Run jobs even without default repo

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
         }
diff --git a/src/Job.hs b/src/Job.hs
index 261d038..bd9db0e 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -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