packages feed

minici 0.1.5 → 0.1.6

raw patch · 9 files changed

+149/−17 lines, 9 files

Files

CHANGELOG.md view
@@ -1,5 +1,10 @@ # Revision history for MiniCI +## 0.1.6 -- 2025-03-30++* Added `jobid` command resolving job reference to canonical ID+* Fix copying of used artifacts to appropriate working directory+ ## 0.1.5 -- 2025-03-20  * Accept job file path on command line
minici.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               minici-version:            0.1.5+version:            0.1.6 synopsis:           Minimalist CI framework to run checks on local machine description:     Runs defined jobs, for example to build and test a project, for each git@@ -49,6 +49,7 @@     other-modules:         Command         Command.Checkout+        Command.JobId         Command.Run         Config         Eval
+ src/Command/JobId.hs view
@@ -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
src/Config.hs view
@@ -157,14 +157,14 @@             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
src/Eval.hs view
@@ -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 @@ 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 @@         }   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
src/Job.hs view
@@ -343,10 +343,10 @@             let target = adir </> T.unpack tname </> takeFileName path             liftIO $ do                 createDirectoryIfMissing True $ takeDirectory target-                copyFile (checkoutPath </> path) target+                copyFile path target             return $ ArtifactOutput                 { aoutName = name-                , aoutWorkPath = path+                , aoutWorkPath = makeRelative checkoutPath path                 , aoutStorePath = target                 }
src/Job/Types.hs view
@@ -68,3 +68,12 @@     | 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
src/Main.hs view
@@ -19,6 +19,7 @@  import Command import Command.Checkout+import Command.JobId import Command.Run import Config import Repo@@ -73,6 +74,7 @@ commands =     ( SC $ Proxy @RunCommand) NE.:|     [ SC $ Proxy @CheckoutCommand+    , SC $ Proxy @JobIdCommand     ]  lookupCommand :: String -> Maybe SomeCommandType
src/Repo.hs view
@@ -9,7 +9,8 @@     Tag(..),      openRepo,-    readCommit,+    readCommit, tryReadCommit,+    readTree, tryReadTree,     readBranch,     readTag,     listCommits,@@ -63,6 +64,9 @@         , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])         } +instance Show Repo where+    show GitRepo {..} = gitDir+ data DeclaredRepo = DeclaredRepo     { repoName :: RepoName     , repoPath :: FilePath@@ -164,11 +168,26 @@     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     try @IO @IOException (BC.readFile $ gitDir </> path) >>= \case@@ -325,11 +344,11 @@             _ -> 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                 }