diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Run.hs | 2 | ||||
| -rw-r--r-- | src/Job.hs | 4 | ||||
| -rw-r--r-- | src/Repo.hs | 159 |
3 files changed, 135 insertions, 30 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 945a4fd..14341cd 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -79,7 +79,7 @@ cmdRun (RunCommand changeset) = do forM_ jobssets $ \jobset -> do let commit = jobsetCommit jobset shortCid = T.pack $ take 7 $ showCommitId $ commitId commit - shortDesc = fitToLength 50 (commitDescription commit) + shortDesc <- fitToLength 50 <$> getCommitTitle commit case jobsetJobsEither jobset of Right jobs -> do outs <- runJobs mngr commit jobs @@ -179,7 +179,7 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case runJobs :: JobManager -> Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] runJobs mngr@JobManager {..} commit jobs = do - treeId <- readTreeId commit + treeId <- getTreeId commit results <- atomically $ do forM jobs $ \job -> do let jid = JobId [ JobIdTree treeId, JobIdName (jobName job) ] @@ -285,7 +285,7 @@ prepareJob dir commit job inner = do flip finally (liftIO $ removeDirectoryRecursive checkoutPath) $ do checkoutAt commit checkoutPath - tid <- readTreeId commit + tid <- getTreeId commit let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job) liftIO $ createDirectoryIfMissing True jdir diff --git a/src/Repo.hs b/src/Repo.hs index 45fdb04..caa8a20 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -1,28 +1,45 @@ module Repo ( - Repo(..), Commit(..), + Repo, Commit, commitId, CommitId, showCommitId, TreeId, showTreeId, openRepo, + readBranch, + readTag, listCommits, + + getTreeId, + getCommitTitle, + getCommitMessage, + checkoutAt, - readTreeId, readCommittedFile, + + watchBranch, + watchTags, ) where import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL +import Data.Function +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding import System.Directory import System.Exit import System.FilePath +import System.INotify import System.Process @@ -30,15 +47,32 @@ data Repo = GitRepo { gitDir :: FilePath , gitLock :: MVar () + , gitInotify :: MVar (Maybe ( INotify, TChan Text )) + , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ]) } data Commit = Commit { commitRepo :: Repo - , commitId :: CommitId - , commitDescription :: Text - , commitTreeId :: MVar (Maybe TreeId) + , commitId_ :: CommitId + , commitDetails :: MVar (Maybe CommitDetails) + } + +commitId :: Commit -> CommitId +commitId = commitId_ + +data CommitDetails = CommitDetails + { commitTreeId :: TreeId + , commitTitle :: Text + , commitMessage :: Text } +instance Eq Repo where + (==) = (==) `on` gitLock + +instance Eq Commit where + x == y = commitRepo x == commitRepo y && + commitId_ x == commitId_ y + newtype CommitId = CommitId ByteString deriving (Eq, Ord) @@ -58,6 +92,8 @@ openRepo path = do findGitDir >>= \case Just gitDir -> do gitLock <- newMVar () + gitInotify <- newMVar Nothing + gitWatchedBranches <- newMVar M.empty return $ Just GitRepo {..} Nothing -> do return Nothing @@ -72,46 +108,76 @@ openRepo path = do Just dir -> return (Just dir) _ -> return Nothing +readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit) +readCommitFromFile commitRepo@GitRepo {..} path = liftIO $ do + try @IOException (BC.readFile $ gitDir </> path) >>= \case + Right content | (cid : _) <- BC.lines content -> do + let commitId_ = CommitId cid + commitDetails <- newMVar Nothing + return $ Just Commit {..} + _ -> do + return Nothing + +readBranch :: MonadIO m => Repo -> Text -> m (Maybe Commit) +readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch) + +readTag :: MonadIO m => Repo -> Text -> m (Maybe Commit) +readTag repo tag = readCommitFromFile repo ("refs/tags" </> T.unpack tag) listCommits :: MonadIO m => Repo -> String -> m [ Commit ] listCommits commitRepo range = liftIO $ do - out <- readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", range ] "" - forM (lines out) $ \line -> do - let ( cid, desc ) = fmap (drop 1) $ (span (/=' ')) line - commitId = CommitId (BC.pack cid) - commitDescription = T.pack desc - commitTreeId <- newMVar Nothing + out <- readProcess "git" [ "log", "--pretty=%H", "--first-parent", "--reverse", range ] "" + forM (lines out) $ \cid -> do + let commitId_ = CommitId (BC.pack cid) + commitDetails <- newMVar Nothing return Commit {..} +getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails +getCommitDetails Commit {..} = do + let GitRepo {..} = commitRepo + liftIO $ do + modifyMVar commitDetails $ \case + cur@(Just details) -> do + return ( cur, details ) + Nothing -> do + ( infoPart, _ : title : message ) <- + fmap (span (not . null) . lines) $ + withMVar gitLock $ \_ -> do + readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId_ ] "" + let info = map (fmap (drop 1) . span (/= ' ')) infoPart + + Just commitTreeId <- return $ TreeId . BC.pack <$> lookup "tree" info + 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 + +getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text +getCommitTitle = fmap commitTitle . getCommitDetails + +getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text +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, "--", "." ] "" + "" <- readProcess "git" [ "-C", dest, "restore", "--worktree", "--source=" <> showCommitId commitId_, "--", "." ] "" removeDirectoryRecursive $ dest </> ".git" -readTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId -readTreeId Commit {..} = do - let GitRepo {..} = commitRepo - liftIO $ do - modifyMVar commitTreeId $ \case - Just tid -> do - return ( Just tid, tid ) - Nothing -> do - withMVar gitLock $ \_ -> do - [ "tree", stid ] : _ <- map words . lines <$> readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId ] "" - let tid = TreeId $ BC.pack stid - return ( Just tid, tid ) - - readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString) readCommittedFile Commit {..} path = do let GitRepo {..} = commitRepo 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", showCommitId commitId_ <> ":" <> path ]) { std_in = NoStream , std_out = CreatePipe } @@ -130,3 +196,42 @@ readCommittedFile Commit {..} path = do _ -> return (Just content) | otherwise -> error "createProcess must return stdout handle" + + +repoInotify :: Repo -> IO ( INotify, TChan Text ) +repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case + cur@(Just info) -> + return ( cur, info ) + Nothing -> do + inotify <- initINotify + tagsChan <- newBroadcastTChanIO + let info = ( inotify, tagsChan ) + + _ <- addWatch inotify [ MoveIn ] (BC.pack headsDir) $ \event -> do + let branch = decodeUtf8 $ filePath event + tvars <- fromMaybe [] . M.lookup branch <$> readMVar gitWatchedBranches + when (not $ null tvars) $ do + commit <- readBranch repo branch + atomically $ do + mapM_ (`writeTVar` commit) tvars + + _ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do + let tag = decodeUtf8 $ filePath event + atomically $ writeTChan tagsChan tag + + return ( Just info, info ) + where + headsDir = gitDir </> "refs/heads" + tagsDir = gitDir </> "refs/tags" + +watchBranch :: Repo -> Text -> IO (STM (Maybe Commit)) +watchBranch repo@GitRepo {..} branch = do + var <- newTVarIO =<< readBranch repo branch + void $ repoInotify repo + modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ] + return $ readTVar var + +watchTags :: Repo -> IO (TChan Text) +watchTags repo = do + tagsChan <- snd <$> repoInotify repo + atomically $ dupTChan tagsChan |