From 6e3893f7cd303c40b4f40f2095748bdf6da34e00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 19 Jul 2026 08:44:44 +0200 Subject: Branch type and push function --- src/Repo.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/Repo.hs b/src/Repo.hs index 2093a9a..c6fc275 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -8,6 +8,7 @@ module Repo ( TreeId, textTreeId, showTreeId, Tag(..), TagId, textTagId, showTagId, + Branch(..), openRepo, readCommit, readCommitId, tryReadCommit, @@ -27,6 +28,7 @@ module Repo ( checkoutAt, createWipCommit, readCommittedFile, + pushToBranch, watchBranch, watchTags, @@ -115,6 +117,11 @@ data Tag a = Tag , tagMessage :: Text } +data Branch = Branch + { branchRepo :: Repo + , branchName :: Text + } + instance Eq Repo where (==) = (==) `on` gitLock @@ -428,6 +435,23 @@ readCommittedFile Tree {..} path = do return (Just content) | otherwise -> error "createProcess must return stdout handle" +pushToBranch :: (MonadIO m, MonadFail m) => Branch -> Commit -> m () +pushToBranch Branch {..} Commit {..} = do + liftIO $ + withMVar (gitLock branchRepo) $ \_ -> + withMVar (gitLock commitRepo) $ \_ -> do + let cmd = (proc "git" [ "--git-dir=" <> gitDir commitRepo, "push", "--quiet", "--porcelain", gitDir branchRepo, showCommitId commitId_ <> ":refs/heads/" <> T.unpack branchName ]) + { std_in = NoStream + , std_out = CreatePipe + , std_err = NoStream + } + createProcess cmd >>= \( _, mbstdout, _, ph ) -> if + | Just _ <- mbstdout -> do + waitForProcess ph >>= \case + ExitSuccess -> return () + code -> fail $ "git push exited with error: " <> show code + | otherwise -> error "createProcess must return stdout handle" + repoInotify :: Repo -> IO ( INotify, TChan (Tag Commit) ) repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case -- cgit v1.2.3