Commit e1d8947a authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Merge pull request #2025 from lfairy/reports++

Improve build reporting for cabal-install
parents cd89a6c6 47cc3de6
......@@ -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)
......
......@@ -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 ]
......@@ -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 _ = ""
......
......@@ -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,
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment