minici 0.1.4 → 0.1.5
raw patch · 13 files changed
+689/−205 lines, 13 filesdep ~unix
Dependency ranges changed: unix
Files
- CHANGELOG.md +7/−0
- README.md +6/−4
- minici.cabal +4/−2
- src/Command.hs +55/−11
- src/Command/Checkout.hs +58/−0
- src/Command/Run.hs +90/−75
- src/Config.hs +58/−18
- src/Eval.hs +54/−0
- src/Job.hs +65/−39
- src/Job/Types.hs +27/−5
- src/Main.hs +91/−21
- src/Repo.hs +151/−30
- src/Terminal.hs +23/−0
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Revision history for MiniCI +## 0.1.5 -- 2025-03-20++* Accept job file path on command line+* Added `checkout` command+* Reference and checkout other repositories from job file+* Accept names of jobs to run as command-line arguments+ ## 0.1.4 -- 2025-02-04 * Fix invocation of `minici run` without arguments
README.md view
@@ -59,16 +59,18 @@ To run jobs for commits that are in local `<branch>`, but not yet in its upstream: ```-minici run <branch>-```-or:-``` minici run --since-upstream=<branch> ``` For current branch, the name can be omitted: ``` minici run+```++To run selected jobs with the current working tree, including uncommitted+changes, list the job names on command line:+```+minici run <job name> [<job name> ...] ``` To watch changes on given `<branch>` and run jobs for each new commit:
minici.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: minici-version: 0.1.4+version: 0.1.5 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@@ -48,8 +48,10 @@ other-modules: Command+ Command.Checkout Command.Run Config+ Eval Job Job.Types Paths_minici@@ -100,7 +102,7 @@ temporary ^>= { 1.3 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat ^>= { 0.1 },- unix ^>= { 2.7.3, 2.8.6 },+ unix ^>= { 2.7.2, 2.8.4 }, hs-source-dirs: src default-language: Haskell2010
src/Command.hs view
@@ -6,34 +6,45 @@ CommandArgumentsType(..), CommandExec(..),+ tfail, CommandInput(..), getCommonOptions, getConfigPath, getConfig,+ getRepo, getDefaultRepo, tryGetDefaultRepo,+ getEvalInput, getTerminalOutput,+ getStorageDir, ) where +import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Reader import Data.Kind import Data.Text (Text) import Data.Text qualified as T+import Data.Text.IO qualified as T import System.Console.GetOpt import System.Exit+import System.FilePath import System.IO import Config+import Eval+import Repo import Terminal data CommonOptions = CommonOptions { optJobs :: Int+ , optRepo :: [ DeclaredRepo ] } defaultCommonOptions :: CommonOptions defaultCommonOptions = CommonOptions { optJobs = 2+ , optRepo = [] } class CommandArgumentsType (CommandArguments c) => Command c where@@ -77,33 +88,66 @@ newtype CommandExec a = CommandExec (ReaderT CommandInput IO a)- deriving (Functor, Applicative, Monad, MonadIO)+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) +instance MonadFail CommandExec where+ fail = tfail . T.pack++tfail :: Text -> CommandExec a+tfail err = liftIO $ do+ T.hPutStrLn stderr err+ exitFailure+ data CommandInput = CommandInput { ciOptions :: CommonOptions , ciConfigPath :: Maybe FilePath , ciConfig :: Either String Config+ , ciContainingRepo :: Maybe Repo+ , ciOtherRepos :: [ ( RepoName, Repo ) ] , ciTerminalOutput :: TerminalOutput+ , ciStorageDir :: Maybe FilePath } getCommonOptions :: CommandExec CommonOptions getCommonOptions = CommandExec (asks ciOptions) getConfigPath :: CommandExec FilePath-getConfigPath = CommandExec $ do- asks ciConfigPath >>= \case- Nothing -> liftIO $ do- hPutStrLn stderr "no config file found"- exitFailure+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- Left err -> liftIO $ do- hPutStrLn stderr err- exitFailure+getConfig = do+ CommandExec (asks ciConfig) >>= \case+ Left err -> fail err Right config -> return config +getRepo :: RepoName -> CommandExec Repo+getRepo name = do+ CommandExec (asks (lookup name . ciOtherRepos)) >>= \case+ Just repo -> return repo+ Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared"++getDefaultRepo :: CommandExec Repo+getDefaultRepo = do+ tryGetDefaultRepo >>= \case+ Just repo -> return repo+ Nothing -> tfail $ "no default repo"++tryGetDefaultRepo :: CommandExec (Maybe Repo)+tryGetDefaultRepo = CommandExec $ asks ciContainingRepo++getEvalInput :: CommandExec EvalInput+getEvalInput = CommandExec $ do+ eiContainingRepo <- asks ciContainingRepo+ eiOtherRepos <- asks ciOtherRepos+ return EvalInput {..}+ getTerminalOutput :: CommandExec TerminalOutput getTerminalOutput = CommandExec (asks ciTerminalOutput)++getStorageDir :: CommandExec FilePath+getStorageDir = CommandExec (asks ciStorageDir) >>= \case+ Just dir -> return dir+ Nothing -> ((</> ".minici") . takeDirectory) <$> getConfigPath
+ src/Command/Checkout.hs view
@@ -0,0 +1,58 @@+module Command.Checkout (+ CheckoutCommand,+) where++import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T++import System.Console.GetOpt++import Command+import Repo+++data CheckoutCommand = CheckoutCommand CheckoutOptions (Maybe RepoName) (Maybe Text)++data CheckoutOptions = CheckoutOptions+ { coDestination :: Maybe FilePath+ , coSubtree :: Maybe FilePath+ }++instance Command CheckoutCommand where+ commandName _ = "checkout"+ commandDescription _ = "Checkout (part of) a given repository"++ type CommandArguments CheckoutCommand = [ Text ]++ commandUsage _ = T.pack $ unlines $+ [ "Usage: minici checkout [<repo> [<revision>]] [<option>...]"+ ]++ type CommandOptions CheckoutCommand = CheckoutOptions+ defaultCommandOptions _ = CheckoutOptions+ { coDestination = Nothing+ , coSubtree = Nothing+ }++ commandOptions _ =+ [ Option [] [ "dest" ]+ (ReqArg (\val opts -> opts { coDestination = Just val }) "<path>")+ "destination path"+ , Option [] [ "subtree" ]+ (ReqArg (\val opts -> opts { coSubtree = Just val }) "<path>")+ "repository subtree to checkout"+ ]++ commandInit _ co args = CheckoutCommand co+ (RepoName <$> listToMaybe args)+ (listToMaybe $ drop 1 args)+ commandExec = cmdCheckout++cmdCheckout :: CheckoutCommand -> CommandExec ()+cmdCheckout (CheckoutCommand CheckoutOptions {..} name mbrev) = do+ repo <- maybe getDefaultRepo getRepo name+ mbCommit <- sequence $ fmap (readCommit repo) mbrev+ root <- getCommitTree =<< maybe (createWipCommit repo) return mbCommit+ tree <- maybe return (getSubtree mbCommit) coSubtree $ root+ checkoutAt tree $ maybe "." id coDestination
src/Command/Run.hs view
@@ -6,23 +6,21 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad-import Control.Monad.Reader+import Control.Monad.IO.Class +import Data.Either import Data.List import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import System.Console.GetOpt-import System.Directory-import System.Exit-import System.FilePath import System.FilePath.Glob import System.IO-import System.Process import Command import Config+import Eval import Job import Repo import Terminal@@ -46,8 +44,8 @@ commandUsage _ = T.pack $ unlines $ [ "Usage: minici run" , " run jobs for commits on current branch not yet in upstream branch"- , " or: minici run [--since-upstream=]<ref>"- , " run jobs for commits on <ref> not yet in its upstream ref"+ , " or: minici run <job>..."+ , " run jobs specified on the command line" , " or: minici run [--range=]<commit>..<commit>" , " run jobs for commits in given range" , " or: minici run <option>..."@@ -83,6 +81,14 @@ data JobSource = JobSource (TMVar (Maybe ( [ JobSet ], JobSource ))) +emptyJobSource :: MonadIO m => m JobSource+emptyJobSource = JobSource <$> liftIO (newTMVarIO Nothing)++oneshotJobSource :: MonadIO m => [ JobSet ] -> m JobSource+oneshotJobSource jobsets = do+ next <- emptyJobSource+ JobSource <$> liftIO (newTMVarIO (Just ( jobsets, next )))+ takeJobSource :: JobSource -> STM (Maybe ( [ JobSet ], JobSource )) takeJobSource (JobSource tmvar) = takeTMVar tmvar @@ -114,15 +120,29 @@ Just (Just ( jobsets, x' )) -> return ( jobsets, x' : xs ) -rangeSource :: Repo -> Text -> Text -> IO JobSource-rangeSource repo base tip = do+argumentJobSource :: [ JobName ] -> CommandExec JobSource+argumentJobSource [] = emptyJobSource+argumentJobSource names = do+ config <- getConfig+ einput <- getEvalInput+ jobsetJobsEither <- fmap Right $ forM names $ \name ->+ case find ((name ==) . jobName) (configJobs config) of+ Just job -> return job+ Nothing -> tfail $ "job `" <> textJobName name <> "' not found"+ jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo+ oneshotJobSource [ evalJobSet einput JobSet {..} ]++rangeSource :: Text -> Text -> CommandExec JobSource+rangeSource base tip = do+ repo <- getDefaultRepo+ einput <- getEvalInput commits <- listCommits repo (base <> ".." <> tip)- jobsets <- mapM loadJobSetForCommit commits- next <- JobSource <$> newTMVarIO Nothing- JobSource <$> newTMVarIO (Just ( jobsets, next ))+ oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits -watchBranchSource :: Repo -> Text -> IO JobSource-watchBranchSource repo branch = do+watchBranchSource :: Text -> CommandExec JobSource+watchBranchSource branch = do+ repo <- getDefaultRepo+ einput <- getEvalInput getCurrentTip <- watchBranch repo branch let go prev tmvar = do cur <- atomically $ do@@ -133,91 +153,86 @@ Nothing -> retry commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur))- jobsets <- mapM loadJobSetForCommit commits+ jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits nextvar <- newEmptyTMVarIO 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+ 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 :: Repo -> Pattern -> IO JobSource-watchTagSource repo pat = do- chan <- watchTags repo+watchTagSource :: Pattern -> CommandExec JobSource+watchTagSource pat = do+ chan <- watchTags =<< getDefaultRepo+ einput <- getEvalInput let go tmvar = do tag <- atomically $ readTChan chan if match pat $ T.unpack $ tagTag tag then do- jobset <- loadJobSetForCommit $ tagObject tag+ jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag) nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar ) go nextvar 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 CommonOptions {..} <- getCommonOptions tout <- getTerminalOutput- configPath <- getConfigPath- let baseDir = takeDirectory configPath+ storageDir <- getStorageDir - liftIO $ do- repo <- openRepo baseDir >>= \case- Just repo -> return repo- Nothing -> do- absPath <- makeAbsolute baseDir- T.hPutStrLn stderr $ "No repository found at `" <> T.pack absPath <> "'"- exitFailure+ ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence+ [ forM roRanges $ \range -> case T.splitOn ".." range of+ [ base, tip ] -> return $ Left ( Just base, tip )+ _ -> tfail $ "invalid range: " <> range+ , forM roSinceUpstream $ return . Left . ( Nothing, )+ , forM args $ \arg -> case T.splitOn ".." arg of+ [ base, tip ] -> return $ Left ( Just base, tip )+ [ _ ] -> do+ config <- getConfig+ if any ((JobName arg ==) . jobName) (configJobs config)+ then return $ Right $ JobName arg+ else do+ liftIO $ T.hPutStrLn stderr $ "standalone `" <> arg <> "' argument deprecated, use `--since-upstream=" <> arg <> "' instead"+ return $ Left ( Nothing, arg )+ _ -> tfail $ "invalid argument: " <> arg+ ] - rangeOptions <- concat <$> sequence- [ forM roRanges $ \range -> case T.splitOn ".." range of- [ base, tip ] -> return ( Just base, tip )- _ -> do- T.hPutStrLn stderr $ "Invalid range: " <> range- exitFailure- , forM roSinceUpstream $ return . ( Nothing, )- , forM args $ \arg -> case T.splitOn ".." arg of- [ base, tip ] -> return ( Just base, tip )- [ ref ] -> return ( Nothing, ref )- _ -> do- T.hPutStrLn stderr $ "Invalid argument: " <> arg- exitFailure- ]+ argumentJobs <- argumentJobSource jobOptions - let rangeOptions'- | null rangeOptions, null roNewCommitsOn, null roNewTags = [ ( 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- [ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack paramTip ] "" >>= \case- ( ExitSuccess, out, _ ) -> return $ lines out- ( _, _, _ ) -> return [ T.unpack paramTip ]- [ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""- [ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""- return ( T.pack base, T.pack tip )- 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 - mngr <- newJobManager (baseDir </> ".minici") optJobs+ liftIO $ do+ mngr <- newJobManager storageDir optJobs - source <- mergeSources $ concat [ ranges, branches, tags ]+ source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ] headerLine <- newLine tout "" threadCount <- newTVarIO (0 :: Int)@@ -238,12 +253,12 @@ 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- outs <- runJobs mngr commit jobs+ outs <- runJobs mngr tout commit jobs let findJob name = snd <$> find ((name ==) . jobName . fst) outs line <- newLine tout "" mask $ \restore -> do@@ -273,7 +288,7 @@ JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m" JobSkipped -> "\ESC[0m-\ESC[0m " JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "- JobError _ -> "\ESC[91m!!\ESC[0m "+ JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m" JobFailed -> "\ESC[91m✗\ESC[0m " JobCancelled -> "\ESC[0mC\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m "
src/Config.hs view
@@ -9,8 +9,10 @@ import Control.Monad import Control.Monad.Combinators+import Control.Monad.IO.Class import Data.ByteString.Lazy qualified as BS+import Data.Either import Data.List import Data.Map qualified as M import Data.Maybe@@ -21,6 +23,7 @@ import System.Directory import System.FilePath+import System.FilePath.Glob import System.Process import Job.Types@@ -32,17 +35,20 @@ data Config = Config- { configJobs :: [Job]+ { configJobs :: [ DeclaredJob ]+ , configRepos :: [ DeclaredRepo ] } instance Semigroup Config where a <> b = Config { configJobs = configJobs a ++ configJobs b+ , configRepos = configRepos a ++ configRepos b } instance Monoid Config where mempty = Config { configJobs = []+ , configRepos = [] } instance FromYAML Config where@@ -51,22 +57,49 @@ (Mapping pos _ _, _) -> pos (Sequence pos _ _, _) -> pos (Anchor pos _ _, _) -> pos- jobs <- fmap catMaybes $ forM (sortBy (comparing $ posLine . getpos) $ M.assocs m) $ \case- (Scalar _ (SStr tag), node) | ["job", name] <- T.words tag -> do- Just <$> parseJob name node- _ -> return Nothing- return $ Config jobs+ foldM go mempty $ sortBy (comparing $ posLine . getpos) $ M.assocs m+ where+ go config = \case+ (Scalar _ (SStr tag), node)+ | [ "job", name ] <- T.words tag -> do+ job <- parseJob name node+ return $ config { configJobs = configJobs config ++ [ job ] }+ | [ "repo", name ] <- T.words tag -> do+ repo <- parseRepo name node+ return $ config { configRepos = configRepos config ++ [ repo ] }+ _ -> return config -parseJob :: Text -> Node Pos -> Parser Job-parseJob name node = flip (withMap "Job") node $ \j -> Job- <$> pure (JobName name)- <*> choice+parseJob :: Text -> Node Pos -> Parser DeclaredJob+parseJob name node = flip (withMap "Job") node $ \j -> do+ let jobName = JobName name+ ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice+ [ parseSingleCheckout =<< j .: "checkout"+ , parseMultipleCheckouts =<< j .: "checkout"+ , withNull "no checkout" (return []) =<< j .: "checkout"+ , return [ Left $ JobCheckout Nothing Nothing ]+ ]+ jobRecipe <- choice [ cabalJob =<< j .: "cabal" , shellJob =<< j .: "shell" ]- <*> parseArtifacts j- <*> (maybe (return []) parseUses =<< j .:? "uses")+ jobArtifacts <- parseArtifacts j+ jobUses <- maybe (return []) parseUses =<< j .:? "uses"+ return Job {..} +parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]+parseSingleCheckout = withMap "checkout definition" $ \m -> do+ jcSubtree <- fmap T.unpack <$> m .:? "subtree"+ jcDestination <- fmap T.unpack <$> m .:? "dest"+ let checkout = JobCheckout {..}+ m .:? "repo" >>= \case+ Nothing -> return [ Left checkout ]+ Just name -> do+ revision <- m .:? "revision"+ return [ Right ( DeclaredJobRepo (RepoName name), revision, checkout ) ]++parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]+parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout+ cabalJob :: Node Pos -> Parser [CreateProcess] cabalJob = withMap "cabal job" $ \m -> do ghcOptions <- m .:? "ghc-options" >>= \case@@ -80,7 +113,7 @@ shellJob = withSeq "shell commands" $ \xs -> do fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack -parseArtifacts :: Mapping Pos -> Parser [(ArtifactName, CreateProcess)]+parseArtifacts :: Mapping Pos -> Parser [ ( ArtifactName, Pattern ) ] parseArtifacts m = do fmap catMaybes $ forM (M.assocs m) $ \case (Scalar _ (SStr tag), node) | ["artifact", name] <- T.words tag -> do@@ -88,8 +121,8 @@ _ -> return Nothing where parseArtifact name = withMap "Artifact" $ \am -> do- path <- am .: "path"- return (ArtifactName name, proc "echo" [ T.unpack path ])+ pat <- compile . T.unpack <$> am .: "path"+ return ( ArtifactName name, pat ) parseUses :: Node Pos -> Parser [(JobName, ArtifactName)] parseUses = withSeq "Uses list" $ mapM $@@ -97,6 +130,13 @@ [job, art] <- return $ T.split (== '.') text return (JobName job, ArtifactName art) ++parseRepo :: Text -> Node Pos -> Parser DeclaredRepo+parseRepo name node = flip (withMap "Repo") node $ \r -> DeclaredRepo+ <$> pure (RepoName name)+ <*> (T.unpack <$> r .: "path")++ findConfig :: IO (Maybe FilePath) findConfig = go "." where@@ -117,16 +157,16 @@ 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 DeclaredJobSet loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit where toJobSet configEither = JobSet- { jobsetCommit = commit+ { jobsetCommit = Just commit , jobsetJobsEither = fmap configJobs configEither }
+ src/Eval.hs view
@@ -0,0 +1,54 @@+module Eval (+ EvalInput(..),+ EvalError(..), textEvalError,++ evalJob,+ evalJobSet,+) where++import Control.Monad+import Control.Monad.Except++import Data.Bifunctor+import Data.Text (Text)+import Data.Text qualified as T++import Job.Types+import Repo++data EvalInput = EvalInput+ { eiContainingRepo :: Maybe Repo+ , eiOtherRepos :: [ ( RepoName, Repo ) ]+ }++data EvalError+ = OtherEvalError Text++textEvalError :: EvalError -> Text+textEvalError (OtherEvalError text) = text++evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job+evalJob EvalInput {..} decl = do+ otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, revision, checkout ) -> do+ repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $+ lookup name eiOtherRepos+ return ( EvaluatedJobRepo repo, revision, checkout )+ return Job+ { jobName = jobName decl+ , jobContainingCheckout = jobContainingCheckout decl+ , jobOtherCheckout = otherCheckout+ , jobRecipe = jobRecipe decl+ , jobArtifacts = jobArtifacts decl+ , jobUses = jobUses decl+ }++evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet+evalJobSet ei decl = do+ JobSet+ { jobsetCommit = jobsetCommit decl+ , jobsetJobsEither = join $+ fmap (sequence . map (runExceptStr . evalJob ei)) $+ jobsetJobsEither decl+ }+ where+ runExceptStr = first (T.unpack . textEvalError) . runExcept
src/Job.hs view
@@ -1,6 +1,6 @@ module Job (- Job(..),- JobSet(..), jobsetJobs,+ Job, DeclaredJob, Job'(..),+ JobSet, DeclaredJobSet, JobSet'(..), jobsetJobs, JobOutput(..), JobName(..), stringJobName, textJobName, ArtifactName(..),@@ -21,6 +21,7 @@ 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)@@ -30,6 +31,7 @@ import System.Directory import System.Exit import System.FilePath+import System.FilePath.Glob import System.IO import System.IO.Temp import System.Posix.Signals@@ -37,6 +39,7 @@ import Job.Types import Repo+import Terminal data JobOutput = JobOutput@@ -58,7 +61,7 @@ | JobWaiting [JobName] | JobRunning | JobSkipped- | JobError Text+ | JobError TerminalFootnote | JobFailed | JobCancelled | JobDone a@@ -86,7 +89,7 @@ JobWaiting _ -> "waiting" JobRunning -> "running" JobSkipped -> "skipped"- JobError err -> "error\n" <> err+ JobError err -> "error\n" <> footnoteText err JobFailed -> "failed" JobCancelled -> "cancelled" JobDone _ -> "done"@@ -178,12 +181,12 @@ writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks -runJobs :: JobManager -> Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]-runJobs mngr@JobManager {..} commit jobs = do- treeId <- getTreeId commit+runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]+runJobs mngr@JobManager {..} tout commit jobs = do+ tree <- sequence $ fmap getCommitTree commit results <- atomically $ do forM jobs $ \job -> do- let jid = JobId [ JobIdTree treeId, 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@@ -196,9 +199,12 @@ return statusVar forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do- let handler e = atomically $ writeTVar outVar $ if- | Just JobCancelledException <- fromException e -> JobCancelled- | otherwise -> JobError (T.pack $ displayException e)+ let handler e = if+ | Just JobCancelledException <- fromException e -> do+ atomically $ writeTVar outVar $ JobCancelled+ | otherwise -> do+ footnote <- newFootnote tout $ T.pack $ displayException e+ atomically $ writeTVar outVar $ JobError footnote handle handler $ do res <- runExceptT $ do duplicate <- liftIO $ atomically $ do@@ -210,7 +216,7 @@ case duplicate of Nothing -> do- uses <- waitForUsedArtifacts job results outVar+ uses <- waitForUsedArtifacts tout job results outVar runManagedJob mngr tid (return JobCancelled) $ do liftIO $ atomically $ writeTVar outVar JobRunning prepareJob jmDataDir commit job $ \checkoutPath jdir -> do@@ -232,21 +238,18 @@ else wait liftIO wait - case res of- Left (JobError err) -> T.putStrLn err- _ -> return ()- atomically $ writeTVar outVar $ either id id res return $ map (\( job, _, var ) -> ( job, var )) results waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>+ TerminalOutput -> Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]-waitForUsedArtifacts job results outVar = do+waitForUsedArtifacts tout job results outVar = do origState <- liftIO $ atomically $ readTVar outVar ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do case find (\( j, _, _ ) -> jobName j == ujobName) results of Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))- Nothing -> throwError $ JobError $ "Job '" <> tjobName <> "' not found"+ Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found") let loop prev = do ustatuses <- atomically $ do@@ -265,7 +268,7 @@ case ustatus of JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of Just art -> return art- Nothing -> throwError $ JobError $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found"+ Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found") _ -> throwError JobSkipped updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()@@ -279,13 +282,29 @@ 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- checkoutAt commit checkoutPath- tid <- getTreeId commit+ jdirCommit <- case mbCommit of+ Just commit -> do+ tree <- getCommitTree commit+ forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do+ subtree <- maybe return (getSubtree mbCommit) mbsub $ tree+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest+ return $ showTreeId (treeId tree) </> stringJobName (jobName job)+ Nothing -> do+ when (not $ null $ jobContainingCheckout job) $ do+ fail $ "no containing repository, can't do checkout"+ return $ stringJobName (jobName job) - let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job)+ jdirOther <- forM (jobOtherCheckout job) $ \( EvaluatedJobRepo repo, revision, JobCheckout mbsub dest ) -> do+ commit <- readCommit repo $ fromMaybe "HEAD" revision+ tree <- getCommitTree commit+ subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest+ return $ showTreeId (treeId tree)++ let jdir = dir </> "jobs" </> jdirCommit </> joinPath jdirOther liftIO $ createDirectoryIfMissing True jdir inner checkoutPath jdir@@ -312,19 +331,26 @@ | fromIntegral n == -sigINT -> throwError JobCancelled | otherwise -> throwError JobFailed - let adir = jdir </> "artifacts"- artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> liftIO $ do- [path] <- lines <$> readCreateProcess pathCmd { cwd = Just checkoutPath } ""- let target = adir </> T.unpack tname- createDirectoryIfMissing True adir- copyFile (checkoutPath </> path) target- return $ ArtifactOutput- { aoutName = name- , aoutWorkPath = path- , aoutStorePath = target- }+ let adir = jdir </> "artifacts"+ artifacts <- forM (jobArtifacts job) $ \( name@(ArtifactName tname), pathPattern ) -> do+ path <- liftIO (globDir1 pathPattern checkoutPath) >>= \case+ [ path ] -> return path+ found -> do+ liftIO $ hPutStrLn logs $+ (if null found then "no file" else "multiple files") <> " found matching pattern `" <>+ decompile pathPattern <> "' for artifact `" <> T.unpack tname <> "'"+ throwError JobFailed+ let target = adir </> T.unpack tname </> takeFileName path+ liftIO $ do+ createDirectoryIfMissing True $ takeDirectory target+ copyFile (checkoutPath </> path) target+ return $ ArtifactOutput+ { aoutName = name+ , aoutWorkPath = path+ , aoutStorePath = target+ } - return JobOutput- { outName = jobName job- , outArtifacts = artifacts- }+ return JobOutput+ { outName = jobName job+ , outArtifacts = artifacts+ }
src/Job/Types.hs view
@@ -3,18 +3,27 @@ import Data.Text (Text) import Data.Text qualified as T +import System.FilePath.Glob import System.Process import Repo -data Job = Job+data Declared+data Evaluated++data Job' d = Job { jobName :: JobName+ , jobContainingCheckout :: [ JobCheckout ]+ , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ] , jobRecipe :: [ CreateProcess ]- , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]+ , jobArtifacts :: [ ( ArtifactName, Pattern ) ] , jobUses :: [ ( JobName, ArtifactName ) ] } +type Job = Job' Evaluated+type DeclaredJob = Job' Declared+ data JobName = JobName Text deriving (Eq, Ord, Show) @@ -25,14 +34,27 @@ textJobName (JobName name) = name +data JobRepo d where+ DeclaredJobRepo :: RepoName -> JobRepo Declared+ EvaluatedJobRepo :: Repo -> JobRepo Evaluated++data JobCheckout = JobCheckout+ { jcSubtree :: Maybe FilePath+ , jcDestination :: Maybe FilePath+ }++ data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) -data JobSet = JobSet- { jobsetCommit :: Commit- , jobsetJobsEither :: Either String [ Job ]+data JobSet' d = JobSet+ { jobsetCommit :: Maybe Commit+ , jobsetJobsEither :: Either String [ Job' d ] }++type JobSet = JobSet' Evaluated+type DeclaredJobSet = JobSet' Declared jobsetJobs :: JobSet -> [ Job ] jobsetJobs = either (const []) id . jobsetJobsEither
src/Main.hs view
@@ -6,17 +6,22 @@ import Data.ByteString.Lazy qualified as BL import Data.List+import Data.List.NonEmpty qualified as NE import Data.Proxy import Data.Text qualified as T import System.Console.GetOpt+import System.Directory import System.Environment import System.Exit+import System.FilePath import System.IO import Command+import Command.Checkout import Command.Run import Config+import Repo import Terminal import Version @@ -24,6 +29,7 @@ { optShowHelp :: Bool , optShowVersion :: Bool , optCommon :: CommonOptions+ , optStorage :: Maybe FilePath } defaultCmdlineOptions :: CmdlineOptions@@ -31,26 +37,42 @@ { optShowHelp = False , optShowVersion = False , optCommon = defaultCommonOptions+ , optStorage = Nothing } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ] options =- [ Option ['h'] ["help"]- (NoArg $ \opts -> opts { optShowHelp = True })+ [ Option [ 'h' ] [ "help" ]+ (NoArg $ \opts -> return opts { optShowHelp = True }) "show this help and exit"- , Option ['V'] ["version"]- (NoArg $ \opts -> opts { optShowVersion = True })+ , Option [ 'V' ] [ "version" ]+ (NoArg $ \opts -> return opts { optShowVersion = True }) "show version and exit"- , Option ['j'] ["jobs"]- (ReqArg (\num opts -> opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>")+ , Option [ 'j' ] [ "jobs" ]+ (ReqArg (\num opts -> return opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>") ("number of jobs to run simultaneously (default " <> show (optJobs defaultCommonOptions) <> ")")+ , Option [] [ "repo" ]+ (ReqArg (\value opts ->+ case span (/= ':') value of+ ( repo, ':' : path ) -> return opts+ { optCommon = (optCommon opts)+ { optRepo = DeclaredRepo (RepoName $ T.pack repo) path : optRepo (optCommon opts)+ }+ }+ _ -> throwError $ "--repo: invalid value `" <> value <> "'"+ ) "<repo>:<path>")+ ("override or declare repo path")+ , Option [] [ "storage" ]+ (ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>")+ "set storage path" ] data SomeCommandType = forall c. Command c => SC (Proxy c) -commands :: [ SomeCommandType ]+commands :: NE.NonEmpty SomeCommandType commands =- [ SC $ Proxy @RunCommand+ ( SC $ Proxy @RunCommand) NE.:|+ [ SC $ Proxy @CheckoutCommand ] lookupCommand :: String -> Maybe SomeCommandType@@ -61,25 +83,40 @@ main :: IO () main = do args <- getArgs- (opts, cmdargs) <- case getOpt RequireOrder options args of- (o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)+ let ( mbConfigPath, args' ) = case args of+ (path : rest)+ | any isPathSeparator path -> ( Just path, rest )+ _ -> ( Nothing, args )++ (opts, cmdargs) <- case getOpt RequireOrder options args' of+ (os, cmdargs, []) -> do+ let merge :: ([String], CmdlineOptions) -> (CmdlineOptions -> Except String CmdlineOptions) -> ([String], CmdlineOptions)+ merge ( errs, o ) f = case runExcept $ f o of+ Left err -> ( err : errs, o )+ Right o' -> ( errs, o' )++ case foldl merge ( [], defaultCmdlineOptions ) os of+ ( [], opts ) -> return ( opts , cmdargs )+ ( errs, _ ) -> do+ hPutStrLn stderr $ unlines (reverse errs) <> "Try `minici --help' for more information."+ exitFailure (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information." exitFailure when (optShowHelp opts) $ do- let header = "Usage: minici [<option>...] <command> [<args>]\n\nCommon options are:"+ let header = "Usage: minici [<job-file>] [<option>...] <command> [<args>]\n\nCommon options are:" commandDesc (SC proxy) = " " <> padCommand (commandName proxy) <> commandDescription proxy padTo n str = str <> replicate (n - length str) ' ' padCommand = padTo (maxCommandNameLength + 3) commandNameLength (SC proxy) = length $ commandName proxy- maxCommandNameLength = maximum $ map commandNameLength commands+ maxCommandNameLength = maximum $ fmap commandNameLength commands putStr $ usageInfo header options <> unlines ( [ "" , "Available commands:"- ] ++ map commandDesc commands+ ] ++ map commandDesc (NE.toList commands) ) exitSuccess @@ -87,8 +124,17 @@ putStrLn versionLine exitSuccess - (ncmd, cargs) <- case cmdargs of- [] -> return (head commands, [])+ ( configPath, cmdargs' ) <- case ( mbConfigPath, cmdargs ) of+ ( Just path, _ )+ -> return ( Just path, cmdargs )+ ( _, path : rest )+ | any isPathSeparator path+ -> return ( Just path, rest )+ _ -> ( , cmdargs ) <$> findConfig++ ( ncmd, cargs ) <- case cmdargs' of+ [] -> return ( NE.head commands, [] )+ (cname : cargs) | Just nc <- lookupCommand cname -> return (nc, cargs) | otherwise -> do@@ -98,7 +144,7 @@ ] exitFailure - runSomeCommand (optCommon opts) ncmd cargs+ runSomeCommand configPath opts ncmd cargs data FullCommandOptions c = FullCommandOptions { fcoSpecific :: CommandOptions c@@ -120,8 +166,10 @@ "show this help and exit" ] -runSomeCommand :: CommonOptions -> SomeCommandType -> [ String ] -> IO ()-runSomeCommand ciOptions (SC tproxy) args = do+runSomeCommand :: Maybe FilePath -> CmdlineOptions -> SomeCommandType -> [ String ] -> IO ()+runSomeCommand ciConfigPath gopts (SC tproxy) args = do+ let ciOptions = optCommon gopts+ ciStorageDir = optStorage gopts let exitWithErrors errs = do hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information." exitFailure@@ -138,12 +186,34 @@ putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy) exitSuccess - ciConfigPath <- findConfig ciConfig <- case ciConfigPath of Just path -> parseConfig <$> BL.readFile path- Nothing -> return $ Left "no config file found"+ Nothing -> return $ Left "no job file found" let cmd = commandInit tproxy (fcoSpecific opts) cmdargs let CommandExec exec = commandExec cmd++ ciContainingRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath++ let openDeclaredRepo dir decl = do+ let path = dir </> repoPath decl+ openRepo path >>= \case+ Just repo -> return ( repoName decl, repo )+ Nothing -> do+ absPath <- makeAbsolute path+ hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl <> " (" <> absPath <> ")"+ exitFailure++ cmdlineRepos <- forM (optRepo ciOptions) (openDeclaredRepo "")+ configRepos <- case ( ciConfigPath, ciConfig ) of+ ( Just path, Right config ) ->+ forM (configRepos config) $ \decl -> do+ case lookup (repoName decl) cmdlineRepos of+ Just repo -> return ( repoName decl, repo )+ Nothing -> openDeclaredRepo (takeDirectory path) decl+ _ -> return []++ let ciOtherRepos = configRepos ++ cmdlineRepos+ ciTerminalOutput <- initTerminalOutput flip runReaderT CommandInput {..} exec
src/Repo.hs view
@@ -1,19 +1,28 @@ module Repo (- Repo, Commit, commitId,+ Repo,+ DeclaredRepo(..),+ RepoName(..), textRepoName, showRepoName,+ Commit, commitId, CommitId, textCommitId, showCommitId,+ Tree, treeId, treeRepo, TreeId, textTreeId, showTreeId, Tag(..), openRepo,+ readCommit, readBranch, readTag, listCommits,+ findUpstreamRef, - getTreeId,+ getCommitTree, getCommitTitle, getCommitMessage, + getSubtree,+ checkoutAt,+ createWipCommit, readCommittedFile, watchBranch,@@ -22,8 +31,9 @@ import Control.Concurrent import Control.Concurrent.STM-import Control.Exception+import Control.Exception (IOException) import Control.Monad+import Control.Monad.Catch import Control.Monad.IO.Class import Data.ByteString (ByteString)@@ -37,10 +47,11 @@ import Data.Text qualified as T import Data.Text.Encoding -import System.Directory+import System.Environment import System.Exit import System.FilePath import System.INotify+import System.IO.Temp import System.Process @@ -52,6 +63,21 @@ , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ]) } +data DeclaredRepo = DeclaredRepo+ { repoName :: RepoName+ , repoPath :: FilePath+ }++newtype RepoName = RepoName Text+ deriving (Eq, Ord)++textRepoName :: RepoName -> Text+textRepoName (RepoName text) = text++showRepoName :: RepoName -> String+showRepoName = T.unpack . textRepoName++ data Commit = Commit { commitRepo :: Repo , commitId_ :: CommitId@@ -62,11 +88,16 @@ commitId = commitId_ data CommitDetails = CommitDetails- { commitTreeId :: TreeId+ { commitTree :: Tree , commitTitle :: Text , commitMessage :: Text } +data Tree = Tree+ { treeRepo :: Repo+ , treeId :: TreeId+ }+ data Tag a = Tag { tagTag :: Text , tagObject :: a@@ -100,6 +131,12 @@ showTreeId (TreeId tid) = BC.unpack tid +runGitCommand :: MonadIO m => Repo -> [ String ] -> m String+runGitCommand GitRepo {..} args = liftIO $ do+ withMVar gitLock $ \_ -> do+ readProcess "git" (("--git-dir=" <> gitDir) : args) ""++ openRepo :: FilePath -> IO (Maybe Repo) openRepo path = do findGitDir >>= \case@@ -121,14 +158,20 @@ Just dir -> return (Just dir) _ -> return Nothing -mkCommit :: Repo -> CommitId -> IO Commit+mkCommit :: MonadIO m => Repo -> CommitId -> m Commit mkCommit commitRepo commitId_ = do- commitDetails <- newMVar Nothing+ commitDetails <- liftIO $ newMVar Nothing 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 <> "'"+ readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit) readCommitFromFile repo@GitRepo {..} path = liftIO $ do- try @IOException (BC.readFile $ gitDir </> path) >>= \case+ try @IO @IOException (BC.readFile $ gitDir </> path) >>= \case Right content | (cid : _) <- BC.lines content -> do Just <$> mkCommit repo (CommitId cid) _ -> do@@ -138,11 +181,10 @@ readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch) readTag :: MonadIO m => Repo -> Text -> m (Maybe (Tag Commit))-readTag repo@GitRepo {..} tag = do+readTag repo tag = do ( infoPart, message ) <- fmap (fmap (drop 1) . span (not . null) . lines) $- liftIO $ withMVar gitLock $ \_ -> do- readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "tag", T.unpack tag ] ""+ runGitCommand repo [ "cat-file", "tag", T.unpack tag ] let info = map (fmap (drop 1) . span (/= ' ')) infoPart sequence $ do@@ -157,16 +199,28 @@ listCommits :: MonadIO m => Repo -> Text -> m [ Commit ] listCommits commitRepo range = liftIO $ do- out <- readProcess "git" [ "log", "--pretty=%H", "--first-parent", "--reverse", T.unpack range ] ""+ out <- runGitCommand commitRepo [ "log", "--pretty=%H", "--first-parent", "--reverse", T.unpack range ] forM (lines out) $ \cid -> do let commitId_ = CommitId (BC.pack cid) commitDetails <- newMVar Nothing return Commit {..} +findUpstreamRef :: MonadIO m => Repo -> Text -> m (Maybe Text)+findUpstreamRef repo@GitRepo {..} ref = liftIO $ do+ deref <- readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "symbolic-ref", "--quiet", T.unpack ref ] "" >>= \case+ ( ExitSuccess, out, _ ) | [ deref ] <- lines out -> return deref+ ( _, _, _ ) -> return $ T.unpack ref+ runGitCommand repo [ "show-ref", deref ] >>= \case+ out | [ _, fullRef ] : _ <- words <$> lines out+ -> runGitCommand repo [ "for-each-ref", "--format=%(upstream)", fullRef ] >>= \case+ out' | [ upstream ] <- lines out'+ -> return $ Just $ T.pack upstream+ _ -> return Nothing+ _ -> return Nothing + getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails getCommitDetails Commit {..} = do- let GitRepo {..} = commitRepo liftIO $ do modifyMVar commitDetails $ \case cur@(Just details) -> do@@ -174,19 +228,20 @@ Nothing -> do ( infoPart, _ : title : message ) <- fmap (span (not . null) . lines) $- withMVar gitLock $ \_ -> do- readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId_ ] ""+ runGitCommand commitRepo [ "cat-file", "commit", showCommitId commitId_ ] let info = map (fmap (drop 1) . span (/= ' ')) infoPart - Just commitTreeId <- return $ TreeId . BC.pack <$> lookup "tree" info+ Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info+ let treeRepo = commitRepo+ let commitTree = Tree {..} let commitTitle = T.pack title let commitMessage = T.pack $ unlines $ dropWhile null message let details = CommitDetails {..} return ( Just details, details ) -getTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId-getTreeId = fmap commitTreeId . getCommitDetails+getCommitTree :: (MonadIO m, MonadFail m) => Commit -> m Tree+getCommitTree = fmap commitTree . getCommitDetails getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text getCommitTitle = fmap commitTitle . getCommitDetails@@ -195,16 +250,82 @@ getCommitMessage = fmap commitMessage . getCommitDetails -checkoutAt :: (MonadIO m, MonadFail m) => Commit -> FilePath -> m ()-checkoutAt Commit {..} dest = do- let GitRepo {..} = commitRepo- liftIO $ withMVar gitLock $ \_ -> do- "" <- readProcess "git" [ "clone", "--quiet", "--shared", "--no-checkout", gitDir, dest ] ""- "" <- readProcess "git" [ "-C", dest, "restore", "--worktree", "--source=" <> showCommitId commitId_, "--", "." ] ""- removeDirectoryRecursive $ dest </> ".git"+getSubtree :: (MonadIO m, MonadFail m) => Maybe Commit -> FilePath -> Tree -> m Tree+getSubtree mbCommit path tree = liftIO $ do+ let GitRepo {..} = treeRepo tree+ readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> path ] "" >>= \case+ ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do+ return Tree+ { treeRepo = treeRepo tree+ , treeId = TreeId (BC.pack tid)+ }+ _ -> do+ fail $ "subtree `" <> path <> "' not found" <> maybe "" (("in revision `" <>) . (<> "'") . showCommitId . commitId) mbCommit -readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString)+checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()+checkoutAt Tree {..} dest = do+ let GitRepo {..} = treeRepo+ liftIO $ withSystemTempFile "minici-checkout.index" $ \index _ -> do+ curenv <- getEnvironment+ let readGitProcess args input =+ withMVar gitLock $ \_ ->+ readCreateProcess (proc "git" args)+ { env = Just $ concat+ [ [ ( "GIT_INDEX_FILE", index ) ]+ , [ ( "GIT_DIR", gitDir ) ]+ , [ ( "GIT_WORK_TREE", "." ) ]+ , curenv+ ]+ } input+ "" <- readGitProcess [ "read-tree", showTreeId treeId ] ""+ "" <- readGitProcess [ "checkout-index", "--all", "--prefix=" <> addTrailingPathSeparator dest ] ""+ return ()++createWipCommit :: (MonadIO m, MonadMask m, MonadFail m) => Repo -> m Commit+createWipCommit repo@GitRepo {..} = do+ withSystemTempFile "minici-wip.index" $ \index _ -> do+ curenv <- liftIO getEnvironment+ let readGitProcess mbWorkTree args input = liftIO $ do+ withMVar gitLock $ \_ ->+ readCreateProcess (proc "git" args)+ { env = Just $ concat+ [ [ ( "GIT_INDEX_FILE", index ) ]+ , [ ( "GIT_DIR", gitDir ) ]+ , map (( "GIT_WORK_TREE", ) . T.unpack) $ maybeToList mbWorkTree+ , curenv+ ]+ } input+ mkPair = fmap (T.dropWhile (== ' ')) . T.break (== ' ')+ info <- map mkPair . takeWhile (not . T.null) . T.splitOn "\0". T.pack <$>+ readGitProcess Nothing [ "worktree", "list", "--porcelain", "-z" ] ""+ case ( lookup "worktree" info, lookup "HEAD" info ) of+ ( Just worktree, Just headRev ) -> do+ let readGitProcessW = readGitProcess (Just worktree)++ headCommit <- mkCommit repo (CommitId $ encodeUtf8 headRev)+ headTree <- getCommitTree headCommit++ "" <- readGitProcessW [ "read-tree", "--empty" ] ""+ status <- map mkPair . T.splitOn "\0" . T.pack <$>+ readGitProcessW [ "status", "--porcelain=v1", "-z", "--untracked-files=all" ] ""+ "" <- readGitProcessW [ "update-index", "--add", "-z", "--stdin" ] $ T.unpack $ T.intercalate "\0" $ map snd status+ [ tid ] <- lines <$> readGitProcessW [ "write-tree" ] ""++ if TreeId (BC.pack tid) == treeId headTree+ then return headCommit+ else do+ headMsg <- getCommitTitle headCommit+ let wipMsg = case lookup "branch" info of+ Just branch -> "WIP on " <> branch <> ": " <> headMsg+ Nothing -> "WIP: " <> headMsg+ [ cid ] <- lines <$> readGitProcessW [ "commit-tree", "-m", T.unpack wipMsg, "-p", T.unpack headRev, tid ] ""+ mkCommit repo (CommitId $ BC.pack cid)++ _ -> readCommit repo "HEAD"+++readCommittedFile :: MonadIO m => Commit -> FilePath -> m (Maybe BL.ByteString) readCommittedFile Commit {..} path = do let GitRepo {..} = commitRepo liftIO $ withMVar gitLock $ \_ -> do@@ -256,14 +377,14 @@ 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
src/Terminal.hs view
@@ -1,9 +1,11 @@ module Terminal ( TerminalOutput, TerminalLine,+ TerminalFootnote(..), initTerminalOutput, newLine, redrawLine,+ newFootnote, terminalBlinkStatus, ) where @@ -11,6 +13,7 @@ import Control.Concurrent.STM import Control.Monad +import Data.Function import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T@@ -20,17 +23,30 @@ data TerminalOutput = TerminalOutput { outNumLines :: MVar Int+ , outNextFootnote :: MVar Int , outBlinkVar :: TVar Bool } +instance Eq TerminalOutput where+ (==) = (==) `on` outNumLines+ data TerminalLine = TerminalLine { lineOutput :: TerminalOutput , lineNum :: Int }+ deriving (Eq) +data TerminalFootnote = TerminalFootnote+ { footnoteLine :: TerminalLine+ , footnoteNumber :: Int+ , footnoteText :: Text+ }+ deriving (Eq)+ initTerminalOutput :: IO TerminalOutput initTerminalOutput = do outNumLines <- newMVar 0+ outNextFootnote <- newMVar 1 outBlinkVar <- newTVarIO False void $ forkIO $ forever $ do threadDelay 500000@@ -51,6 +67,13 @@ let moveBy = total - lineNum T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u" hFlush stdout++newFootnote :: TerminalOutput -> Text -> IO TerminalFootnote+newFootnote tout@TerminalOutput {..} footnoteText = do+ modifyMVar outNextFootnote $ \footnoteNumber -> do+ footnoteLine <- newLine tout $ "[" <> T.pack (show footnoteNumber) <> "] " <> footnoteText+ hFlush stdout+ return ( footnoteNumber + 1, TerminalFootnote {..} ) terminalBlinkStatus :: TerminalOutput -> STM Bool terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar