diff options
| -rw-r--r-- | src/Command.hs | 27 | ||||
| -rw-r--r-- | src/Command/Run.hs | 81 | ||||
| -rw-r--r-- | src/Config.hs | 7 | ||||
| -rw-r--r-- | src/Job.hs | 22 | ||||
| -rw-r--r-- | src/Job/Types.hs | 2 | ||||
| -rw-r--r-- | src/Repo.hs | 10 |
6 files changed, 78 insertions, 71 deletions
diff --git a/src/Command.hs b/src/Command.hs index 7ca257a..c9a77e6 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -11,7 +11,7 @@ module Command ( getCommonOptions, getConfigPath, getConfig, - getRepo, getDefaultRepo, + getRepo, getDefaultRepo, tryGetDefaultRepo, getTerminalOutput, ) where @@ -106,28 +106,31 @@ getCommonOptions :: CommandExec CommonOptions getCommonOptions = CommandExec (asks ciOptions) getConfigPath :: CommandExec FilePath -getConfigPath = CommandExec $ do - asks ciConfigPath >>= \case - Nothing -> fail $ "no job file found" +getConfigPath = do + CommandExec (asks ciConfigPath) >>= \case + Nothing -> tfail $ "no job file found" Just path -> return path getConfig :: CommandExec Config -getConfig = CommandExec $ do - asks ciConfig >>= \case +getConfig = do + CommandExec (asks ciConfig) >>= \case Left err -> fail err Right config -> return config getRepo :: RepoName -> CommandExec Repo -getRepo name = CommandExec $ do - asks (lookup (Just name) . ciRepos) >>= \case +getRepo name = do + CommandExec (asks (lookup (Just name) . ciRepos)) >>= \case Just repo -> return repo - Nothing -> fail $ "repo `" <> showRepoName name <> "' not declared" + Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared" getDefaultRepo :: CommandExec Repo -getDefaultRepo = CommandExec $ do - asks (lookup Nothing . ciRepos) >>= \case +getDefaultRepo = do + tryGetDefaultRepo >>= \case Just repo -> return repo - Nothing -> fail $ "no default repo" + Nothing -> tfail $ "no default repo" + +tryGetDefaultRepo :: CommandExec (Maybe Repo) +tryGetDefaultRepo = CommandExec $ asks (lookup Nothing . ciRepos) getTerminalOutput :: CommandExec TerminalOutput getTerminalOutput = CommandExec (asks ciTerminalOutput) diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 383276d..bd29455 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -15,7 +15,6 @@ import Data.Text qualified as T import Data.Text.IO qualified as T import System.Console.GetOpt -import System.Directory import System.FilePath import System.FilePath.Glob import System.IO @@ -129,16 +128,18 @@ argumentJobSource names = do case find ((name ==) . jobName) (configJobs config) of Just job -> return job Nothing -> tfail $ "job `" <> textJobName name <> "' not found" - jobsetCommit <- createWipCommit =<< getDefaultRepo + jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo oneshotJobSource [ JobSet {..} ] -rangeSource :: Repo -> Text -> Text -> IO JobSource -rangeSource repo base tip = do +rangeSource :: Text -> Text -> CommandExec JobSource +rangeSource base tip = do + repo <- getDefaultRepo commits <- listCommits repo (base <> ".." <> tip) oneshotJobSource =<< mapM loadJobSetForCommit commits -watchBranchSource :: Repo -> Text -> IO JobSource -watchBranchSource repo branch = do +watchBranchSource :: Text -> CommandExec JobSource +watchBranchSource branch = do + repo <- getDefaultRepo getCurrentTip <- watchBranch repo branch let go prev tmvar = do cur <- atomically $ do @@ -154,18 +155,19 @@ watchBranchSource repo branch = do atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) go cur nextvar - tmvar <- newEmptyTMVarIO - atomically getCurrentTip >>= \case - Just commit -> - void $ forkIO $ go commit tmvar - Nothing -> do - T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found" - atomically $ putTMVar tmvar Nothing - return $ JobSource tmvar - -watchTagSource :: Repo -> Pattern -> IO JobSource -watchTagSource repo pat = do - chan <- watchTags repo + liftIO $ do + tmvar <- newEmptyTMVarIO + atomically getCurrentTip >>= \case + Just commit -> + void $ forkIO $ go commit tmvar + Nothing -> do + T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found" + atomically $ putTMVar tmvar Nothing + return $ JobSource tmvar + +watchTagSource :: Pattern -> CommandExec JobSource +watchTagSource pat = do + chan <- watchTags =<< getDefaultRepo let go tmvar = do tag <- atomically $ readTChan chan @@ -178,9 +180,10 @@ watchTagSource repo pat = do else do go tmvar - tmvar <- newEmptyTMVarIO - void $ forkIO $ go tmvar - return $ JobSource tmvar + liftIO $ do + tmvar <- newEmptyTMVarIO + void $ forkIO $ go tmvar + return $ JobSource tmvar cmdRun :: RunCommand -> CommandExec () cmdRun (RunCommand RunOptions {..} args) = do @@ -189,12 +192,6 @@ cmdRun (RunCommand RunOptions {..} args) = do configPath <- getConfigPath let baseDir = takeDirectory configPath - repo <- liftIO (openRepo baseDir) >>= \case - Just repo -> return repo - Nothing -> do - absPath <- liftIO $ makeAbsolute baseDir - fail $ "no repository found at `" <> absPath <> "'" - ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence [ forM roRanges $ \range -> case T.splitOn ".." range of [ base, tip ] -> return $ Left ( Just base, tip ) @@ -214,22 +211,22 @@ cmdRun (RunCommand RunOptions {..} args) = do argumentJobs <- argumentJobSource jobOptions - liftIO $ do - let rangeOptions' - | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ] - | otherwise = rangeOptions + let rangeOptions' + | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ] + | otherwise = rangeOptions - ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do - ( base, tip ) <- case mbBase of - Just base -> return ( base, paramTip ) - Nothing -> liftIO $ do - Just base <- findUpstreamRef repo paramTip - return ( base, paramTip ) - rangeSource repo base tip + ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do + ( base, tip ) <- case mbBase of + Just base -> return ( base, paramTip ) + Nothing -> do + Just base <- flip findUpstreamRef paramTip =<< getDefaultRepo + return ( base, paramTip ) + rangeSource base tip - branches <- mapM (watchBranchSource repo) roNewCommitsOn - tags <- mapM (watchTagSource repo) roNewTags + branches <- mapM watchBranchSource roNewCommitsOn + tags <- mapM watchTagSource roNewTags + liftIO $ do mngr <- newJobManager (baseDir </> ".minici") optJobs source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ] @@ -253,8 +250,8 @@ cmdRun (RunCommand RunOptions {..} args) = do map ((" " <>) . fitToLength 7 . textJobName) names let commit = jobsetCommit jobset - shortCid = T.pack $ take 7 $ showCommitId $ commitId commit - shortDesc <- fitToLength 50 <$> getCommitTitle commit + shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit + shortDesc <- fitToLength 50 <$> maybe (return "") getCommitTitle commit case jobsetJobsEither jobset of Right jobs -> do diff --git a/src/Config.hs b/src/Config.hs index da8a089..e9287e4 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -9,6 +9,7 @@ module Config ( import Control.Monad import Control.Monad.Combinators +import Control.Monad.IO.Class import Data.ByteString.Lazy qualified as BS import Data.List @@ -149,16 +150,16 @@ parseConfig contents = do Left $ prettyPosWithSource pos contents err Right conf -> Right conf -loadConfigForCommit :: Commit -> IO (Either String Config) +loadConfigForCommit :: MonadIO m => Commit -> m (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 :: MonadIO m => Commit -> m JobSet loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit where toJobSet configEither = JobSet - { jobsetCommit = commit + { jobsetCommit = Just commit , jobsetJobsEither = fmap configJobs configEither } @@ -21,6 +21,7 @@ import Control.Monad.IO.Class import Data.List import Data.Map (Map) import Data.Map qualified as M +import Data.Maybe import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text) @@ -178,12 +179,12 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks -runJobs :: JobManager -> Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] +runJobs :: JobManager -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] runJobs mngr@JobManager {..} commit jobs = do - tree <- getCommitTree commit + tree <- sequence $ fmap getCommitTree commit results <- atomically $ do forM jobs $ \job -> do - let jid = JobId [ JobIdTree (treeId tree), JobIdName (jobName job) ] + let jid = JobId $ concat [ JobIdTree . treeId <$> maybeToList tree, [ JobIdName (jobName job) ] ] tid <- reserveTaskId mngr managed <- readTVar jmJobs ( job, tid, ) <$> case M.lookup jid managed of @@ -279,13 +280,18 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing T.writeFile path $ textJobStatus status <> "\n" when (not (jobStatusFinished status)) $ loop $ Just status -prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Commit -> Job -> (FilePath -> FilePath -> m a) -> m a -prepareJob dir commit job inner = do +prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a +prepareJob dir mbCommit job inner = do withSystemTempDirectory "minici" $ \checkoutPath -> do - tree <- getCommitTree commit - checkoutAt tree checkoutPath + jdirCommit <- case mbCommit of + Just commit -> do + tree <- getCommitTree commit + checkoutAt tree checkoutPath + return $ showTreeId (treeId tree) </> stringJobName (jobName job) + Nothing -> do + return $ stringJobName (jobName job) - let jdir = dir </> "jobs" </> showTreeId (treeId tree) </> stringJobName (jobName job) + let jdir = dir </> "jobs" </> jdirCommit liftIO $ createDirectoryIfMissing True jdir inner checkoutPath jdir diff --git a/src/Job/Types.hs b/src/Job/Types.hs index bfc4b2e..3f6f1f0 100644 --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -31,7 +31,7 @@ data ArtifactName = ArtifactName Text data JobSet = JobSet - { jobsetCommit :: Commit + { jobsetCommit :: Maybe Commit , jobsetJobsEither :: Either String [ Job ] } diff --git a/src/Repo.hs b/src/Repo.hs index 0a6c563..2568fff 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -325,7 +325,7 @@ createWipCommit repo@GitRepo {..} = do _ -> readCommit repo "HEAD" -readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString) +readCommittedFile :: MonadIO m => Commit -> FilePath -> m (Maybe BL.ByteString) readCommittedFile Commit {..} path = do let GitRepo {..} = commitRepo liftIO $ withMVar gitLock $ \_ -> do @@ -377,14 +377,14 @@ repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case headsDir = gitDir </> "refs/heads" tagsDir = gitDir </> "refs/tags" -watchBranch :: Repo -> Text -> IO (STM (Maybe Commit)) -watchBranch repo@GitRepo {..} branch = do +watchBranch :: MonadIO m => Repo -> Text -> m (STM (Maybe Commit)) +watchBranch repo@GitRepo {..} branch = liftIO $ do var <- newTVarIO =<< readBranch repo branch void $ repoInotify repo modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ] return $ readTVar var -watchTags :: Repo -> IO (TChan (Tag Commit)) -watchTags repo = do +watchTags :: MonadIO m => Repo -> m (TChan (Tag Commit)) +watchTags repo = liftIO $ do tagsChan <- snd <$> repoInotify repo atomically $ dupTChan tagsChan |