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)