Evaluate canonical job ids

Changelog: Added `jobid` command resolving job reference to canonical id

7 files changed, 141 insertions, 14 deletions

diff --git a/minici.cabal b/minici.cabal
index 433576f..b8fa18a 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -49,6 +49,7 @@ executable minici
     other-modules:
         Command
         Command.Checkout
+        Command.JobId
         Command.Run
         Config
         Eval
diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs
new file mode 100644
index 0000000..9f531d6
--- /dev/null
+++ b/src/Command/JobId.hs
@@ -0,0 +1,39 @@
+module Command.JobId (
+    JobIdCommand,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import Command
+import Eval
+import Job.Types
+
+
+data JobIdCommand = JobIdCommand JobRef
+
+instance Command JobIdCommand where
+    commandName _ = "jobid"
+    commandDescription _ = "Resolve job reference to canonical job ID"
+
+    type CommandArguments JobIdCommand = Text
+
+    commandUsage _ = T.pack $ unlines $
+        [ "Usage: minici jobid <job ref>"
+        ]
+
+    commandInit _ _ = JobIdCommand . JobRef . T.splitOn "."
+    commandExec = cmdJobId
+
+
+cmdJobId :: JobIdCommand -> CommandExec ()
+cmdJobId (JobIdCommand ref) = do
+    config <- getConfig
+    einput <- getEvalInput
+    JobId ids <- either (tfail . textEvalError) return =<<
+        liftIO (runEval (evalJobReference config ref) einput)
+
+    liftIO $ T.putStrLn $ T.intercalate "." $ map textJobIdPart ids
diff --git a/src/Config.hs b/src/Config.hs
index 08bc3f2..5631179 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -157,14 +157,14 @@ parseConfig contents = do
             Left $ prettyPosWithSource pos contents err
         Right conf -> Right conf
 
-loadConfigForCommit :: MonadIO m => Commit -> m (Either String Config)
-loadConfigForCommit commit = do
-    readCommittedFile commit configFileName >>= return . \case
+loadConfigForCommit :: MonadIO m => Tree -> m (Either String Config)
+loadConfigForCommit tree = do
+    readCommittedFile tree configFileName >>= return . \case
         Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content
         Nothing -> Left $ configFileName <> " not found"
 
-loadJobSetForCommit :: MonadIO m => Commit -> m DeclaredJobSet
-loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit
+loadJobSetForCommit :: (MonadIO m, MonadFail m) => Commit -> m DeclaredJobSet
+loadJobSetForCommit commit = return . toJobSet =<< loadConfigForCommit =<< getCommitTree commit
   where
     toJobSet configEither = JobSet
         { jobsetCommit = Just commit
diff --git a/src/Eval.hs b/src/Eval.hs
index a071770..1828468 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -1,18 +1,23 @@
 module Eval (
     EvalInput(..),
     EvalError(..), textEvalError,
+    Eval, runEval,
 
     evalJob,
     evalJobSet,
+    evalJobReference,
 ) where
 
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.Reader
 
 import Data.Bifunctor
+import Data.List
 import Data.Text (Text)
 import Data.Text qualified as T
 
+import Config
 import Job.Types
 import Repo
 
@@ -27,6 +32,13 @@ data EvalError
 textEvalError :: EvalError -> Text
 textEvalError (OtherEvalError text) = text
 
+
+type Eval a = ReaderT EvalInput (ExceptT EvalError IO) a
+
+runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
+runEval action einput = runExceptT $ flip runReaderT einput action
+
+
 evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
 evalJob EvalInput {..} decl = do
     otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, revision, checkout ) -> do
@@ -52,3 +64,48 @@ evalJobSet ei decl = do
         }
   where
     runExceptStr = first (T.unpack . textEvalError) . runExcept
+
+
+canonicalJobName :: [ Text ] -> Config -> Eval [ JobIdPart ]
+canonicalJobName (r : rs) config = do
+    einput <- ask
+    let name = JobName r
+    case find ((name ==) . jobName) (configJobs config) of
+        Just djob -> do
+            job <- either throwError return $ runExcept $ evalJob einput djob
+            let repos = nub $ map (\( EvaluatedJobRepo repo, _, _ ) -> repo) $ jobOtherCheckout job
+            (JobIdName name :) <$> canonicalOtherCheckouts rs repos
+        Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
+canonicalJobName [] _ = throwError $ OtherEvalError "expected job name"
+
+canonicalOtherCheckouts :: [ Text ] -> [ Repo ] -> Eval [ JobIdPart ]
+canonicalOtherCheckouts (r : rs) (repo : repos) = do
+    tree <- tryReadCommit repo r >>= \case
+        Just commit -> getCommitTree commit
+        Nothing -> tryReadTree repo r >>= \case
+            Just tree -> return tree
+            Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
+    (JobIdTree (treeId tree) :) <$> canonicalOtherCheckouts rs repos
+canonicalOtherCheckouts []       []       = return []
+canonicalOtherCheckouts []       (_ : _ ) = throwError $ OtherEvalError $ "expected commit or tree reference"
+canonicalOtherCheckouts (r : _)  []       = throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r <> "’"
+
+canonicalCommitConfig :: [ Text ] -> Repo -> Eval [ JobIdPart ]
+canonicalCommitConfig (r : rs) repo = do
+    tree <- tryReadCommit repo r >>= \case
+        Just commit -> getCommitTree commit
+        Nothing -> tryReadTree repo r >>= \case
+            Just tree -> return tree
+            Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
+    config <- either fail return =<< loadConfigForCommit tree
+    (JobIdTree (treeId tree) :) <$> canonicalJobName rs config
+canonicalCommitConfig [] _ = throwError $ OtherEvalError "expected commit or tree reference"
+
+evalJobReference :: Config -> JobRef -> Eval JobId
+evalJobReference config (JobRef rs) =
+    fmap JobId $ do
+        asks eiContainingRepo >>= \case
+            Just defRepo -> do
+                canonicalCommitConfig rs defRepo
+            Nothing -> do
+                canonicalJobName rs config
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 0f91b94..0447615 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -68,3 +68,12 @@ data JobIdPart
     | JobIdCommit CommitId
     | JobIdTree TreeId
     deriving (Eq, Ord)
+
+newtype JobRef = JobRef [ Text ]
+    deriving (Eq, Ord)
+
+textJobIdPart :: JobIdPart -> Text
+textJobIdPart = \case
+    JobIdName name -> textJobName name
+    JobIdCommit cid -> textCommitId cid
+    JobIdTree tid -> textTreeId tid
diff --git a/src/Main.hs b/src/Main.hs
index f98b274..9e9214f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,7 @@ import System.IO
 
 import Command
 import Command.Checkout
+import Command.JobId
 import Command.Run
 import Config
 import Repo
@@ -73,6 +74,7 @@ commands :: NE.NonEmpty SomeCommandType
 commands =
     ( SC $ Proxy @RunCommand) NE.:|
     [ SC $ Proxy @CheckoutCommand
+    , SC $ Proxy @JobIdCommand
     ]
 
 lookupCommand :: String -> Maybe SomeCommandType
diff --git a/src/Repo.hs b/src/Repo.hs
index 702f09d..f22b211 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -9,7 +9,8 @@ module Repo (
     Tag(..),
 
     openRepo,
-    readCommit,
+    readCommit, tryReadCommit,
+    readTree, tryReadTree,
     readBranch,
     readTag,
     listCommits,
@@ -63,6 +64,9 @@ data Repo
         , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])
         }
 
+instance Show Repo where
+    show GitRepo {..} = gitDir
+
 data DeclaredRepo = DeclaredRepo
     { repoName :: RepoName
     , repoPath :: FilePath
@@ -164,10 +168,25 @@ mkCommit commitRepo commitId_ = do
     return $ Commit {..}
 
 readCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m Commit
-readCommit repo@GitRepo {..} ref = liftIO $ do
-    readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{commit}" ] "" >>= \case
-        ( ExitSuccess, out, _ ) | cid : _ <- lines out -> mkCommit repo (CommitId $ BC.pack cid)
-        _                                              -> fail $ "revision `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit repo ref
+    where err = "revision `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+
+tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit)
+tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref
+
+readTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m Tree
+readTree repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadTree repo ref
+    where err = "tree `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+
+tryReadTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Tree)
+tryReadTree repo ref = return . fmap (Tree repo . TreeId) =<< tryReadObjectId repo "tree" ref
+
+tryReadObjectId :: (MonadIO m, MonadFail m) => Repo -> Text -> Text -> m (Maybe ByteString)
+tryReadObjectId GitRepo {..} otype ref = do
+    liftIO (readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{" <> T.unpack otype <> "}" ] "") >>= \case
+        ( ExitSuccess, out, _ ) | oid : _ <- lines out -> return $ Just $ BC.pack oid
+        _                                              -> return Nothing
+
 
 readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit)
 readCommitFromFile repo@GitRepo {..} path = liftIO $ do
@@ -325,11 +344,11 @@ createWipCommit repo@GitRepo {..} = do
             _ -> readCommit repo "HEAD"
 
 
-readCommittedFile :: MonadIO m => Commit -> FilePath -> m (Maybe BL.ByteString)
-readCommittedFile Commit {..} path = do
-    let GitRepo {..} = commitRepo
+readCommittedFile :: MonadIO m => Tree -> FilePath -> m (Maybe BL.ByteString)
+readCommittedFile Tree {..} path = do
+    let GitRepo {..} = treeRepo
     liftIO $ withMVar gitLock $ \_ -> do
-        let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showCommitId commitId_ <> ":" <> path ])
+        let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showTreeId treeId <> ":" <> path ])
                 { std_in = NoStream
                 , std_out = CreatePipe
                 }