diff --git a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs index 23d5681b9cd..c6d6b1014c3 100644 --- a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +++ b/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) diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs index 390a02cdbc1..eb1ccc7b0d2 100644 --- a/cabal-install/Distribution/Client/BuildReports/Storage.hs +++ b/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 ] diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index d3abbdd3cc7..3bee4fcca6f 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/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 _ = "" diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index f680c394fd9..987108a4727 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/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, diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index ed8b10a935c..e58c665a4fe 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/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