diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 83baa59675f832ed5d1cf587e190f82625a5b788..3cbf10d8c5af1f8f06783baab5e0da84079c6565 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -99,7 +99,8 @@ build-8.8:
- nix run -f ./ci -c run-ci
after_script:
- - nix run -f ./ci -c xz results.json
+ - nix run -f ./ci -c tar -cJf ../../results.tar.xz -C ci/run \
+ results.json logs
after_script:
- ls -lh
diff --git a/ci/TestPatches.hs b/ci/TestPatches.hs
index 191f7c5dd1de7ab97151d2eb7baa9cdd371676fa..db2ab2d505aef17ee6dc09a9a10ccfd938eac5ce 100644
--- a/ci/TestPatches.hs
+++ b/ci/TestPatches.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module TestPatches
( testPatches
@@ -109,7 +110,7 @@ testPatches cfg = do
| otherwise
= S.fromList packages
- let build :: (Cabal.PackageName, Version) -> IO [TestedPatch]
+ let build :: (Cabal.PackageName, Version) -> IO [TestedPatch LogOutput]
build (pname, ver) = do
res <- buildPackage cfg pname ver
let tpatch = TestedPatch { patchedPackageName = PkgName $ T.pack $ display pname
@@ -121,7 +122,7 @@ testPatches cfg = do
let runResult = RunResult testedPatches
print $ resultSummary (configExpectedBrokenPkgs cfg) runResult
- BSL.writeFile "results.json" $ encode runResult
+ BSL.writeFile "results.json" . encode =<< writeLogs "logs" runResult
case failedPatches (configExpectedBrokenPkgs cfg) runResult of
[] -> return ()
badPatches -> do
@@ -131,21 +132,38 @@ testPatches cfg = do
])
exitWith $ ExitFailure 1
-failedPatches :: BrokenPackages -> RunResult -> [TestedPatch]
+writeLogs :: FilePath -> RunResult LogOutput -> IO (RunResult ())
+writeLogs logDir runResult = do
+ createDirectoryIfMissing True logDir
+ let failedUnits = [ (unitId, log)
+ | (unitId, (buildInfo, result)) <- M.toList $ runResultUnits runResult
+ , Just log <- pure $
+ case result of
+ BuildSucceeded log -> Just log
+ BuildFailed log -> Just log
+ _ -> Nothing
+ ]
+ mapM_ writeLog failedUnits
+ return (() <$ runResult)
+ where
+ writeLog (UnitId unitId, LogOutput log) = TIO.writeFile logPath log
+ where logPath = logDir </> T.unpack unitId
+
+failedPatches :: BrokenPackages -> RunResult log -> [TestedPatch log]
failedPatches broken (RunResult testedPatches) =
filter failed testedPatches
where
failed tp =
patchFailed tp /= failureExpected broken (patchedPackageName tp)
- patchFailed :: TestedPatch -> Bool
+ patchFailed :: TestedPatch log -> Bool
patchFailed tp =
case patchedPackageResult tp of
PackagePlanningFailed _ -> True
PackageResult False _ -> True
_ -> False
-resultSummary :: BrokenPackages -> RunResult -> Doc
+resultSummary :: forall log. BrokenPackages -> RunResult log -> Doc
resultSummary broken runResult = vcat
[ "Total units built:" <+> pshow (length allUnits)
, ""
@@ -171,14 +189,9 @@ resultSummary broken runResult = vcat
, PackagePlanningFailed _ <- pure $ patchedPackageResult tpatch
]
- allUnits :: M.Map UnitId (BuildInfo, BuildResult)
- allUnits = M.unions
- [ units
- | tpatch <- testedPatches runResult
- , PackageResult _ units <- pure $ patchedPackageResult tpatch
- ]
+ allUnits = runResultUnits runResult
- failedUnits :: M.Map UnitId (BuildInfo, BuildResult)
+ failedUnits :: M.Map UnitId (BuildInfo, BuildResult log)
failedUnits = M.filter failed allUnits
where failed (_, BuildFailed _) = True
failed _ = False
@@ -202,7 +215,7 @@ prettyPackageVersion :: Cabal.PackageName -> Version -> Doc
prettyPackageVersion pname version =
prettyPkgVer (toPkgName pname) (toVer version)
-buildPackage :: Config -> Cabal.PackageName -> Version -> IO PackageResult
+buildPackage :: Config -> Cabal.PackageName -> Version -> IO (PackageResult LogOutput)
buildPackage cfg pname version = do
logMsg $ "=> Building" <+> prettyPackageVersion pname version
compilerId <- getCompilerId (configCompiler cfg)
@@ -257,21 +270,21 @@ buildPackage cfg pname version = do
}
]
- checkUnit :: FilePath -> Unit -> IO BuildResult
+ checkUnit :: FilePath -> Unit -> IO (BuildResult LogOutput)
checkUnit logDir unit
| UnitTypeBuiltin <- uType unit = return BuildPreexisted
- | UnitTypeLocal <- uType unit = return $ BuildSucceeded "inplace"
+ | UnitTypeLocal <- uType unit = return $ BuildSucceeded (LogOutput "<<inplace>>")
| otherwise = do
exists <- doesFileExist logPath
case exists of
True -> do
buildLog <- TE.decodeUtf8With TE.lenientDecode <$> BS.readFile logPath
if | T.null buildLog
- -> return $ BuildFailed buildLog
+ -> return $ BuildFailed (LogOutput buildLog)
| any isInstallingLine $ take 5 $ reverse $ T.lines buildLog
- -> return $ BuildSucceeded buildLog
+ -> return $ BuildSucceeded (LogOutput buildLog)
| otherwise
- -> return $ BuildFailed buildLog
+ -> return $ BuildFailed (LogOutput buildLog)
False -> return BuildNotAttempted
where
isInstallingLine line = "Installing" `T.isPrefixOf` line
@@ -281,8 +294,8 @@ buildPackage cfg pname version = do
mergeInfoPlan :: Ord k
=> M.Map k BuildInfo
- -> M.Map k BuildResult
- -> M.Map k (BuildInfo, BuildResult)
+ -> M.Map k (BuildResult log)
+ -> M.Map k (BuildInfo, BuildResult log)
mergeInfoPlan = M.merge err err (M.zipWithMatched $ \_ x y -> (x,y))
where
err = M.mapMissing $ \_ _ -> error "error merging"
@@ -357,11 +370,11 @@ setup cfg = do
repoName = "local"
-- | Compute for each unit which of its dependencies failed to build.
-failedDeps :: M.Map UnitId (BuildInfo, BuildResult) -> M.Map UnitId (S.Set UnitId)
+failedDeps :: M.Map UnitId (BuildInfo, BuildResult log) -> M.Map UnitId (S.Set UnitId)
failedDeps pkgs =
let res = fmap f pkgs -- N.B. Knot-tied
- f :: (BuildInfo, BuildResult) -> S.Set UnitId
+ f :: (BuildInfo, BuildResult log) -> S.Set UnitId
f (binfo, result) =
failedDirectDeps <> failedTransDeps
where
diff --git a/ci/Types.hs b/ci/Types.hs
index 9f0ac679fb01eab789b69cd063af18518be1419a..6a55d699542ad40c6bb09e38700b59effc595110 100644
--- a/ci/Types.hs
+++ b/ci/Types.hs
@@ -1,13 +1,17 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Types
( RunResult(..)
+ , runResultUnits
, TestedPatch(..)
, PackageResult(..)
, BuildInfo(..)
, BuildResult(..)
+ , LogOutput(..)
) where
import Cabal.Plan
@@ -29,41 +33,53 @@ data BuildInfo
deriving anyclass (ToJSON, FromJSON)
-- | The result of a unit build.
-data BuildResult
- = BuildSucceeded { buildLog :: T.Text }
+data BuildResult log
+ = BuildSucceeded { buildLog :: log }
-- ^ the build succeeded.
| BuildPreexisted
-- ^ the unit pre-existed in the global package database.
- | BuildFailed { buildLog :: T.Text }
+ | BuildFailed { buildLog :: log }
-- ^ the build failed
| BuildNotAttempted
-- ^ the build was not attempted either because a dependency failed or it
-- is an executable or testsuite component
- deriving stock (Show, Generic)
+ deriving stock (Show, Generic, Functor, Foldable, Traversable)
deriving anyclass (ToJSON, FromJSON)
-- | The result of an attempt to tested a patch
-data PackageResult
+data PackageResult log
= PackagePlanningFailed { planningError :: T.Text }
-- ^ Our attempt to build the package resulting in no viable install plan.
| PackageResult { packageBuilt :: Bool
- , units :: M.Map UnitId (BuildInfo, BuildResult)
+ , units :: M.Map UnitId (BuildInfo, BuildResult log)
}
-- ^ We attempted to build the package.
- deriving stock (Show, Generic)
+ deriving stock (Show, Generic, Functor, Foldable, Traversable)
deriving anyclass (ToJSON, FromJSON)
-- | Information about a patch which we tested.
-data TestedPatch
+data TestedPatch log
= TestedPatch { patchedPackageName :: PkgName
, patchedPackageVersion :: Ver
- , patchedPackageResult :: PackageResult
+ , patchedPackageResult :: PackageResult log
}
- deriving stock (Show, Generic)
+ deriving stock (Show, Generic, Functor, Foldable, Traversable)
deriving anyclass (ToJSON, FromJSON)
-- | The result of a CI run.
-data RunResult
- = RunResult { testedPatches :: [TestedPatch] }
- deriving stock (Show, Generic)
+data RunResult log
+ = RunResult { testedPatches :: [TestedPatch log] }
+ deriving stock (Show, Generic, Functor, Foldable, Traversable)
deriving anyclass (ToJSON, FromJSON)
+
+runResultUnits :: RunResult log -> M.Map UnitId (BuildInfo, BuildResult log)
+runResultUnits runResult = M.unions
+ [ units
+ | tpatch <- testedPatches runResult
+ , PackageResult _ units <- pure $ patchedPackageResult tpatch
+ ]
+
+-- | Logged output from a build.
+newtype LogOutput = LogOutput { getLogOutput :: T.Text }
+ deriving stock (Eq, Ord, Show)
+ deriving newtype (ToJSON, FromJSON)