Commit 1070b225 authored by Chris Wong's avatar Chris Wong
Browse files

Add --report-planning-failure option to cabal-install

parent 5c70361b
...@@ -18,6 +18,7 @@ module Distribution.Client.BuildReports.Anonymous ( ...@@ -18,6 +18,7 @@ module Distribution.Client.BuildReports.Anonymous (
-- * Constructing and writing reports -- * Constructing and writing reports
new, new,
new',
-- * parsing and pretty printing -- * parsing and pretty printing
parse, parse,
...@@ -106,7 +107,8 @@ data BuildReport ...@@ -106,7 +107,8 @@ data BuildReport
} }
data InstallOutcome data InstallOutcome
= DependencyFailed PackageIdentifier = PlanningFailed
| DependencyFailed PackageIdentifier
| DownloadFailed | DownloadFailed
| UnpackFailed | UnpackFailed
| SetupFailed | SetupFailed
...@@ -124,8 +126,13 @@ new :: OS -> Arch -> CompilerId -- -> Version ...@@ -124,8 +126,13 @@ new :: OS -> Arch -> CompilerId -- -> Version
-> ConfiguredPackage -> BR.BuildResult -> ConfiguredPackage -> BR.BuildResult
-> BuildReport -> BuildReport
new os' arch' comp (ConfiguredPackage pkg flags _ deps) result = 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 { BuildReport {
package = packageId pkg, package = pkgid,
os = os', os = os',
arch = arch', arch = arch',
compiler = comp, compiler = comp,
...@@ -139,6 +146,7 @@ new os' arch' comp (ConfiguredPackage pkg flags _ deps) result = ...@@ -139,6 +146,7 @@ new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
} }
where where
convertInstallOutcome = case result of convertInstallOutcome = case result of
Left BR.PlanningFailed -> PlanningFailed
Left (BR.DependentFailed p) -> DependencyFailed p Left (BR.DependentFailed p) -> DependencyFailed p
Left (BR.DownloadFailed _) -> DownloadFailed Left (BR.DownloadFailed _) -> DownloadFailed
Left (BR.UnpackFailed _) -> UnpackFailed Left (BR.UnpackFailed _) -> UnpackFailed
...@@ -276,6 +284,7 @@ parseFlag = do ...@@ -276,6 +284,7 @@ parseFlag = do
flag -> return (FlagName flag, True) flag -> return (FlagName flag, True)
instance Text.Text InstallOutcome where instance Text.Text InstallOutcome where
disp PlanningFailed = Disp.text "PlanningFailed"
disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
disp DownloadFailed = Disp.text "DownloadFailed" disp DownloadFailed = Disp.text "DownloadFailed"
disp UnpackFailed = Disp.text "UnpackFailed" disp UnpackFailed = Disp.text "UnpackFailed"
...@@ -289,6 +298,7 @@ instance Text.Text InstallOutcome where ...@@ -289,6 +298,7 @@ instance Text.Text InstallOutcome where
parse = do parse = do
name <- Parse.munch1 Char.isAlphaNum name <- Parse.munch1 Char.isAlphaNum
case name of case name of
"PlanningFailed" -> return PlanningFailed
"DependencyFailed" -> do Parse.skipSpaces "DependencyFailed" -> do Parse.skipSpaces
pkgid <- Text.parse pkgid <- Text.parse
return (DependencyFailed pkgid) return (DependencyFailed pkgid)
......
...@@ -20,6 +20,7 @@ module Distribution.Client.BuildReports.Storage ( ...@@ -20,6 +20,7 @@ module Distribution.Client.BuildReports.Storage (
-- * 'InstallPlan' support -- * 'InstallPlan' support
fromInstallPlan, fromInstallPlan,
fromPlanningFailure,
) where ) where
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
...@@ -30,6 +31,10 @@ import qualified Distribution.Client.InstallPlan as InstallPlan ...@@ -30,6 +31,10 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan import Distribution.Client.InstallPlan
( InstallPlan ) ( InstallPlan )
import Distribution.Package
( PackageId )
import Distribution.PackageDescription
( FlagAssignment )
import Distribution.Simple.InstallDirs import Distribution.Simple.InstallDirs
( PathTemplate, fromPathTemplate ( PathTemplate, fromPathTemplate
, initialPathTemplateEnv, substPathTemplate ) , initialPathTemplateEnv, substPathTemplate )
...@@ -127,3 +132,11 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of ...@@ -127,3 +132,11 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
-> Just $ (BuildReport.new os arch comp pkg (Left result), repo) -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
_ -> Nothing _ -> Nothing
fromPlanningFailure :: Platform -> CompilerId
-> [PackageId] -> FlagAssignment -> [Repo] -> [(BuildReport, Repo)]
fromPlanningFailure (Platform arch os) comp pkgids flags repos =
[ (BuildReport.new' os arch comp pkgid flags [] (Left PlanningFailed), repo)
| pkgid <- pkgids
, repo@Repo{ repoKind = Left RemoteRepo{} } <- repos
]
...@@ -32,7 +32,7 @@ import Data.List ...@@ -32,7 +32,7 @@ import Data.List
( isPrefixOf, unfoldr, nub, sort, (\\) ) ( isPrefixOf, unfoldr, nub, sort, (\\) )
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe import Data.Maybe
( isJust, fromMaybe, maybeToList ) ( isJust, fromMaybe, mapMaybe, maybeToList )
import Control.Exception as Exception import Control.Exception as Exception
( Exception(toException), bracket, catches ( Exception(toException), bracket, catches
, Handler(Handler), handleJust, IOException, SomeException ) , Handler(Handler), handleJust, IOException, SomeException )
...@@ -44,6 +44,8 @@ import System.Exit ...@@ -44,6 +44,8 @@ import System.Exit
( ExitCode(..) ) ( ExitCode(..) )
import Distribution.Compat.Exception import Distribution.Compat.Exception
( catchIO, catchExit ) ( catchIO, catchExit )
import Control.Applicative
( (<$>) )
import Control.Monad import Control.Monad
( when, unless ) ( when, unless )
import System.Directory import System.Directory
...@@ -87,7 +89,7 @@ import Distribution.Client.SetupWrapper ...@@ -87,7 +89,7 @@ import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan ) ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
import qualified Distribution.Client.InstallSymlink as InstallSymlink import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries ) ( symlinkBinaries )
import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.PackageIndex as SourcePackageIndex
...@@ -121,7 +123,7 @@ import Distribution.Simple.InstallDirs as InstallDirs ...@@ -121,7 +123,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv ) , initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package import Distribution.Package
( PackageIdentifier, PackageId, packageName, packageVersion ( PackageIdentifier(..), PackageId, packageName, packageVersion
, Package(..), PackageFixedDeps(..) , Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion, InstalledPackageId ) , Dependency(..), thisPackageVersion, InstalledPackageId )
import qualified Distribution.PackageDescription as PackageDescription import qualified Distribution.PackageDescription as PackageDescription
...@@ -133,7 +135,7 @@ import Distribution.PackageDescription.Configuration ...@@ -133,7 +135,7 @@ import Distribution.PackageDescription.Configuration
import Distribution.ParseUtils import Distribution.ParseUtils
( showPWarning ) ( showPWarning )
import Distribution.Version import Distribution.Version
( Version ) ( Version, VersionRange, foldVersionRange )
import Distribution.Simple.Utils as Utils import Distribution.Simple.Utils as Utils
( notice, info, warn, debug, debugNoWrap, die ( notice, info, warn, debug, debugNoWrap, die
, intercalate, withTempDirectory ) , intercalate, withTempDirectory )
...@@ -187,10 +189,15 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo ...@@ -187,10 +189,15 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
userTargets0 = do userTargets0 = do
installContext <- makeInstallContext verbosity args (Just userTargets0) installContext <- makeInstallContext verbosity args (Just userTargets0)
installPlan <- foldProgress logMsg die' return =<< planResult <- foldProgress logMsg (return . Left) (return . Right) =<<
makeInstallPlan verbosity args installContext makeInstallPlan verbosity args installContext
processInstallPlan verbosity args installContext installPlan case planResult of
Left message -> do
reportPlanningFailure verbosity args installContext
die' message
Right installPlan ->
processInstallPlan verbosity args installContext installPlan
where where
args :: InstallArgs args :: InstallArgs
args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo, args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
...@@ -641,6 +648,54 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of ...@@ -641,6 +648,54 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
-- * Post installation stuff -- * 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 -> IO ()
reportPlanningFailure verbosity
(_, repos, comp, platform, _, _, _
,_, configFlags, _, installFlags, _)
(_, sourcePkgDb, _, pkgSpecifiers) = 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) repos
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
where
reportFailure = fromFlag (installReportPlanningFailure installFlags)
-- | 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 -- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes: -- of packages. This includes:
-- --
...@@ -836,6 +891,9 @@ printBuildFailures plan = ...@@ -836,6 +891,9 @@ printBuildFailures plan =
InstallFailed e -> " failed during the final install step." InstallFailed e -> " failed during the final install step."
++ showException e ++ 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 showException e = " The exception was:\n " ++ show e ++ maybeOOM e
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
maybeOOM _ = "" maybeOOM _ = ""
......
...@@ -953,6 +953,7 @@ data InstallFlags = InstallFlags { ...@@ -953,6 +953,7 @@ data InstallFlags = InstallFlags {
installSummaryFile :: [PathTemplate], installSummaryFile :: [PathTemplate],
installLogFile :: Flag PathTemplate, installLogFile :: Flag PathTemplate,
installBuildReports :: Flag ReportLevel, installBuildReports :: Flag ReportLevel,
installReportPlanningFailure :: Flag Bool,
installSymlinkBinDir :: Flag FilePath, installSymlinkBinDir :: Flag FilePath,
installOneShot :: Flag Bool, installOneShot :: Flag Bool,
installNumJobs :: Flag (Maybe Int), installNumJobs :: Flag (Maybe Int),
...@@ -979,6 +980,7 @@ defaultInstallFlags = InstallFlags { ...@@ -979,6 +980,7 @@ defaultInstallFlags = InstallFlags {
installSummaryFile = mempty, installSummaryFile = mempty,
installLogFile = mempty, installLogFile = mempty,
installBuildReports = Flag NoReports, installBuildReports = Flag NoReports,
installReportPlanningFailure = Flag False,
installSymlinkBinDir = mempty, installSymlinkBinDir = mempty,
installOneShot = Flag False, installOneShot = Flag False,
installNumJobs = mempty, installNumJobs = mempty,
...@@ -1157,6 +1159,11 @@ installOptions showOrParseArgs = ...@@ -1157,6 +1159,11 @@ installOptions showOrParseArgs =
(toFlag `fmap` parse)) (toFlag `fmap` parse))
(flagToList . fmap display)) (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"] , option [] ["one-shot"]
"Do not record the packages in the world file." "Do not record the packages in the world file."
installOneShot (\v flags -> flags { installOneShot = v }) installOneShot (\v flags -> flags { installOneShot = v })
...@@ -1200,6 +1207,7 @@ instance Monoid InstallFlags where ...@@ -1200,6 +1207,7 @@ instance Monoid InstallFlags where
installSummaryFile = mempty, installSummaryFile = mempty,
installLogFile = mempty, installLogFile = mempty,
installBuildReports = mempty, installBuildReports = mempty,
installReportPlanningFailure = mempty,
installSymlinkBinDir = mempty, installSymlinkBinDir = mempty,
installOneShot = mempty, installOneShot = mempty,
installNumJobs = mempty, installNumJobs = mempty,
...@@ -1224,6 +1232,7 @@ instance Monoid InstallFlags where ...@@ -1224,6 +1232,7 @@ instance Monoid InstallFlags where
installSummaryFile = combine installSummaryFile, installSummaryFile = combine installSummaryFile,
installLogFile = combine installLogFile, installLogFile = combine installLogFile,
installBuildReports = combine installBuildReports, installBuildReports = combine installBuildReports,
installReportPlanningFailure = combine installReportPlanningFailure,
installSymlinkBinDir = combine installSymlinkBinDir, installSymlinkBinDir = combine installSymlinkBinDir,
installOneShot = combine installOneShot, installOneShot = combine installOneShot,
installNumJobs = combine installNumJobs, installNumJobs = combine installNumJobs,
......
...@@ -195,7 +195,8 @@ data Repo = Repo { ...@@ -195,7 +195,8 @@ data Repo = Repo {
-- ------------------------------------------------------------ -- ------------------------------------------------------------
type BuildResult = Either BuildFailure BuildSuccess type BuildResult = Either BuildFailure BuildSuccess
data BuildFailure = DependentFailed PackageId data BuildFailure = PlanningFailed
| DependentFailed PackageId
| DownloadFailed SomeException | DownloadFailed SomeException
| UnpackFailed SomeException | UnpackFailed SomeException
| ConfigureFailed 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