diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -5,6 +5,7 @@ import Git.Blob as X import Git.Commit as X +import Git.Commit.Push as X import Git.Object as X import Git.Reference as X import Git.Repository as X diff --git a/Git/Blob.hs b/Git/Blob.hs --- a/Git/Blob.hs +++ b/Git/Blob.hs @@ -1,5 +1,6 @@ module Git.Blob where +import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Data.ByteString as B @@ -24,12 +25,10 @@ blobContentsToByteString :: Repository m => BlobContents m -> m ByteString blobContentsToByteString (BlobString bs) = return bs -blobContentsToByteString (BlobStream bs) = do - strs <- bs $$ CList.consume - return (B.concat strs) -blobContentsToByteString (BlobSizedStream bs _) = do - strs <- bs $$ CList.consume - return (B.concat strs) +blobContentsToByteString (BlobStream bs) = + B.concat <$> (bs $$ CList.consume) +blobContentsToByteString (BlobSizedStream bs _) = + B.concat <$> (bs $$ CList.consume) blobToByteString :: Repository m => Blob m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents diff --git a/Git/Commit.hs b/Git/Commit.hs --- a/Git/Commit.hs +++ b/Git/Commit.hs @@ -2,6 +2,8 @@ import Control.Monad import Control.Monad.Trans.Class +import Data.Conduit +import qualified Data.Conduit.List as CL import Data.Function import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet @@ -59,8 +61,10 @@ => Maybe (CommitOid m) -- ^ A commit we may already have -> CommitOid m -- ^ The commit we need -> m [CommitOid m] -- ^ All the objects in between -listCommits have need = - mapM (\(CommitObjOid c) -> return c) =<< listObjects have need False +listCommits mhave need = + sourceObjects mhave need False + $= CL.mapM (\(CommitObjOid c) -> return c) + $$ CL.consume traverseCommits :: Repository m => (CommitOid m -> m a) -> CommitOid m -> m [a] traverseCommits f need = mapM f =<< listCommits Nothing need diff --git a/Git/Commit/Push.hs b/Git/Commit/Push.hs --- a/Git/Commit/Push.hs +++ b/Git/Commit/Push.hs @@ -19,9 +19,9 @@ -- 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. -genericPushCommit :: (Repository m, Repository (t m), MonadTrans t) - => CommitOid m -> Text -> t m (CommitOid (t m)) -genericPushCommit coid remoteRefName = do +pushCommit :: (Repository m, Repository (t m), MonadTrans t) + => CommitOid m -> Text -> t m (CommitOid (t m)) +pushCommit coid remoteRefName = do mrref <- resolveReference remoteRefName commits1 <- mapM copyCommitOid =<< lift (listCommits Nothing coid) fastForward <- case mrref of diff --git a/Git/Object.hs b/Git/Object.hs --- a/Git/Object.hs +++ b/Git/Object.hs @@ -1,12 +1,22 @@ module Git.Object where -import Control.Monad -import Data.Function -import Data.List -import Data.Maybe -import Git.Types -import Prelude hiding (FilePath) +import Control.Monad +import Control.Monad.Trans.Class +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Function +import Data.Maybe +import Git.Types +import Prelude hiding (FilePath) +listObjects :: Repository m + => Maybe (CommitOid m) -- ^ A commit we may already have + -> CommitOid m -- ^ The commit we need + -> Bool -- ^ Include commit trees also? + -> m [ObjectOid m] -- ^ All the objects in between +listObjects mhave need alsoTrees = + sourceObjects mhave need alsoTrees $$ CL.consume + traverseObjects :: Repository m => (ObjectOid m -> m a) -> CommitOid m -> m [a] traverseObjects f need = mapM f =<< listObjects Nothing need False @@ -16,21 +26,25 @@ -- | Given a list of objects (commit and top-level trees) return by -- 'listObjects', expand it to include all subtrees and blobs as well. -- Ordering is preserved. -expandTreeObjects :: Repository m => [ObjectOid m] -> m [ObjectOid m] -expandTreeObjects objs = - fmap concat . forM objs $ \obj -> case obj of - TreeObjOid toid -> do - tr <- lookupTree toid - entries <- listTreeEntries tr - let subobjss = foldr f [] entries - return (obj:subobjss) - _ -> return [obj] +expandTreeObjects :: Repository m => Conduit (ObjectOid m) m (ObjectOid m) +expandTreeObjects = whileJust_ await $ \obj -> case obj of + TreeObjOid toid -> do + yield $ TreeObjOid toid + tr <- lift $ lookupTree toid + ents <- lift $ listTreeEntries tr + forM_ ents $ \ent -> case ent of + (_, BlobEntry oid _) -> yield $ BlobObjOid oid + (_, TreeEntry oid) -> yield $ TreeObjOid oid + _ -> return () + _ -> yield obj where - f (_, ent) rest = case ent of - BlobEntry oid _ -> BlobObjOid oid : rest - TreeEntry oid -> TreeObjOid oid : rest - _ -> rest + whileJust_ p f = do + x <- p + case x of + Nothing -> return () + Just x' -> f x' >> whileJust_ p f listAllObjects :: Repository m => Maybe (CommitOid m) -> CommitOid m -> m [ObjectOid m] -listAllObjects have need = expandTreeObjects =<< listObjects have need True +listAllObjects mhave need = + sourceObjects mhave need True $= expandTreeObjects $$ CL.consume diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,7 +5,6 @@ import Control.Failure import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class import qualified Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -55,16 +54,16 @@ listReferences :: m [Text] -- Object lookup - lookupCommit :: CommitOid m -> m (Commit m) - lookupTree :: TreeOid m -> m (Tree m) - lookupBlob :: BlobOid m -> m (Blob m) - lookupTag :: TagOid m -> m (Tag m) - lookupObject :: Oid m -> m (Object m) - existsObject :: Oid m -> m Bool - listObjects :: Maybe (CommitOid m) -- ^ A commit we may already have - -> CommitOid m -- ^ The commit we need - -> Bool -- ^ Include commit trees also? - -> m [ObjectOid m] -- ^ All the objects in between + lookupCommit :: CommitOid m -> m (Commit m) + lookupTree :: TreeOid m -> m (Tree m) + lookupBlob :: BlobOid m -> m (Blob m) + lookupTag :: TagOid m -> m (Tag m) + lookupObject :: Oid m -> m (Object m) + existsObject :: Oid m -> m Bool + sourceObjects :: Maybe (CommitOid m) -- ^ A commit we may already have + -> CommitOid m -- ^ The commit we need + -> Bool -- ^ Include commit trees also? + -> Source m (ObjectOid m) -- ^ All the objects in between -- Working with trees newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m) @@ -80,27 +79,22 @@ -> Signature -> Signature -> Text -> Maybe Text -> m (Commit m) createTag :: CommitOid m -> Signature -> Text -> Text -> m (Tag m) - -- Pushing and pulling - pushCommit :: (MonadTrans t, MonadGit m, MonadGit (t m), - Repository m, Repository (t m)) - => CommitOid m -> Maybe Text -> Text -> t m (CommitOid (t m)) - - -- Pack files - buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] - -> m FilePath - buildPackFile _ _ = - failure (BackendError "Backend does not support building pack files") + -- -- Pack files + -- buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] + -- -> m FilePath + -- buildPackFile _ _ = + -- failure (BackendError "Backend does not support building pack files") - buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) - buildPackIndex _ _ = - failure (BackendError "Backend does not support building pack indexes") + -- buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) + -- buildPackIndex _ _ = + -- failure (BackendError "Backend does not support building pack indexes") - writePackFile :: FilePath -> m () - writePackFile _ = - failure (BackendError "Backend does not support writing pack files") + -- writePackFile :: FilePath -> m () + -- writePackFile _ = + -- failure (BackendError "Backend does not support writing pack files") - -- Git remotes - remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () + -- -- Git remotes + -- remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () data RepositoryOptions = RepositoryOptions { repoPath :: !FilePath diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -1,5 +1,5 @@ Name: gitlib -Version: 2.0.0.0 +Version: 2.0.1.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT