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

-- | Fast-forward push a reference between repositories using a recursive
--   copy.  This can be extremely slow, but always works no matter which two
--   backends are being used.  It should be considered a matter of last
--   resort, or for objects sets that are known to be small.
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
    -- jww (2013-04-18): This is something the user must decide to do
    -- updateReference_ remoteRefName (RefObj 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
        -- jww (2013-04-24): We don't need do download every object back to
        -- the first commit, but only the commits (and their objects) back to
        -- and including the common ancestor.  The question is, how do we
        -- determine the common ancestor before we've fetched all the contents
        -- of at least one side?
        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

        -- This will always be a fast-forward, since temp.git is empty.  The
        -- resulting HEAD will have the refname as the ref we want to push to
        -- or pull from, and no others.
        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")