diff options
| -rw-r--r-- | minici.cabal | 1 | ||||
| -rw-r--r-- | src/Job.hs | 157 | ||||
| -rw-r--r-- | src/Main.hs | 70 |
3 files changed, 168 insertions, 60 deletions
diff --git a/minici.cabal b/minici.cabal index be83193..9b96a08 100644 --- a/minici.cabal +++ b/minici.cabal @@ -46,6 +46,7 @@ executable minici , bytestring >=0.10 && <0.11 , containers >=0.6 && <0.7 , directory >=1.3 && <1.4 + , exceptions >=0.10 && <0.11 , filepath >=1.4 && <1.5 , HsYAML >=0.2 && <0.3 , mtl >=2.2 && <2.3 @@ -1,8 +1,10 @@ module Job ( Job(..), JobOutput(..), - JobName(..), stringJobName, + JobName(..), stringJobName, textJobName, ArtifactName(..), + JobStatus(..), + jobStatusFinished, jobStatusFailed, runJobs, ) where @@ -10,11 +12,13 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Control.Monad.Catch import Control.Monad.Except import Data.List import Data.Text (Text) import Data.Text qualified as T +import Data.Text.IO qualified as T import System.Directory import System.Exit @@ -31,9 +35,9 @@ data Job = Job data JobOutput = JobOutput { outName :: JobName - , outStatus :: Bool , outArtifacts :: [ArtifactOutput] } + deriving (Eq) data JobName = JobName Text deriving (Eq, Ord, Show) @@ -41,6 +45,9 @@ data JobName = JobName Text stringJobName :: JobName -> String stringJobName (JobName name) = T.unpack name +textJobName :: JobName -> Text +textJobName (JobName name) = name + data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) @@ -49,41 +56,123 @@ data ArtifactOutput = ArtifactOutput , aoutWorkPath :: FilePath , aoutStorePath :: FilePath } - - -runJobs :: FilePath -> String -> [Job] -> IO [TVar (Maybe JobOutput)] + deriving (Eq) + + +data JobStatus a = JobQueued + | JobWaiting [JobName] + | JobRunning + | JobSkipped + | JobError Text + | JobFailed + | JobDone a + deriving (Eq) + +jobStatusFinished :: JobStatus a -> Bool +jobStatusFinished = \case + JobQueued {} -> False + JobWaiting {} -> False + JobRunning {} -> False + _ -> True + +jobStatusFailed :: JobStatus a -> Bool +jobStatusFailed = \case + JobError {} -> True + JobFailed {} -> True + _ -> False + +textJobStatus :: JobStatus a -> Text +textJobStatus = \case + JobQueued -> "queued" + JobWaiting _ -> "waiting" + JobRunning -> "running" + JobSkipped -> "skipped" + JobError err -> "error\n" <> err + JobFailed -> "failed" + JobDone _ -> "done" + + +runJobs :: FilePath -> String -> [Job] -> IO [TVar (JobStatus JobOutput)] runJobs dir cid jobs = do - results <- forM jobs $ \job -> (job,) <$> newTVarIO Nothing + results <- forM jobs $ \job -> (job,) <$> newTVarIO JobQueued gitLock <- newMVar () forM_ results $ \(job, outVar) -> void $ forkIO $ do - uses <- forM (jobUses job) $ \(ujobName, uartName) -> do - Just (_, uoutVar) <- return $ find ((==ujobName) . jobName . fst) results - uout <- atomically $ maybe retry return =<< readTVar uoutVar - Just uart <- return $ find ((==uartName) . aoutName) $ outArtifacts uout - return uart - out <- runJob gitLock dir cid job uses - atomically $ writeTVar outVar $ Just out + res <- runExceptT $ do + uses <- waitForUsedArtifacts job results outVar + liftIO $ atomically $ writeTVar outVar JobRunning + prepareJob gitLock dir cid job $ \checkoutPath jdir -> do + updateStatusFile (jdir </> "status") outVar + runJob job uses checkoutPath jdir + + case res of + Left (JobError err) -> T.putStrLn err + _ -> return () + + atomically $ writeTVar outVar $ either id JobDone res return $ map snd results -runJob :: MVar () -> FilePath -> String -> Job -> [ArtifactOutput] -> IO JobOutput -runJob gitLock dir cid job uses = do - [checkoutPath] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" - - tid <- withMVar gitLock $ \_ -> do - "" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] "" - ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] "" - return tid - - let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job) - createDirectoryIfMissing True jdir - logs <- openFile (jdir </> "log") WriteMode - - forM_ uses $ \aout -> do +waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) => + Job -> [(Job, TVar (JobStatus JobOutput))] -> TVar (JobStatus JobOutput) -> m [ArtifactOutput] +waitForUsedArtifacts job results outVar = do + ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do + case find ((==ujobName) . jobName . fst) results of + Just (_, var) -> return (var, (ujobName, uartName)) + Nothing -> throwError $ JobError $ "Job '" <> tjobName <> "' not found" + + let loop prev = do + ustatuses <- atomically $ do + ustatuses <- forM ujobs $ \(uoutVar, uartName) -> do + (,uartName) <$> readTVar uoutVar + when (Just (map fst ustatuses) == prev) retry + writeTVar outVar $ JobWaiting $ map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses + return ustatuses + if all (jobStatusFinished . fst) ustatuses + then return ustatuses + else loop $ Just $ map fst ustatuses + ustatuses <- liftIO $ loop Nothing + + forM ustatuses $ \(ustatus, (JobName tjobName, uartName@(ArtifactName tartName))) -> do + case ustatus of + JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of + Just art -> return art + Nothing -> throwError $ JobError $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found" + _ -> throwError JobSkipped + +updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m () +updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing + where + loop prev = do + status <- atomically $ do + status <- readTVar outVar + when (Just status == prev) retry + return status + T.writeFile path $ textJobStatus status <> "\n" + when (not (jobStatusFinished status)) $ loop $ Just status + +prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => MVar () -> FilePath -> String -> Job -> (FilePath -> FilePath -> m a) -> m a +prepareJob gitLock dir cid job inner = do + [checkoutPath] <- fmap lines $ liftIO $ + readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] "" + + flip finally (liftIO $ removeDirectoryRecursive checkoutPath) $ do + tid <- liftIO $ withMVar gitLock $ \_ -> do + "" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] "" + ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] "" + return tid + + let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job) + liftIO $ createDirectoryIfMissing True jdir + + inner checkoutPath jdir + +runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput +runJob job uses checkoutPath jdir = do + liftIO $ forM_ uses $ \aout -> do let target = checkoutPath </> aoutWorkPath aout createDirectoryIfMissing True $ takeDirectory target copyFile (aoutStorePath aout) target - res <- runExceptT $ do + bracket (liftIO $ openFile (jdir </> "log") WriteMode) (liftIO . hClose) $ \logs -> do forM_ (jobRecipe job) $ \p -> do (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p { cwd = Just checkoutPath @@ -95,15 +184,10 @@ runJob gitLock dir cid job uses = do exit <- liftIO $ waitForProcess hp when (exit /= ExitSuccess) $ - throwError () - - hClose logs - - writeFile (jdir </> "status") $ - if res == Right () then "success\n" else "failure\n" + throwError JobFailed let adir = jdir </> "artifacts" - artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> do + artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> liftIO $ do [path] <- lines <$> readCreateProcess pathCmd { cwd = Just checkoutPath } "" let target = adir </> T.unpack tname createDirectoryIfMissing True adir @@ -114,10 +198,7 @@ runJob gitLock dir cid job uses = do , aoutStorePath = target } - removeDirectoryRecursive checkoutPath - return JobOutput { outName = jobName job - , outStatus = res == Right () , outArtifacts = artifacts } diff --git a/src/Main.hs b/src/Main.hs index 8ba28d1..4e99c5f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,19 +1,60 @@ module Main (main) where +import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + import System.IO import System.Process import Config import Job -fitToLength :: Int -> String -> String -fitToLength maxlen str | len <= maxlen = str <> replicate (maxlen - len) ' ' - | otherwise = take (maxlen - 1) str <> "…" - where len = length str +fitToLength :: Int -> Text -> Text +fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " " + | otherwise = T.take (maxlen - 1) str <> "…" + where len = T.length str + +showStatus :: Bool -> JobStatus a -> Text +showStatus blink = \case + JobQueued -> "\ESC[94m…\ESC[0m " + JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m" + JobSkipped -> "\ESC[0m-\ESC[0m " + JobRunning -> "\ESC[96m" <> (if blink then "*" else "⋅") <> "\ESC[0m " + JobError _ -> "\ESC[91m!!\ESC[0m " + JobFailed -> "\ESC[91m✗\ESC[0m " + JobDone _ -> "\ESC[92m✓\ESC[0m " + +displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO () +displayStatusLine prefix1 prefix2 statuses = do + blinkVar <- newTVarIO False + t <- forkIO $ forever $ do + threadDelay 500000 + atomically $ writeTVar blinkVar . not =<< readTVar blinkVar + go blinkVar "" + killThread t + where + go blinkVar prev = do + (ss, cur) <- atomically $ do + ss <- mapM readTVar statuses + blink <- readTVar blinkVar + let cur = T.concat $ map ((" " <>) . showStatus blink) ss + when (cur == prev) retry + return (ss, cur) + when (not $ T.null prev) $ putStr "\r" + let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m" + else prefix1 + T.putStr $ prefix1' <> prefix2 <> cur + hFlush stdout + + if all jobStatusFinished ss + then T.putStrLn "" + else go blinkVar cur main :: IO () main = do @@ -25,25 +66,10 @@ main = do putStr $ replicate (8 + 50) ' ' forM_ (configJobs config) $ \job -> do - putStr $ (' ':) $ fitToLength 7 $ stringJobName $ jobName job + T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job putStrLn "" forM_ commits $ \(cid, desc) -> do - let shortCid = take 7 cid - putStr $ shortCid <> " " <> fitToLength 50 desc - hFlush stdout + let shortCid = T.pack $ take 7 cid outs <- runJobs "./.minici" cid $ configJobs config - results <- forM outs $ \outVar -> do - putStr " " - hFlush stdout - out <- atomically $ maybe retry return =<< readTVar outVar - 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 "" + displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs |