module Git.Commit.Push where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class
import Data.Function
import qualified Data.HashSet as HashSet
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Tagged
import Data.Text (Text)
import Data.Traversable (for)
import Git.Commit
import Git.Object
import Git.Reference
import Git.Repository
import Git.Types
import Prelude
pushCommit :: (MonadGit r m, MonadGit s (t m), MonadTrans t)
=> CommitOid r -> Text -> t m (CommitOid s)
pushCommit coid remoteRefName = do
commits <- mapM copyCommitOid =<< lift (listCommits Nothing coid)
mrref <- fmap Tagged `liftM` resolveReference remoteRefName
mrref' <- for mrref $ \rref ->
if rref `elem` commits
then lift $ copyCommitOid rref
else throwM $ PushNotFastForward
$ "SHA " <> renderObjOid rref
<> " not found in remote"
objs <- lift $ listAllObjects mrref' coid
let shas = HashSet.fromList $ map (renderOid . untagObjOid) objs
(cref,_) <- copyCommit coid Nothing shas
unless (renderObjOid coid == renderObjOid cref) $
throwM $ BackendError $ "Error copying commit: "
<> renderObjOid coid <> " /= " <> renderObjOid cref
return cref
copyRepository :: (MonadGit r m, MonadUnliftIO m,
MonadGit s (t m), MonadTrans t, MonadUnliftIO (t m))
=> RepositoryFactory (t m) m s
-> Maybe (CommitOid r)
-> Text
-> FilePath
-> Bool
-> m ()
copyRepository factory mname refName gitDir isBare =
withRepository' factory RepositoryOptions
{ repoPath = gitDir
, repoWorkingDir = Nothing
, repoIsBare = isBare
, repoAutoCreate = True
}
(maybe (return ()) go mname)
where
go coid = do
cref <- pushCommit coid refName
updateReference refName (RefObj (untag cref))
updateReference "HEAD" (RefSymbolic refName)
mref <- fmap renderOid <$> resolveReference refName
unless (maybe False (renderObjOid coid ==) mref) $
throwM (BackendError $
"Could not resolve destination reference '"
<> refName <> "'in project")