Merge pull request #2025 from lfairy/reports++

Improve build reporting for cabal-install

cabal-install/Distribution/Client/BuildReports/Anonymous.hs

@@ -18,6 +18,7 @@ module Distribution.Client.BuildReports.Anonymous (
 
  -- * Constructing and writing reports
  new,
+ new',
 
  -- * parsing and pretty printing
  parse,
@@ -106,7 +107,8 @@ data BuildReport
  }
 
 data InstallOutcome
- = DependencyFailed PackageIdentifier
+ = PlanningFailed
+ | DependencyFailed PackageIdentifier
  | DownloadFailed
  | UnpackFailed
  | SetupFailed
@@ -124,8 +126,13 @@ new :: OS -> Arch -> CompilerId -- -> Version
  -> ConfiguredPackage -> BR.BuildResult
  -> BuildReport
 new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
+ new' os' arch' comp (packageId pkg) flags deps result
+
+new' :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
+ -> [PackageIdentifier] -> BR.BuildResult -> BuildReport
+new' os' arch' comp pkgid flags deps result =
  BuildReport {
- package = packageId pkg,
+ package = pkgid,
  os = os',
  arch = arch',
  compiler = comp,
@@ -139,6 +146,7 @@ new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
  }
  where
  convertInstallOutcome = case result of
+ Left BR.PlanningFailed -> PlanningFailed
  Left (BR.DependentFailed p) -> DependencyFailed p
  Left (BR.DownloadFailed _) -> DownloadFailed
  Left (BR.UnpackFailed _) -> UnpackFailed
@@ -276,6 +284,7 @@ parseFlag = do
  flag -> return (FlagName flag, True)
 
 instance Text.Text InstallOutcome where
+ disp PlanningFailed = Disp.text "PlanningFailed"
  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
  disp DownloadFailed = Disp.text "DownloadFailed"
  disp UnpackFailed = Disp.text "UnpackFailed"
@@ -289,6 +298,7 @@ instance Text.Text InstallOutcome where
  parse = do
  name <- Parse.munch1 Char.isAlphaNum
  case name of
+ "PlanningFailed" -> return PlanningFailed
  "DependencyFailed" -> do Parse.skipSpaces
  pkgid <- Text.parse
  return (DependencyFailed pkgid)

cabal-install/Distribution/Client/BuildReports/Storage.hs

@@ -20,6 +20,7 @@ module Distribution.Client.BuildReports.Storage (
 
  -- * 'InstallPlan' support
  fromInstallPlan,
+ fromPlanningFailure,
  ) where
 
 import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
@@ -30,6 +31,10 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.InstallPlan
  ( InstallPlan )
 
+import Distribution.Package
+ ( PackageId )
+import Distribution.PackageDescription
+ ( FlagAssignment )
 import Distribution.Simple.InstallDirs
  ( PathTemplate, fromPathTemplate
  , initialPathTemplateEnv, substPathTemplate )
@@ -49,7 +54,7 @@ import System.FilePath
 import System.Directory
  ( createDirectoryIfMissing )
 
-storeAnonymous :: [(BuildReport, Repo)] -> IO ()
+storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
 storeAnonymous reports = sequence_
  [ appendFile file (concatMap format reports')
  | (repo, reports') <- separate reports
@@ -59,7 +64,7 @@ storeAnonymous reports = sequence_
 
  where
  format r = '\n' : BuildReport.show r ++ "\n"
- separate :: [(BuildReport, Repo)]
+ separate :: [(BuildReport, Maybe Repo)]
  -> [(Repo, [BuildReport])]
  separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
  . map concat
@@ -69,12 +74,12 @@ storeAnonymous reports = sequence_
  . onlyRemote
  repoName (_,_,rrepo) = remoteRepoName rrepo
 
- onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
+ onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]
  onlyRemote rs =
  [ (report, repo, remoteRepo)
- | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
+ | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]
 
-storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO ()
+storeLocal :: [PathTemplate] -> [(BuildReport, Maybe Repo)] -> Platform -> IO ()
 storeLocal templates reports platform = sequence_
  [ do createDirectoryIfMissing True (takeDirectory file)
  appendFile file output
@@ -109,7 +114,7 @@ storeLocal templates reports platform = sequence_
 -- * InstallPlan support
 -- ------------------------------------------------------------
 
-fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
+fromInstallPlan :: InstallPlan -> [(BuildReport, Maybe Repo)]
 fromInstallPlan plan = catMaybes
  . map (fromPlanPackage platform comp)
  . InstallPlan.toList
@@ -119,16 +124,24 @@ fromInstallPlan plan = catMaybes
 
 fromPlanPackage :: Platform -> CompilerId
  -> InstallPlan.PlanPackage
- -> Maybe (BuildReport, Repo)
+ -> Maybe (BuildReport, Maybe Repo)
 fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
 
- InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
+ InstallPlan.Installed pkg@(ReadyPackage srcPkg _ _ _) result
  -> Just $ (BuildReport.new os arch comp
- (readyPackageToConfiguredPackage pkg) (Right result), repo)
+ (readyPackageToConfiguredPackage pkg) (Right result), extractRepo srcPkg)
 
- InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
- -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
+ InstallPlan.Failed pkg@(ConfiguredPackage srcPkg _ _ _) result
+ -> Just $ (BuildReport.new os arch comp pkg (Left result), extractRepo srcPkg)
 
  _ -> Nothing
+
+ where
+ extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo
+ extractRepo _ = Nothing
+
+fromPlanningFailure :: Platform -> CompilerId
+ -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
+fromPlanningFailure (Platform arch os) comp pkgids flags =
+ [ (BuildReport.new' os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
+ | pkgid <- pkgids ]

cabal-install/Distribution/Client/Install.hs

@@ -32,7 +32,7 @@ import Data.List
  ( isPrefixOf, unfoldr, nub, sort, (\\) )
 import qualified Data.Set as S
 import Data.Maybe
- ( isJust, fromMaybe, maybeToList )
+ ( isJust, fromMaybe, mapMaybe, maybeToList )
 import Control.Exception as Exception
  ( Exception(toException), bracket, catches
  , Handler(Handler), handleJust, IOException, SomeException )
@@ -44,8 +44,10 @@ import System.Exit
  ( ExitCode(..) )
 import Distribution.Compat.Exception
  ( catchIO, catchExit )
+import Control.Applicative
+ ( (<$>) )
 import Control.Monad
- ( when, unless )
+ ( forM_, when, unless )
 import System.Directory
  ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
  createDirectoryIfMissing, removeFile, renameDirectory )
@@ -87,7 +89,7 @@ import Distribution.Client.SetupWrapper
  ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
 import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
 import qualified Distribution.Client.BuildReports.Storage as BuildReports
- ( storeAnonymous, storeLocal, fromInstallPlan )
+ ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
 import qualified Distribution.Client.InstallSymlink as InstallSymlink
  ( symlinkBinaries )
 import qualified Distribution.Client.PackageIndex as SourcePackageIndex
@@ -99,7 +101,7 @@ import Distribution.Client.JobControl
 
 import Distribution.Simple.Compiler
  ( CompilerId(..), Compiler(compilerId), compilerFlavor
- , PackageDB(..), PackageDBStack )
+ , packageKeySupported , PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program (ProgramConfiguration,
  defaultProgramConfiguration)
 import qualified Distribution.Simple.InstallDirs as InstallDirs
@@ -121,8 +123,8 @@ import Distribution.Simple.InstallDirs as InstallDirs
  ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
  , initialPathTemplateEnv, installDirsTemplateEnv )
 import Distribution.Package
- ( PackageIdentifier, PackageId, packageName, packageVersion
- , Package(..), PackageFixedDeps(..), PackageKey
+ ( PackageIdentifier(..), PackageId, packageName, packageVersion
+ , Package(..), PackageFixedDeps(..), PackageKey, mkPackageKey
  , Dependency(..), thisPackageVersion, InstalledPackageId )
 import qualified Distribution.PackageDescription as PackageDescription
 import Distribution.PackageDescription
@@ -133,7 +135,7 @@ import Distribution.PackageDescription.Configuration
 import Distribution.ParseUtils
  ( showPWarning )
 import Distribution.Version
- ( Version )
+ ( Version, VersionRange, foldVersionRange )
 import Distribution.Simple.Utils as Utils
  ( notice, info, warn, debug, debugNoWrap, die
  , intercalate, withTempDirectory )
@@ -187,10 +189,15 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
  userTargets0 = do
 
  installContext <- makeInstallContext verbosity args (Just userTargets0)
- installPlan <- foldProgress logMsg die' return =<<
+ planResult  <- foldProgress logMsg (return . Left) (return . Right) =<<
  makeInstallPlan verbosity args installContext
 
- processInstallPlan verbosity args installContext installPlan
+ case planResult of
+ Left message -> do
+ reportPlanningFailure verbosity args installContext message
+ die' message
+ Right installPlan ->
+ processInstallPlan verbosity args installContext installPlan
  where
  args :: InstallArgs
  args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
@@ -596,12 +603,11 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
  showLatest :: ReadyPackage -> String
  showLatest pkg = case mLatestVersion of
  Just latestVersion ->
- if pkgVersion < latestVersion
+ if packageVersion pkg < latestVersion
  then (" (latest: " ++ display latestVersion ++ ")")
  else ""
  Nothing -> ""
  where
- pkgVersion = packageVersion pkg
  mLatestVersion :: Maybe Version
  mLatestVersion = case SourcePackageIndex.lookupPackageName
  (packageIndex sourcePkgDb)
@@ -643,6 +649,70 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
 -- * Post installation stuff
 -- ------------------------------------------------------------
 
+-- | Report a solver failure. This works slightly differently to
+-- 'postInstallActions', as (by definition) we don't have an install plan.
+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO ()
+reportPlanningFailure verbosity
+ (_, _, comp, platform, _, _, _
+ ,_, configFlags, _, installFlags, _)
+ (_, sourcePkgDb, _, pkgSpecifiers)
+ message = do
+
+ when reportFailure $ do
+
+ -- Only create reports for explicitly named packages
+ let pkgids =
+ filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
+ mapMaybe theSpecifiedPackage pkgSpecifiers
+
+ buildReports = BuildReports.fromPlanningFailure platform (compilerId comp)
+ pkgids (configConfigurationsFlags configFlags)
+
+ when (not (null buildReports)) $
+ notice verbosity $
+ "Notice: this solver failure will be reported for "
+ ++ intercalate "," (map display pkgids)
+
+ -- Save reports
+ BuildReports.storeLocal (installSummaryFile installFlags) buildReports platform
+
+ -- Save solver log
+ case logFile of
+ Nothing -> return ()
+ Just template -> forM_ pkgids $ \pkgid ->
+ let env = initialPathTemplateEnv pkgid dummyPackageKey
+ (compilerId comp) platform
+ path = fromPathTemplate $ substPathTemplate env template
+ in writeFile path message
+
+ where
+ reportFailure = fromFlag (installReportPlanningFailure installFlags)
+ logFile = flagToMaybe (installLogFile installFlags)
+
+ -- A PackageKey is calculated from the transitive closure of
+ -- dependencies, but when the solver fails we don't have that.
+ -- So we fail.
+ dummyPackageKey = error "reportPlanningFailure: package key not available"
+
+-- | If a 'PackageSpecifier' refers to a single package, return Just that package.
+theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
+theSpecifiedPackage pkgSpec =
+ case pkgSpec of
+ NamedPackage name [PackageConstraintVersion name' version]
+ | name == name' -> PackageIdentifier name <$> trivialRange version
+ NamedPackage _ _ -> Nothing
+ SpecificSourcePackage pkg -> Just $ packageId pkg
+ where
+ -- | If a range includes only a single version, return Just that version.
+ trivialRange :: VersionRange -> Maybe Version
+ trivialRange = foldVersionRange
+ Nothing
+ Just -- "== v"
+ (\_ -> Nothing)
+ (\_ -> Nothing)
+ (\_ _ -> Nothing)
+ (\_ _ -> Nothing)
+
 -- | Various stuff we do after successful or unsuccessfully installing a bunch
 -- of packages. This includes:
 --
@@ -693,7 +763,7 @@ postInstallActions verbosity
  worldFile = fromFlag $ globalWorldFile globalFlags
 
 storeDetailedBuildReports :: Verbosity -> FilePath
- -> [(BuildReports.BuildReport, Repo)] -> IO ()
+ -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()
 storeDetailedBuildReports verbosity logsDir reports = sequence_
  [ do dotCabal <- defaultCabalDir
  let logFileName = display (BuildReports.package report) <.> "log"
@@ -706,7 +776,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
  createDirectoryIfMissing True reportsDir -- FIXME
  writeFile reportFile (show (BuildReports.show report, buildLog))
 
- | (report, Repo { repoKind = Left remoteRepo }) <- reports
+ | (report, Just Repo { repoKind = Left remoteRepo }) <- reports
  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
 
  where
@@ -841,6 +911,9 @@ printBuildFailures plan =
  InstallFailed e -> " failed during the final install step."
  ++ showException e
 
+ -- This will never happen, but we include it for completeness
+ PlanningFailed -> " failed during the planning phase."
+
  showException e = " The exception was:\n " ++ show e ++ maybeOOM e
 #ifdef mingw32_HOST_OS
  maybeOOM _ = ""

cabal-install/Distribution/Client/Setup.hs

@@ -973,6 +973,7 @@ data InstallFlags = InstallFlags {
  installSummaryFile :: [PathTemplate],
  installLogFile :: Flag PathTemplate,
  installBuildReports :: Flag ReportLevel,
+ installReportPlanningFailure :: Flag Bool,
  installSymlinkBinDir :: Flag FilePath,
  installOneShot :: Flag Bool,
  installNumJobs :: Flag (Maybe Int),
@@ -999,6 +1000,7 @@ defaultInstallFlags = InstallFlags {
  installSummaryFile = mempty,
  installLogFile = mempty,
  installBuildReports = Flag NoReports,
+ installReportPlanningFailure = Flag False,
  installSymlinkBinDir = mempty,
  installOneShot = Flag False,
  installNumJobs = mempty,
@@ -1177,6 +1179,11 @@ installOptions showOrParseArgs =
  (toFlag `fmap` parse))
  (flagToList . fmap display))
 
+ , option [] ["report-planning-failure"]
+ "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."
+ installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })
+ trueArg
+
  , option [] ["one-shot"]
  "Do not record the packages in the world file."
  installOneShot (\v flags -> flags { installOneShot = v })
@@ -1220,6 +1227,7 @@ instance Monoid InstallFlags where
  installSummaryFile = mempty,
  installLogFile = mempty,
  installBuildReports = mempty,
+ installReportPlanningFailure = mempty,
  installSymlinkBinDir = mempty,
  installOneShot = mempty,
  installNumJobs = mempty,
@@ -1244,6 +1252,7 @@ instance Monoid InstallFlags where
  installSummaryFile = combine installSummaryFile,
  installLogFile = combine installLogFile,
  installBuildReports = combine installBuildReports,
+ installReportPlanningFailure = combine installReportPlanningFailure,
  installSymlinkBinDir = combine installSymlinkBinDir,
  installOneShot = combine installOneShot,
  installNumJobs = combine installNumJobs,

cabal-install/Distribution/Client/Types.hs

@@ -206,7 +206,8 @@ data Repo = Repo {
 -- ------------------------------------------------------------
 
 type BuildResult = Either BuildFailure BuildSuccess
-data BuildFailure = DependentFailed PackageId
+data BuildFailure = PlanningFailed
+ | DependentFailed PackageId
  | DownloadFailed SomeException
  | UnpackFailed SomeException
  | ConfigureFailed SomeException