Commit 47654ece authored by Ben Gamari's avatar Ben Gamari 🐢

Separate log files

parent 835dfc67
......@@ -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
......
......@@ -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
......
{-# 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)
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