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 :: CommitOid r -> Text -> t m (CommitOid s)
pushCommit CommitOid r
coid Text
remoteRefName = do
[CommitOid s]
commits <- (CommitOid r -> t m (CommitOid s))
-> [CommitOid r] -> t m [CommitOid s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CommitOid r -> t m (CommitOid s)
forall r s (n :: * -> *).
(IsOid (Oid r), MonadGit s n) =>
CommitOid r -> n (CommitOid s)
copyCommitOid ([CommitOid r] -> t m [CommitOid s])
-> t m [CommitOid r] -> t m [CommitOid s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m [CommitOid r] -> t m [CommitOid r]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe (CommitOid r) -> CommitOid r -> m [CommitOid r]
forall r (m :: * -> *).
MonadGit r m =>
Maybe (CommitOid r) -> CommitOid r -> m [CommitOid r]
listCommits Maybe (CommitOid r)
forall a. Maybe a
Nothing CommitOid r
coid)
Maybe (CommitOid s)
mrref <- (Oid s -> CommitOid s) -> Maybe (Oid s) -> Maybe (CommitOid s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Oid s -> CommitOid s
forall k (s :: k) b. b -> Tagged s b
Tagged (Maybe (Oid s) -> Maybe (CommitOid s))
-> t m (Maybe (Oid s)) -> t m (Maybe (CommitOid s))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Text -> t m (Maybe (Oid s))
forall r (m :: * -> *). MonadGit r m => Text -> m (Maybe (Oid r))
resolveReference Text
remoteRefName
Maybe (CommitOid r)
mrref' <- Maybe (CommitOid s)
-> (CommitOid s -> t m (CommitOid r)) -> t m (Maybe (CommitOid r))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (CommitOid s)
mrref ((CommitOid s -> t m (CommitOid r)) -> t m (Maybe (CommitOid r)))
-> (CommitOid s -> t m (CommitOid r)) -> t m (Maybe (CommitOid r))
forall a b. (a -> b) -> a -> b
$ \CommitOid s
rref ->
if CommitOid s
rref CommitOid s -> [CommitOid s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CommitOid s]
commits
then m (CommitOid r) -> t m (CommitOid r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (CommitOid r) -> t m (CommitOid r))
-> m (CommitOid r) -> t m (CommitOid r)
forall a b. (a -> b) -> a -> b
$ CommitOid s -> m (CommitOid r)
forall r s (n :: * -> *).
(IsOid (Oid r), MonadGit s n) =>
CommitOid r -> n (CommitOid s)
copyCommitOid CommitOid s
rref
else GitException -> t m (CommitOid r)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GitException -> t m (CommitOid r))
-> GitException -> t m (CommitOid r)
forall a b. (a -> b) -> a -> b
$ Text -> GitException
PushNotFastForward
(Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$ Text
"SHA " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CommitOid s -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid s
rref
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found in remote"
[ObjectOid r]
objs <- m [ObjectOid r] -> t m [ObjectOid r]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ObjectOid r] -> t m [ObjectOid r])
-> m [ObjectOid r] -> t m [ObjectOid r]
forall a b. (a -> b) -> a -> b
$ Maybe (CommitOid r) -> CommitOid r -> m [ObjectOid r]
forall r (m :: * -> *).
MonadGit r m =>
Maybe (CommitOid r) -> CommitOid r -> m [ObjectOid r]
listAllObjects Maybe (CommitOid r)
mrref' CommitOid r
coid
let shas :: HashSet Text
shas = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([Text] -> HashSet Text) -> [Text] -> HashSet Text
forall a b. (a -> b) -> a -> b
$ (ObjectOid r -> Text) -> [ObjectOid r] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Oid r -> Text
forall o. IsOid o => o -> Text
renderOid (Oid r -> Text) -> (ObjectOid r -> Oid r) -> ObjectOid r -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectOid r -> Oid r
forall r. ObjectOid r -> Oid r
untagObjOid) [ObjectOid r]
objs
(CommitOid s
cref,HashSet Text
_) <- CommitOid r
-> Maybe Text -> HashSet Text -> t m (CommitOid s, HashSet Text)
forall r (m :: * -> *) s (t :: (* -> *) -> * -> *).
(MonadGit r m, MonadGit s (t m), MonadTrans t) =>
CommitOid r
-> Maybe Text -> HashSet Text -> t m (CommitOid s, HashSet Text)
copyCommit CommitOid r
coid Maybe Text
forall a. Maybe a
Nothing HashSet Text
shas
Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CommitOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid r
coid Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== CommitOid s -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid s
cref) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
GitException -> t m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GitException -> t m ()) -> GitException -> t m ()
forall a b. (a -> b) -> a -> b
$ Text -> GitException
BackendError (Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$ Text
"Error copying commit: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CommitOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid r
coid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CommitOid s -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid s
cref
CommitOid s -> t m (CommitOid s)
forall (m :: * -> *) a. Monad m => a -> m a
return CommitOid s
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 :: RepositoryFactory (t m) m s
-> Maybe (CommitOid r) -> Text -> FilePath -> Bool -> m ()
copyRepository RepositoryFactory (t m) m s
factory Maybe (CommitOid r)
mname Text
refName FilePath
gitDir Bool
isBare =
RepositoryFactory (t m) m s -> RepositoryOptions -> t m () -> m ()
forall r (n :: * -> *) (m :: * -> *) a.
(MonadGit r n, MonadUnliftIO n, MonadUnliftIO m) =>
RepositoryFactory n m r -> RepositoryOptions -> n a -> m a
withRepository' RepositoryFactory (t m) m s
factory RepositoryOptions :: FilePath -> Maybe FilePath -> Bool -> Bool -> RepositoryOptions
RepositoryOptions
{ repoPath :: FilePath
repoPath = FilePath
gitDir
, repoWorkingDir :: Maybe FilePath
repoWorkingDir = Maybe FilePath
forall a. Maybe a
Nothing
, repoIsBare :: Bool
repoIsBare = Bool
isBare
, repoAutoCreate :: Bool
repoAutoCreate = Bool
True
}
(t m () -> (CommitOid r -> t m ()) -> Maybe (CommitOid r) -> t m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> t m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CommitOid r -> t m ()
go Maybe (CommitOid r)
mname)
where
go :: CommitOid r -> t m ()
go CommitOid r
coid = do
Tagged (Commit s) (Oid s)
cref <- CommitOid r -> Text -> t m (Tagged (Commit s) (Oid s))
forall r (m :: * -> *) s (t :: (* -> *) -> * -> *).
(MonadGit r m, MonadGit s (t m), MonadTrans t) =>
CommitOid r -> Text -> t m (CommitOid s)
pushCommit CommitOid r
coid Text
refName
Text -> RefTarget s -> t m ()
forall r (m :: * -> *). MonadGit r m => Text -> RefTarget r -> m ()
updateReference Text
refName (Oid s -> RefTarget s
forall r. Oid r -> RefTarget r
RefObj (Tagged (Commit s) (Oid s) -> Oid s
forall k (s :: k) b. Tagged s b -> b
untag Tagged (Commit s) (Oid s)
cref))
Text -> RefTarget s -> t m ()
forall r (m :: * -> *). MonadGit r m => Text -> RefTarget r -> m ()
updateReference Text
"HEAD" (Text -> RefTarget s
forall r. Text -> RefTarget r
RefSymbolic Text
refName)
Maybe Text
mref <- (Oid s -> Text) -> Maybe (Oid s) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Oid s -> Text
forall o. IsOid o => o -> Text
renderOid (Maybe (Oid s) -> Maybe Text)
-> t m (Maybe (Oid s)) -> t m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> t m (Maybe (Oid s))
forall r (m :: * -> *). MonadGit r m => Text -> m (Maybe (Oid r))
resolveReference Text
refName
Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (CommitOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid CommitOid r
coid Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe Text
mref) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
GitException -> t m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Text -> GitException
BackendError (Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$
Text
"Could not resolve destination reference '"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'in project")