Run jobs based on configuration in associated commit

Changelog: Run jobs based on configuration in associated commit

6 files changed, 133 insertions, 50 deletions

diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 729a699..73baee0 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -7,6 +7,7 @@ import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Reader
 
+import Data.List
 import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
@@ -43,7 +44,6 @@ instance Command RunCommand where
 
 cmdRun :: RunCommand -> CommandExec ()
 cmdRun (RunCommand changeset) = do
-    config <- getConfig
     ( base, tip ) <- case T.splitOn (T.pack "..") changeset of
         base : tip : _ -> return ( T.unpack base, T.unpack tip )
         [ param ] -> liftIO $ do
@@ -58,16 +58,26 @@ cmdRun (RunCommand changeset) = do
     liftIO $ do
         Just repo <- openRepo "."
         commits <- listCommits repo (base <> ".." <> tip)
+        jobssets <- mapM loadJobSetForCommit commits
+        let names = nub $ map jobName $ concatMap jobsetJobs jobssets
 
         putStr $ replicate (8 + 50) ' '
-        forM_ (configJobs config) $ \job -> do
-            T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
+        forM_ names $ \name -> do
+            T.putStr $ (" "<>) $ fitToLength 7 $ textJobName name
         putStrLn ""
 
-        forM_ commits $ \commit -> do
-            let shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
-            outs <- runJobs "./.minici" commit $ configJobs config
-            displayStatusLine shortCid (" " <> fitToLength 50 (commitDescription commit)) outs
+        forM_ jobssets $ \jobset -> do
+            let commit = jobsetCommit jobset
+                shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
+                shortDesc = fitToLength 50 (commitDescription commit)
+            case jobsetJobsEither jobset of
+                Right jobs -> do
+                    outs <- runJobs "./.minici" commit jobs
+                    let findJob name = snd <$> find ((name ==) . jobName . fst) outs
+                    displayStatusLine shortCid (" " <> shortDesc) $ map findJob names
+                Left err -> do
+                    T.putStrLn $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
+                    hFlush stdout
 
 
 fitToLength :: Int -> Text -> Text
@@ -85,28 +95,29 @@ showStatus blink = \case
     JobFailed       -> "\ESC[91m✗\ESC[0m      "
     JobDone _       -> "\ESC[92m✓\ESC[0m      "
 
-displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
+displayStatusLine :: Text -> Text -> [ Maybe (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 ""
+    go blinkVar "\0"
     killThread t
   where
     go blinkVar prev = do
         (ss, cur) <- atomically $ do
-            ss <- mapM readTVar statuses
+            ss <- mapM (sequence . fmap readTVar) statuses
             blink <- readTVar blinkVar
-            let cur = T.concat $ map ((" " <>) . showStatus blink) ss
+            let cur = T.concat $ map (maybe "        " ((" " <>) . 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
+        let prefix1' = if any (maybe False jobStatusFailed) ss
+                         then "\ESC[91m" <> prefix1 <> "\ESC[0m"
+                         else prefix1
         T.putStr $ prefix1' <> prefix2 <> cur
         hFlush stdout
 
-        if all jobStatusFinished ss
+        if all (maybe True jobStatusFinished) ss
            then T.putStrLn ""
            else go blinkVar cur
diff --git a/src/Config.hs b/src/Config.hs
index d5f80fc..a24ee56 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,6 +2,9 @@ module Config (
     Config(..),
     findConfig,
     parseConfig,
+
+    loadConfigForCommit,
+    loadJobSetForCommit,
 ) where
 
 import Control.Monad
@@ -17,11 +20,16 @@ import Data.Text qualified as T
 import Data.YAML
 
 import System.Directory
-import System.Exit
 import System.FilePath
 import System.Process
 
-import Job
+import Job.Types
+import Repo
+
+
+configFileName :: FilePath
+configFileName = "minici.yaml"
+
 
 data Config = Config
     { configJobs :: [Job]
@@ -92,10 +100,9 @@ parseUses = withSeq "Uses list" $ mapM $
 findConfig :: IO (Maybe FilePath)
 findConfig = go "."
   where
-    name = "minici.yaml"
     go path = do
-        doesFileExist (path </> name) >>= \case
-            True -> return $ Just $ path </> name
+        doesFileExist (path </> configFileName) >>= \case
+            True -> return $ Just $ path </> configFileName
             False -> doesDirectoryExist (path </> "..") >>= \case
                 True -> do
                     parent <- canonicalizePath $ path </> ".."
@@ -103,11 +110,23 @@ findConfig = go "."
                                       else return Nothing
                 False -> return Nothing
 
-parseConfig :: FilePath -> IO Config
-parseConfig path = do
-    contents <- BS.readFile path
+parseConfig :: BS.ByteString -> Either String Config
+parseConfig contents = do
     case decode1 contents of
         Left (pos, err) -> do
-            putStr $ prettyPosWithSource pos contents err
-            exitFailure
-        Right conf -> return conf
+            Left $ prettyPosWithSource pos contents err
+        Right conf -> Right conf
+
+loadConfigForCommit :: Commit -> IO (Either String Config)
+loadConfigForCommit commit = do
+    readCommittedFile commit configFileName >>= return . \case
+        Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content
+        Nothing -> Left $ configFileName <> " not found"
+
+loadJobSetForCommit :: Commit -> IO JobSet
+loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit
+  where
+    toJobSet configEither = JobSet
+        { jobsetCommit = commit
+        , jobsetJobsEither = fmap configJobs configEither
+        }
diff --git a/src/Job.hs b/src/Job.hs
index ccb8611..068a076 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -1,5 +1,6 @@
 module Job (
     Job(..),
+    JobSet(..), jobsetJobs,
     JobOutput(..),
     JobName(..), stringJobName, textJobName,
     ArtifactName(..),
@@ -27,34 +28,16 @@ import System.FilePath
 import System.IO
 import System.Process
 
+import Job.Types
 import Repo
 
 
-data Job = Job
-    { jobName :: JobName
-    , jobRecipe :: [CreateProcess]
-    , jobArtifacts :: [(ArtifactName, CreateProcess)]
-    , jobUses :: [(JobName, ArtifactName)]
-    }
-
 data JobOutput = JobOutput
     { outName :: JobName
     , outArtifacts :: [ArtifactOutput]
     }
     deriving (Eq)
 
-data JobName = JobName Text
-    deriving (Eq, Ord, Show)
-
-stringJobName :: JobName -> String
-stringJobName (JobName name) = T.unpack name
-
-textJobName :: JobName -> Text
-textJobName (JobName name) = name
-
-data ArtifactName = ArtifactName Text
-    deriving (Eq, Ord, Show)
-
 data ArtifactOutput = ArtifactOutput
     { aoutName :: ArtifactName
     , aoutWorkPath :: FilePath
@@ -96,7 +79,7 @@ textJobStatus = \case
     JobDone _ -> "done"
 
 
-runJobs :: FilePath -> Commit -> [Job] -> IO [TVar (JobStatus JobOutput)]
+runJobs :: FilePath -> Commit -> [Job] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
 runJobs dir commit jobs = do
     results <- forM jobs $ \job -> (job,) <$> newTVarIO JobQueued
     forM_ results $ \(job, outVar) -> void $ forkIO $ do
@@ -112,7 +95,7 @@ runJobs dir commit jobs = do
             _ -> return ()
 
         atomically $ writeTVar outVar $ either id JobDone res
-    return $ map snd results
+    return results
 
 waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
     Job -> [(Job, TVar (JobStatus JobOutput))] -> TVar (JobStatus JobOutput) -> m [ArtifactOutput]
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
new file mode 100644
index 0000000..6918738
--- /dev/null
+++ b/src/Job/Types.hs
@@ -0,0 +1,38 @@
+module Job.Types where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Process
+
+import Repo
+
+
+data Job = Job
+    { jobName :: JobName
+    , jobRecipe :: [ CreateProcess ]
+    , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]
+    , jobUses :: [ ( JobName, ArtifactName ) ]
+    }
+
+data JobName = JobName Text
+    deriving (Eq, Ord, Show)
+
+stringJobName :: JobName -> String
+stringJobName (JobName name) = T.unpack name
+
+textJobName :: JobName -> Text
+textJobName (JobName name) = name
+
+
+data ArtifactName = ArtifactName Text
+    deriving (Eq, Ord, Show)
+
+
+data JobSet = JobSet
+    { jobsetCommit :: Commit
+    , jobsetJobsEither :: Either String [ Job ]
+    }
+
+jobsetJobs :: JobSet -> [ Job ]
+jobsetJobs = either (const []) id . jobsetJobsEither
diff --git a/src/Main.hs b/src/Main.hs
index cdce0f9..971bffe 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,6 +4,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
+import Data.ByteString.Lazy qualified as BL
 import Data.List
 import Data.Proxy
 import Data.Text qualified as T
@@ -132,7 +133,11 @@ runSomeCommand (SC tproxy) args = do
         exitSuccess
 
     Just configPath <- findConfig
-    config <- parseConfig configPath
-    let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
-    let CommandExec exec = commandExec cmd
-    flip runReaderT config exec
+    BL.readFile configPath >>= return . parseConfig >>= \case
+        Left err -> do
+            putStr err
+            exitFailure
+        Right config -> do
+            let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
+            let CommandExec exec = commandExec cmd
+            flip runReaderT config exec
diff --git a/src/Repo.hs b/src/Repo.hs
index 9e05ccd..c0500f3 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -7,6 +7,7 @@ module Repo (
     listCommits,
     checkoutAt,
     readTreeId,
+    readCommittedFile,
 ) where
 
 import Control.Concurrent
@@ -15,6 +16,7 @@ import Control.Monad.IO.Class
 
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
 import Data.Text (Text)
 import Data.Text qualified as T
 
@@ -93,3 +95,28 @@ readTreeId Commit {..} = do
     liftIO $ withMVar gitLock $ \_ -> do
         [ "tree", tid ] : _ <- map words . lines <$> readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId ] ""
         return $ TreeId $ BC.pack tid
+
+
+readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString)
+readCommittedFile Commit {..} path = do
+    let GitRepo {..} = commitRepo
+    liftIO $ withMVar gitLock $ \_ -> do
+        let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showCommitId commitId <> ":" <> path ])
+                { std_in = NoStream
+                , std_out = CreatePipe
+                }
+        createProcess cmd >>= \( _, mbstdout, _, ph ) -> if
+            | Just stdout <- mbstdout -> do
+                content <- BL.hGetContents stdout
+
+                -- check if there will be some output:
+                case BL.uncons content of
+                    Just (c, _) -> c `seq` return ()
+                    Nothing -> return ()
+
+                getProcessExitCode ph >>= \case
+                    Just code | code /= ExitSuccess ->
+                        return Nothing
+                    _ ->
+                        return (Just content)
+            | otherwise -> error "createProcess must return stdout handle"