Watch branches and tags in git repositories

1 files changed, 132 insertions, 27 deletions

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