diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -36,8 +36,11 @@ , lgGet , lgExcTrap , lgLoadPackFileInMemory + , lgBuildPackFile , lgReadFromPack , lgWithPackFile + , lgWritePackFile + , lgWrap , oidToSha , shaToOid , openLgRepository @@ -54,11 +57,13 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Loops +import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Bits ((.|.)) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU +import Data.Conduit import Data.IORef import Data.List as L import Data.Maybe @@ -83,7 +88,6 @@ import Foreign.Ptr import Foreign.Storable import qualified Git -import qualified Git.Commit.Push as Git import Git.Libgit2.Internal import Git.Libgit2.Types import Prelude hiding (FilePath) @@ -93,8 +97,8 @@ import Unsafe.Coerce debug :: MonadIO m => String -> m () ---debug = liftIO . putStrLn -debug = const (return ()) +debug = liftIO . putStrLn +--debug = const (return ()) type Oid = OidPtr @@ -161,36 +165,35 @@ parseOid = lgParseOid - lookupReference = lgLookupRef - createReference = lgUpdateRef - updateReference = lgUpdateRef - deleteReference = lgDeleteRef - listReferences = lgListRefs - lookupCommit = lgLookupCommit 40 - lookupTree = lgLookupTree 40 - lookupBlob = lgLookupBlob - lookupTag = error "Not implemented: LgRepository.lookupTag" - lookupObject = lgLookupObject - existsObject = lgExistsObject - pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname - listObjects = lgListObjects - newTreeBuilder = lgNewTreeBuilder - treeEntry = lgTreeEntry - treeOid = lgTreeOid - listTreeEntries = lgListTreeEntries - hashContents = lgHashContents - createBlob = lgWrap . lgCreateBlob - createTag = error "Not implemented: LgRepository.createTag" + lookupReference = lgLookupRef + createReference = lgUpdateRef + updateReference = lgUpdateRef + deleteReference = lgDeleteRef + listReferences = lgListRefs + lookupCommit = lgLookupCommit 40 + lookupTree = lgLookupTree 40 + lookupBlob = lgLookupBlob + lookupTag = error "Not implemented: LgRepository.lookupTag" + lookupObject = lgLookupObject + existsObject = lgExistsObject + sourceObjects = lgSourceObjects + newTreeBuilder = lgNewTreeBuilder + treeEntry = lgTreeEntry + treeOid = lgTreeOid + listTreeEntries = lgListTreeEntries + hashContents = lgHashContents + createBlob = lgWrap . lgCreateBlob + createTag = error "Not implemented: LgRepository.createTag" createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r deleteRepository = lgGet >>= liftIO . removeTree . repoPath - buildPackFile = lgBuildPackFile - buildPackIndex = lgBuildPackIndexWrapper - writePackFile = lgWrap . lgWritePackFile + -- buildPackFile = lgBuildPackFile + -- buildPackIndex = lgBuildPackIndexWrapper + -- writePackFile = lgWrap . lgWritePackFile - remoteFetch = lgRemoteFetch + -- remoteFetch = lgRemoteFetch lgWrap :: (MonadIO m, MonadBaseControl IO m) => LgRepository m a -> LgRepository m a @@ -224,7 +227,8 @@ repo <- lgGet ptr <- liftIO mallocForeignPtr r <- Git.blobContentsToByteString b - >>= \bs -> liftIO $ createBlobFromByteString repo ptr bs + >>= \bs -> liftIO $ evaluate + =<< createBlobFromByteString repo ptr bs when (r < 0) $ failure Git.BlobCreateFailed return (Tagged (mkOid ptr)) @@ -433,7 +437,7 @@ (mk'git_treebuilder_filter_cb (callback builder')) freeHaskellFunPtr (flip (c'git_treebuilder_filter builder) nullPtr) - FC.newForeignPtr builder'(c'git_treebuilder_free builder') + FC.newForeignPtr builder' (c'git_treebuilder_free builder') where callback builder te _ = do cname <- c'git_tree_entry_name te @@ -606,56 +610,47 @@ freeHaskellFunPtr (flip (c'git_odb_foreach odbPtr) payload) -lgListObjects :: Git.MonadGit m - => Maybe (CommitOid m) -> CommitOid m -> Bool - -> LgRepository m [ObjectOid m] -lgListObjects mhave need alsoTrees = do - repo <- lgGet - refs <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> - alloca $ \pptr -> - Exc.bracket - (do r <- c'git_revwalk_new pptr repoPtr - when (r < 0) $ - failure (Git.BackendError "Could not create revwalker") - peek pptr) - c'git_revwalk_free - (lgRevWalker need mhave) - concat <$> mapM getCommitContents refs - where - getCommitContents cref - | alsoTrees = do - c <- lgLookupCommit 40 cref - return [Git.CommitObjOid cref, Git.TreeObjOid (Git.commitTree c)] - | otherwise = return [Git.CommitObjOid cref] +lgSourceObjects + :: Git.MonadGit m + => Maybe (CommitOid m) -> CommitOid m -> Bool + -> Source (LgRepository m) (ObjectOid m) +lgSourceObjects mhave need alsoTrees = do + repo <- lift $ lgGet + walker <- liftIO $ alloca $ \pptr -> do + r <- withForeignPtr (repoObj repo) $ \repoPtr -> + c'git_revwalk_new pptr repoPtr + when (r < 0) $ + failure (Git.BackendError "Could not create revwalker") + ptr <- peek pptr + newForeignPtr p'git_revwalk_free ptr - lgRevWalker coid moid walker = do - pushOid (getOid (untag coid)) - case moid of - Nothing -> return () - Just oid -> - withForeignPtr (getOid (untag oid)) $ \coid -> do - r2 <- c'git_revwalk_hide walker coid - when (r2 < 0) $ - failure (Git.BackendError - "Could not hide commit on revwalker") - alloca $ \coidPtr -> do - c'git_revwalk_sorting walker - (fromIntegral ((1 :: Int) .|. (4 :: Int))) - whileM ((==) <$> pure 0 - <*> c'git_revwalk_next coidPtr walker) - (Tagged . mkOid <$> coidPtrToOid coidPtr) - where - pushOid oid = - withForeignPtr oid $ \coid -> do - r2 <- c'git_revwalk_push walker coid - when (r2 < 0) $ - failure (Git.BackendError "Could not push oid on revwalker") + liftIO $ withForeignPtr (getOid (untag need)) $ \coid -> do + r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid + when (r2 < 0) $ + failure (Git.BackendError "Could not push oid on revwalker") - pushRef refName = - withCString refName $ \namePtr -> do - r2 <- c'git_revwalk_push_ref walker namePtr - when (r2 < 0) $ - failure (Git.BackendError "Could not push ref on revwalker") + case mhave of + Nothing -> return () + Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do + r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid + when (r2 < 0) $ + failure (Git.BackendError "Could not hide commit on revwalker") + + liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting + (fromIntegral ((1 :: Int) .|. (4 :: Int))) + + coidPtr <- liftIO mallocForeignPtr + whileM_ ((==) <$> pure 0 + <*> liftIO (withForeignPtr walker $ \walker' -> + withForeignPtr coidPtr $ \coidPtr' -> + c'git_revwalk_next coidPtr' walker')) $ do + oidPtr <- liftIO $ withForeignPtr coidPtr coidPtrToOid + do + let coid = Tagged (mkOid oidPtr) + yield $ Git.CommitObjOid coid + when alsoTrees $ do + c <- lift $ lgLookupCommit 40 coid + yield $ Git.TreeObjOid (Git.commitTree c) -- | Write out a commit to its repository. If it has already been written, -- nothing will happen. diff --git a/gitlib-libgit2.cabal b/gitlib-libgit2.cabal --- a/gitlib-libgit2.cabal +++ b/gitlib-libgit2.cabal @@ -1,5 +1,5 @@ Name: gitlib-libgit2 -Version: 2.0.0.0 +Version: 2.0.1.0 Synopsis: Libgit2 backend for gitlib License-file: LICENSE License: MIT @@ -23,9 +23,9 @@ Hs-source-dirs: test Build-depends: base >=3 - , gitlib >= 2.0.0.0 + , gitlib >= 2.0.1.0 , gitlib-test >= 2.0.0.0 - , gitlib-libgit2 >= 2.0.0.0 + , gitlib-libgit2 >= 2.0.1.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3 @@ -36,7 +36,7 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib >= 2.0.0.0 + , gitlib >= 2.0.1.0 , hlibgit2 >= 0.18.0.7 , attempt >= 0.4.0 , binary >= 0.5.1.0