diff options
| -rw-r--r-- | minici.cabal | 1 | ||||
| -rw-r--r-- | src/Command/Run.hs | 39 | ||||
| -rw-r--r-- | src/Config.hs | 41 | ||||
| -rw-r--r-- | src/Job.hs | 25 | ||||
| -rw-r--r-- | src/Job/Types.hs | 38 | ||||
| -rw-r--r-- | src/Main.hs | 13 | ||||
| -rw-r--r-- | src/Repo.hs | 27 |
7 files changed, 134 insertions, 50 deletions
diff --git a/minici.cabal b/minici.cabal index c91800d..7f20ac1 100644 --- a/minici.cabal +++ b/minici.cabal @@ -51,6 +51,7 @@ executable minici Command.Run Config Job + Job.Types Paths_minici Repo Version 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 + } @@ -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" |