Commit 5bf9c473 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Rearrange the BuildReport code

parent 3570da13
......@@ -8,38 +8,29 @@
-- Stability : experimental
-- Portability : portable
--
-- Report data structure
-- Anonymous build report data structure, printing and parsing
--
-----------------------------------------------------------------------------
module Distribution.Client.Reporting (
module Distribution.Client.BuildReports.Anonymous (
BuildReport(..),
InstallOutcome(..),
Outcome(..),
-- * Constructing and writing reports
buildReport,
writeBuildReports,
new,
-- * parsing and pretty printing
parseBuildReport,
parseBuildReports,
showBuildReport,
-- * 'InstallPlan' variants
planPackageBuildReport,
installPlanBuildReports,
writeInstallPlanBuildReports
parse,
parseList,
show,
showList,
) where
import Distribution.Client.Types
( ConfiguredPackage(..), AvailablePackage(..), BuildResult
, AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
( ConfiguredPackage(..), BuildResult )
import qualified Distribution.Client.Types as BR
( BuildResult, BuildFailure(..), BuildSuccess(..)
, DocsResult(..), TestsResult(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
import Distribution.Client.ParseUtils
( parseFields )
import qualified Paths_cabal_install (version)
......@@ -54,25 +45,24 @@ import Distribution.System
( OS, Arch )
import Distribution.Compiler
( CompilerId )
import Distribution.Text
import qualified Distribution.Text as Text
( Text(disp, parse) )
import Distribution.ParseUtils
( FieldDescr(..), ParseResult(..), simpleField, listField, ppFields )
( FieldDescr(..), ParseResult(..)
, simpleField, listField, ppFields, locatedErrorMsg )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, pfail, munch1, char, option, skipSpaces )
import Text.PrettyPrint.HughesPJ as Disp
( Doc, render, char, text, (<+>), (<>) )
import Distribution.Simple.Utils
( comparing, equating )
import qualified Text.PrettyPrint.HughesPJ as Disp
( Doc, render, char, text )
import Text.PrettyPrint.HughesPJ
( (<+>), (<>) )
import Data.List
( unfoldr, groupBy, sortBy )
import Data.Maybe
( catMaybes )
( unfoldr )
import Data.Char as Char
( isAlpha, isAlphaNum )
import System.FilePath
( (</>) )
import Prelude hiding (show)
data BuildReport
= BuildReport {
......@@ -123,35 +113,10 @@ data InstallOutcome
data Outcome = NotTried | Failed | Ok
writeBuildReports :: [(BuildReport, Repo)] -> IO ()
writeBuildReports reports = sequence_
[ appendFile file (concatMap format reports')
| (repo, reports') <- separate reports
, let file = repoLocalDir repo </> "build-reports.log" ]
--TODO: make this concurrency safe, either lock the report file or make sure
-- the writes for each report are atomic (under 4k and flush at boundaries)
where
format r = '\n' : showBuildReport r ++ "\n"
separate :: [(BuildReport, Repo)]
-> [(Repo, [BuildReport])]
separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
. map concat
. groupBy (equating (repoName . head))
. sortBy (comparing (repoName . head))
. groupBy (equating repoName)
. onlyRemote
repoName (_,_,rrepo) = remoteRepoName rrepo
onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote rs =
[ (report, repo, remoteRepo)
| (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
buildReport :: OS -> Arch -> CompilerId -- -> Version
-> ConfiguredPackage -> BR.BuildResult
-> BuildReport
buildReport os' arch' comp (ConfiguredPackage pkg flags deps) result =
new :: OS -> Arch -> CompilerId -- -> Version
-> ConfiguredPackage -> BR.BuildResult
-> BuildReport
new os' arch' comp (ConfiguredPackage pkg flags deps) result =
BuildReport {
package = packageId pkg,
os = os',
......@@ -212,12 +177,14 @@ initialBuildReport = BuildReport {
-- -----------------------------------------------------------------------------
-- Parsing
parseBuildReport :: String -> ParseResult BuildReport
parseBuildReport = parseFields fieldDescrs initialBuildReport
parse :: String -> Either String BuildReport
parse s = case parseFields fieldDescrs initialBuildReport s of
ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror
ParseOk _ report -> Right report
parseBuildReports :: String -> [BuildReport]
parseBuildReports str =
[ report | ParseOk [] report <- map parseBuildReport (split str) ]
parseList :: String -> [BuildReport]
parseList str =
[ report | Right report <- map parse (split str) ]
where
split :: String -> [String]
......@@ -229,33 +196,33 @@ parseBuildReports str =
-- -----------------------------------------------------------------------------
-- Pretty-printing
showBuildReport :: BuildReport -> String
showBuildReport br = Disp.render (ppFields br fieldDescrs)
show :: BuildReport -> String
show br = Disp.render (ppFields br fieldDescrs)
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
fieldDescrs :: [FieldDescr BuildReport]
fieldDescrs =
[ simpleField "package" disp parse
[ simpleField "package" Text.disp Text.parse
package (\v r -> r { package = v })
, simpleField "os" disp parse
, simpleField "os" Text.disp Text.parse
os (\v r -> r { os = v })
, simpleField "arch" disp parse
, simpleField "arch" Text.disp Text.parse
arch (\v r -> r { arch = v })
, simpleField "compiler" disp parse
, simpleField "compiler" Text.disp Text.parse
compiler (\v r -> r { compiler = v })
, simpleField "client" disp parse
, simpleField "client" Text.disp Text.parse
client (\v r -> r { client = v })
, listField "flags" dispFlag parseFlag
flagAssignment (\v r -> r { flagAssignment = v })
, listField "dependencies" disp parse
, listField "dependencies" Text.disp Text.parse
dependencies (\v r -> r { dependencies = v })
, simpleField "install-outcome" disp parse
, simpleField "install-outcome" Text.disp Text.parse
installOutcome (\v r -> r { installOutcome = v })
, simpleField "docs-outcome" disp parse
, simpleField "docs-outcome" Text.disp Text.parse
docsOutcome (\v r -> r { docsOutcome = v })
, simpleField "tests-outcome" disp parse
, simpleField "tests-outcome" Text.disp Text.parse
testsOutcome (\v r -> r { testsOutcome = v })
]
......@@ -269,8 +236,8 @@ parseFlag = do
name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
return (FlagName name, value)
instance Text InstallOutcome where
disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> disp pkgid
instance Text.Text InstallOutcome where
disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
disp DownloadFailed = Disp.text "DownloadFailed"
disp UnpackFailed = Disp.text "UnpackFailed"
disp SetupFailed = Disp.text "SetupFailed"
......@@ -283,7 +250,7 @@ instance Text InstallOutcome where
name <- Parse.munch1 Char.isAlphaNum
case name of
"DependencyFailed" -> do Parse.skipSpaces
pkgid <- parse
pkgid <- Text.parse
return (DependencyFailed pkgid)
"DownloadFailed" -> return DownloadFailed
"UnpackFailed" -> return UnpackFailed
......@@ -294,7 +261,7 @@ instance Text InstallOutcome where
"InstallOk" -> return InstallOk
_ -> Parse.pfail
instance Text Outcome where
instance Text.Text Outcome where
disp NotTried = Disp.text "NotTried"
disp Failed = Disp.text "Failed"
disp Ok = Disp.text "Ok"
......@@ -305,34 +272,3 @@ instance Text Outcome where
"Failed" -> return Failed
"Ok" -> return Ok
_ -> Parse.pfail
-- ------------------------------------------------------------
-- * InstallPlan support
-- ------------------------------------------------------------
writeInstallPlanBuildReports :: InstallPlan -> IO ()
writeInstallPlanBuildReports = writeBuildReports . installPlanBuildReports
installPlanBuildReports :: InstallPlan -> [(BuildReport, Repo)]
installPlanBuildReports plan = catMaybes
. map (planPackageBuildReport os' arch' comp)
. InstallPlan.toList
$ plan
where os' = InstallPlan.planOS plan
arch' = InstallPlan.planArch plan
comp = InstallPlan.planCompiler plan
planPackageBuildReport :: OS -> Arch -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Repo)
planPackageBuildReport os' arch' comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (buildReport os' arch' comp pkg (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (buildReport os' arch' comp pkg (Left result), repo)
_ -> Nothing
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Reporting
-- Copyright : (c) David Waern 2008
-- License : BSD-like
--
-- Maintainer : david.waern@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Anonymous build report data structure, printing and parsing
--
-----------------------------------------------------------------------------
module Distribution.Client.BuildReports.Storage (
-- * Storing and retrieving build reports
storeAnonymous,
storeLocal,
-- retrieve,
-- * 'InstallPlan' support
fromInstallPlan,
) where
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Client.Types
( ConfiguredPackage(..), AvailablePackage(..)
, AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
import Distribution.Client.Config
( defaultCabalDir )
import Distribution.System
( OS, Arch )
import Distribution.Compiler
( CompilerId )
import Distribution.Simple.Utils
( comparing, equating )
import Data.List
( groupBy, sortBy )
import Data.Maybe
( catMaybes )
import System.FilePath
( (</>) )
storeAnonymous :: [(BuildReport, Repo)] -> IO ()
storeAnonymous reports = sequence_
[ appendFile file (concatMap format reports')
| (repo, reports') <- separate reports
, let file = repoLocalDir repo </> "build-reports.log" ]
--TODO: make this concurrency safe, either lock the report file or make sure
-- the writes for each report are atomic (under 4k and flush at boundaries)
where
format r = '\n' : BuildReport.show r ++ "\n"
separate :: [(BuildReport, Repo)]
-> [(Repo, [BuildReport])]
separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
. map concat
. groupBy (equating (repoName . head))
. sortBy (comparing (repoName . head))
. groupBy (equating repoName)
. onlyRemote
repoName (_,_,rrepo) = remoteRepoName rrepo
onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote rs =
[ (report, repo, remoteRepo)
| (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
storeLocal :: [(BuildReport, Repo)] -> IO ()
storeLocal reports = do
cabalDir <- defaultCabalDir
let file = cabalDir </> "build.log"
appendFile file (concatMap (format . fst) reports)
--TODO: make this concurrency safe, either lock the report file or make sure
-- the writes for each report are atomic (under 4k and flush at boundaries)
where
format r = '\n' : BuildReport.show r ++ "\n"
-- ------------------------------------------------------------
-- * InstallPlan support
-- ------------------------------------------------------------
fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
fromInstallPlan plan = catMaybes
. map (fromPlanPackage os' arch' comp)
. InstallPlan.toList
$ plan
where os' = InstallPlan.planOS plan
arch' = InstallPlan.planArch plan
comp = InstallPlan.planCompiler plan
fromPlanPackage :: OS -> Arch -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Repo)
fromPlanPackage os' arch' comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)
_ -> Nothing
......@@ -48,10 +48,8 @@ import Distribution.Client.Types as Available
, DocsResult(..), TestsResult(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Reporting
( writeInstallPlanBuildReports )
import Distribution.Client.Logging
( writeInstallPlanBuildLog )
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import Paths_cabal_install (getBinDir)
......@@ -158,8 +156,10 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
installUnpackedPackage verbosity (setupScriptOptions installed)
miscOptions configFlags' installFlags
pkg mpath useLogFile
writeInstallPlanBuildReports installPlan'
writeInstallPlanBuildLog installPlan'
let buildReports = BuildReports.fromInstallPlan installPlan'
BuildReports.storeAnonymous buildReports
BuildReports.storeLocal buildReports
symlinkBinaries verbosity configFlags installFlags installPlan'
printBuildFailures installPlan'
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Logging
-- Copyright : (c) David Waern 2008
-- License : BSD-like
--
-- Maintainer : david.waern@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Build log data structure
--
-----------------------------------------------------------------------------
module Distribution.Client.Logging (
BuildLogEntry(..),
InstallOutcome(..),
Outcome(..),
-- * Constructing and writing reports
buildLogEntry,
writeBuildLog,
-- * parsing and pretty printing
parseBuildLogEntry,
parseBuildLog,
showBuildLogEntry,
-- * 'InstallPlan' variants
planPackageBuildLogEntry,
installPlanBuildLog,
writeInstallPlanBuildLog
) where
import Distribution.Client.Reporting
( InstallOutcome(..), Outcome(..) )
import Distribution.Client.Types
( ConfiguredPackage(..), BuildResult )
import Distribution.Client.Config
( defaultCabalDir )
import qualified Distribution.Client.Types as BR
( BuildFailure(..), BuildSuccess(..)
, DocsResult(..), TestsResult(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
import Distribution.Client.ParseUtils
( parseFields )
import qualified Paths_cabal_install (version)
import Distribution.Package
( PackageIdentifier(PackageIdentifier), Package(packageId) )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
--import Distribution.Version
-- ( Version )
import Distribution.System
( OS, Arch )
import Distribution.Compiler
( CompilerId )
import Distribution.Text
( Text(disp, parse) )
import Distribution.ParseUtils
( FieldDescr(..), ParseResult(..), simpleField, listField, ppFields )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, {-pfail,-} munch1, char, option )
import Text.PrettyPrint.HughesPJ as Disp
( Doc, render, char, text, (<>) )
import Data.List
( unfoldr )
import Data.Maybe
( catMaybes )
import Data.Char as Char
( isAlphaNum )
import System.FilePath
( (</>) )
--import Network.URI
-- ( URI, uriToString, parseAbsoluteURI )
type BuildLog = [BuildLogEntry]
data BuildLogEntry
= BuildLogEntry {
-- | The package this build report is about
package :: PackageIdentifier,
-- Which hackage server this package is from or local
-- server :: Maybe URI,
-- | The OS and Arch the package was built on
os :: OS,
arch :: Arch,
-- | The Haskell compiler (and hopefully version) used
compiler :: CompilerId,
-- | The uploading client, ie cabal-install-x.y.z
client :: PackageIdentifier,
-- | Which configurations flags we used
flagAssignment :: FlagAssignment,
-- | Which dependent packages we were using exactly
dependencies :: [PackageIdentifier],
-- | Did installing work ok?
installOutcome :: InstallOutcome,
-- Which version of the Cabal library was used to compile the Setup.hs
-- cabalVersion :: Version,
-- Which build tools we were using (with versions)
-- tools :: [PackageIdentifier],
-- | Configure outcome, did configure work ok?
docsOutcome :: Outcome,
-- | Configure outcome, did configure work ok?
testsOutcome :: Outcome
}
writeBuildLog :: BuildLog -> IO ()
writeBuildLog reports = do
cabalDir <- defaultCabalDir
let file = cabalDir </> "build.log"
appendFile file (concatMap format reports)
--TODO: make this concurrency safe, either lock the report file or make sure
-- the writes for each report are atomic (under 4k and flush at boundaries)
where
format r = '\n' : showBuildLogEntry r ++ "\n"
buildLogEntry :: OS -> Arch -> CompilerId -- -> Version
-> ConfiguredPackage -> BuildResult
-> BuildLogEntry
buildLogEntry os' arch' comp (ConfiguredPackage pkg flags deps) result =
BuildLogEntry {
package = packageId pkg,
-- server = Nothing,
os = os',
arch = arch',
compiler = comp,
client = cabalInstallID,
flagAssignment = flags,
dependencies = deps,
installOutcome = convertInstallOutcome,
-- cabalVersion = undefined
docsOutcome = convertDocsOutcome,
testsOutcome = convertTestsOutcome
}
where
cabalInstallID =
PackageIdentifier "cabal-install" Paths_cabal_install.version
convertInstallOutcome = case result of
Left (BR.DependentFailed p) -> DependencyFailed p
Left (BR.UnpackFailed _) -> UnpackFailed
Left (BR.ConfigureFailed _) -> ConfigureFailed
Left (BR.BuildFailed _) -> BuildFailed
Left (BR.InstallFailed _) -> InstallFailed
Right (BR.BuildOk _ _) -> InstallOk
convertDocsOutcome = case result of
Left _ -> NotTried
Right (BR.BuildOk BR.DocsNotTried _) -> NotTried
Right (BR.BuildOk BR.DocsFailed _) -> Failed
Right (BR.BuildOk BR.DocsOk _) -> Ok
convertTestsOutcome = case result of
Left _ -> NotTried
Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
Right (BR.BuildOk _ BR.TestsFailed) -> Failed
Right (BR.BuildOk _ BR.TestsOk) -> Ok
-- ------------------------------------------------------------
-- * External format
-- ------------------------------------------------------------
initialBuildLogEntry :: BuildLogEntry
initialBuildLogEntry = BuildLogEntry {
package = requiredField "package",
-- server = Nothing,
os = requiredField "os",
arch = requiredField "arch",
compiler = requiredField "compiler",
client = requiredField "client",
flagAssignment = [],
dependencies = [],
installOutcome = requiredField "install-outcome",
-- cabalVersion = Nothing,
-- tools = [],
docsOutcome = NotTried,
testsOutcome = NotTried
}
where
requiredField fname = error ("required field: " ++ fname)
-- -----------------------------------------------------------------------------
-- Parsing
parseBuildLogEntry :: String -> ParseResult BuildLogEntry
parseBuildLogEntry = parseFields fieldDescrs initialBuildLogEntry
parseBuildLog :: String -> [BuildLogEntry]
parseBuildLog str =
[ report | ParseOk [] report <- map parseBuildLogEntry (split str) ]
where