Separate log files

.gitlab-ci.yml

@@ -99,7 +99,7 @@ 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 results.json logs
 
   artifacts:
     when: always

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

ci/Types.hs

 {-# 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)