mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

factor out commitTree

Browse source
This commit is contained in:
Joey Hess 2016-02-25 15:33:50 -04:00
parent 1f91d1d0b7
commit 7b2496508f
Failed to extract signature
1 changed files with 13 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

20
Git/Branch.hs
View file

@ -23,7 +23,7 @@ import qualified Git.BuildVersion
- branch is not created yet. So, this also looks at show-ref HEAD - branch is not created yet. So, this also looks at show-ref HEAD
- to double-check. - to double-check.
-} -}
current :: Repo -> IO (Maybe Git.Ref) current :: Repo -> IO (Maybe Branch)
current r = do current r = do
v <- currentUnsafe r v <- currentUnsafe r
case v of case v of
@ -35,7 +35,7 @@ current r = do
) )
{- The current branch, which may not really exist yet. -} {- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe :: Repo -> IO (Maybe Branch)
currentUnsafe r = parse . firstLine currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where where
@ -144,26 +144,32 @@ commit commitmode allowempty message branch parentrefs repo = do
pipeReadStrict [Param "write-tree"] repo pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree) ifM (cancommit tree)
( do ( do
sha <- getSha "commit-tree" $ sha <- commitTree commitmode message parentrefs tree repo
pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
update branch sha repo update branch sha repo
return $ Just sha return $ Just sha
, return Nothing , return Nothing
) )
where where
ps = applyCommitMode commitmode $
map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree cancommit tree
| allowempty = return True | allowempty = return True
| otherwise = case parentrefs of | otherwise = case parentrefs of
[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
_ -> return True _ -> return True
sendmsg = Just $ flip hPutStr message
commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
commitAlways commitmode message branch parentrefs repo = fromJust commitAlways commitmode message branch parentrefs repo = fromJust
<$> commit commitmode True message branch parentrefs repo <$> commit commitmode True message branch parentrefs repo
commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
commitTree commitmode message parentrefs tree repo =
getSha "commit-tree" $
pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps)
sendmsg repo
where
ps = applyCommitMode commitmode $
map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
sendmsg = Just $ flip hPutStr message
{- A leading + makes git-push force pushing a branch. -} {- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String forcePush :: String -> String
forcePush b = "+" ++ b forcePush b = "+" ++ b