diff options
Diffstat (limited to 'src/Main.hs')
-rw-r--r-- | src/Main.hs | 115 |
1 files changed, 30 insertions, 85 deletions
diff --git a/src/Main.hs b/src/Main.hs index e2d458f..da3c0d8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,101 +1,46 @@ module Main (main) where import Control.Monad -import Control.Monad.Except -import Data.Text (Text) -import Data.Text qualified as T - -import System.Directory -import System.Exit -import System.FilePath import System.IO import System.Process -data Job = Job - { jobName :: JobName - , jobRecipe :: [CreateProcess] - , jobArtifacts :: [(ArtifactName, CreateProcess)] - } - -data JobOutput = JobOutput - { outName :: JobName - , outStatus :: Bool - , outArtifacts :: [(ArtifactName, FilePath)] - } - deriving (Show) - -data JobName = JobName Text - deriving (Eq, Ord, Show) - -data ArtifactName = ArtifactName Text - deriving (Eq, Ord, Show) - -stringJobName :: JobName -> String -stringJobName (JobName name) = T.unpack name - - -runJob :: FilePath -> String -> Job -> IO JobOutput -runJob dir cid job = do - [path] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" - - "" <- readProcess "git" ["--work-tree=" <> path, "restore", "--source=" <> cid, "--", "."] "" - ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] "" - - let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job) - createDirectoryIfMissing True jdir - logs <- openFile (jdir </> "log") WriteMode - - res <- runExceptT $ do - forM_ (jobRecipe job) $ \p -> do - (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p - { cwd = Just path - , std_in = CreatePipe - , std_out = UseHandle logs - , std_err = UseHandle logs - } - liftIO $ hClose hin - exit <- liftIO $ waitForProcess hp +import Config +import Job - when (exit /= ExitSuccess) $ - throwError () - - hClose logs - removeDirectoryRecursive $ path - - writeFile (jdir </> "status") $ - if res == Right () then "success\n" else "failure\n" - - return JobOutput - { outName = jobName job - , outStatus = res == Right () - , outArtifacts = [] - } - - -cabalJob :: JobName -> [ArtifactName] -> Job -cabalJob name artifacts = Job - { jobName = name - , jobRecipe = [ proc "cabal" ["build", "--ghc-option=-Werror"] ] - , jobArtifacts = map (\(ArtifactName aname) -> (ArtifactName "bin", proc "cabal" ["list-bin", T.unpack aname])) artifacts - } +fitToLength :: Int -> String -> String +fitToLength maxlen str | len <= maxlen = str <> replicate (maxlen - len) ' ' + | otherwise = take (maxlen - 1) str <> "…" + where len = length str main :: IO () main = do + Just configPath <- findConfig + config <- parseConfig configPath + commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$> readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] "" - forM_ commits $ \(cid, desc) -> do - let descLen = length desc - desc' = if descLen <= 50 then desc <> replicate (50 - descLen) ' ' - else take 49 desc <> "…" - shortCid = take 7 cid - putStr $ shortCid <> " " <> desc' <> " " + putStr $ replicate (8 + 50) ' ' + forM_ (configJobs config) $ \job -> do + putStr $ (' ':) $ fitToLength 7 $ stringJobName $ jobName job + putStrLn "" + + forM_ commits $ \(cid, desc) -> do + let shortCid = take 7 cid + putStr $ shortCid <> " " <> fitToLength 50 desc hFlush stdout - runJob "./.minici" cid (cabalJob (JobName "build") $ map (ArtifactName . T.pack) []) >>= \case - out | outStatus out -> do - putStr "\ESC[92m✓\ESC[0m" - _ -> do - putStr "\ESC[91m✗\ESC[0m" - putStr $ "\r\ESC[91m" <> shortCid <> "\ESC[0m" + results <- forM (configJobs config) $ \job -> do + putStr " " + hFlush stdout + out <- runJob "./.minici" cid job + if | outStatus out -> do + putStr "\ESC[92m✓\ESC[0m " + | otherwise -> do + putStr "\ESC[91m✗\ESC[0m " + hFlush stdout + return $ outStatus out + + when (not $ and results) $ do + putStr $ "\r\ESC[91m" <> shortCid <> "\ESC[0m" putStrLn "" |