gitlib-libgit2 1.2.2 → 1.3.1
raw patch · 3 files changed
+264/−371 lines, 3 filesdep −gitlib-utilsdep ~gitlibdep ~gitlib-libgit2dep ~gitlib-testPVP ok
version bump matches the API change (PVP)
Dependencies removed: gitlib-utils
Dependency ranges changed: gitlib, gitlib-libgit2, gitlib-test, hashable
API changes (from Hackage documentation)
- Git.Libgit2: SHA :: ByteString -> SHA
- Git.Libgit2: instance Binary SHA
- Git.Libgit2: instance Eq SHA
- Git.Libgit2: instance Hashable SHA
- Git.Libgit2: instance Ord SHA
- Git.Libgit2: instance Read SHA
- Git.Libgit2: instance Show SHA
- Git.Libgit2: newtype SHA
- Git.Libgit2: shaToText :: SHA -> Text
- Git.Libgit2: textToSha :: Monad m => Text -> m SHA
+ Git.Libgit2.Types: type TreeBuilder m = TreeBuilder (LgRepository m)
Files
- Git/Libgit2.hs +244/−351
- Git/Libgit2/Types.hs +13/−12
- gitlib-libgit2.cabal +7/−8
Git/Libgit2.hs view
@@ -41,11 +41,8 @@ , lgLoadPackFileInMemory , lgReadFromPack , lgWithPackFile- , SHA(..) , oidToSha , shaToOid- , shaToText- , textToSha , openLgRepository , runLgRepository , strToOid@@ -62,14 +59,9 @@ import Control.Monad.Loops import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource-import qualified Data.Binary as Bin import Data.Bits ((.|.)) import qualified Data.ByteString as B-import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Unsafe as BU-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Hashable import Data.IORef import Data.List as L import Data.Maybe@@ -97,7 +89,6 @@ import qualified Git import Git.Libgit2.Internal import Git.Libgit2.Types-import qualified Git.Utils as Git import Prelude hiding (FilePath) import System.Directory (removeFile) import System.IO (openBinaryTempFile, hClose)@@ -117,19 +108,26 @@ mkOid :: ForeignPtr C'git_oid -> OidPtr mkOid = OidPtr +lgParseOidIO :: Text -> Int -> IO (Maybe Oid)+lgParseOidIO str len = do+ oid <- liftIO $ mallocForeignPtr+ r <- liftIO $ withCString (T.unpack str) $ \cstr ->+ withForeignPtr oid $ \ptr ->+ if len == 40+ then c'git_oid_fromstr ptr cstr+ else c'git_oid_fromstrn ptr cstr (fromIntegral len)+ return $ if r < 0+ then Nothing+ else Just (mkOid oid)+ lgParseOid :: Git.MonadGit m => Text -> LgRepository m Oid lgParseOid str | len > 40 = failure (Git.OidParseFailed str) | otherwise = do- oid <- liftIO $ mallocForeignPtr- r <- liftIO $ withCString (T.unpack str) $ \cstr ->- withForeignPtr oid $ \ptr ->- if len == 40- then c'git_oid_fromstr ptr cstr- else c'git_oid_fromstrn ptr cstr (fromIntegral len)- if r < 0- then failure (Git.OidParseFailed str)- else return (mkOid oid)+ moid <- liftIO $ lgParseOidIO str len+ case moid of+ Nothing -> failure (Git.OidParseFailed str)+ Just oid -> return oid where len = T.length str @@ -154,47 +152,41 @@ instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ -data TreeBuilder m t = TreeBuilder- { lgPendingUpdates :: IORef (HashMap Text (Tree m t))- , lgTreeContents :: ForeignPtr C'git_treebuilder- }- instance Git.MonadGit m => Git.Repository (LgRepository m) where- type Oid (LgRepository m) = OidPtr- type TreeKind (LgRepository m) = Git.MutableTree- type Tree (LgRepository m) = TreeBuilder m-+ type Oid (LgRepository m) = OidPtr+ data Tree (LgRepository m) = LgTree+ { lgTreePtr :: Maybe (ForeignPtr C'git_tree)+ } data Options (LgRepository m) = Options facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True } - parseOid = lgParseOid- lookupRef = lgLookupRef- createRef = lgUpdateRef- updateRef = lgUpdateRef- deleteRef = lgDeleteRef- resolveRef = lgResolveRef- allRefNames = lgAllRefNames- lookupCommit = lgLookupCommit 40- lookupTree = lgLookupTree 40- lookupBlob = lgLookupBlob- lookupTag = undefined- lookupObject = lgLookupObject- existsObject = lgExistsObject- pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname- traverseCommits = lgTraverseCommits- missingObjects = lgMissingObjects- traverseObjects = error "Not defined: LgRepository.traverseObjects"- newTree = lgNewTree- cloneTree = lgCloneTree- traverseEntries = lgTraverseEntries- unsafeUpdateTree = lgModifyTree- writeTree = lgWriteTree- hashContents = lgHashContents- createBlob = lgWrap . lgCreateBlob- createTag = undefined+ parseOid = lgParseOid+ lookupReference = lgLookupRef+ createReference = lgUpdateRef+ updateReference = lgUpdateRef+ deleteReference = lgDeleteRef+ resolveReference = lgResolveRef+ allReferenceNames = lgAllRefNames+ lookupCommit = lgLookupCommit 40+ lookupTree = lgLookupTree 40+ lookupBlob = lgLookupBlob+ lookupTag = undefined+ lookupObject = lgLookupObject+ existsObject = lgExistsObject+ pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname+ traverseCommits = lgTraverseCommits+ missingObjects = lgMissingObjects+ traverseObjects = error "Not defined: LgRepository.traverseObjects"+ newTreeBuilder = lgNewTreeBuilder+ getTreeEntry = lgTreeEntry+ treeOid = lgTreeOid+ traverseEntries = lgTraverseEntries+ hashContents = lgHashContents+ createBlob = lgWrap . lgCreateBlob+ createTag = undefined createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r @@ -254,7 +246,7 @@ lgLookupBlob :: Git.MonadGit m => BlobOid m -> LgRepository m (Git.Blob (LgRepository m)) lgLookupBlob oid =- lookupObject' (getOid (unTagged oid)) 40+ lookupObject' (getOid (untag oid)) 40 c'git_blob_lookup c'git_blob_lookup_prefix $ \_ obj _ -> withForeignPtr obj $ \ptr -> do@@ -269,68 +261,175 @@ type TreeEntry m = Git.TreeEntry (LgRepository m) +lgTreeEntry :: Git.MonadGit m => Tree m -> FilePath+ -> LgRepository m (Maybe (TreeEntry m))+lgTreeEntry (LgTree Nothing) _ = return Nothing+lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr ->+ withFilePath fp $ \pathStr ->+ withForeignPtr tree $ \treePtr -> do+ r <- c'git_tree_entry_bypath entryPtr treePtr pathStr+ if r < 0+ then return Nothing+ else Just <$> (entryToTreeEntry =<< peek entryPtr)++lgTreeOid :: Git.MonadGit m => Tree m -> TreeOid m+lgTreeOid (LgTree Nothing) =+ SU.unsafePerformIO . liftIO $+ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40+lgTreeOid (LgTree (Just tree)) = SU.unsafePerformIO $ liftIO $ do+ toid <- withForeignPtr tree $ c'git_tree_id+ ftoid <- coidPtrToOid toid+ return $ Tagged (mkOid ftoid)+ lgTraverseEntries :: Git.MonadGit m- =>(FilePath -> TreeEntry m -> LgRepository m a)- -> Tree m Git.MutableTree+ => (FilePath -> TreeEntry m -> LgRepository m a)+ -> Tree m -> LgRepository m [a]-lgTraverseEntries f initialTree = go "" initialTree- where- go fp tree = do- entries <- liftIO $ withForeignPtr (lgTreeContents tree) $ \tb -> do- ior <- newIORef []- bracket- (mk'git_treebuilder_filter_cb (callback fp ior))+lgTraverseEntries _ (LgTree Nothing) = return []+lgTraverseEntries f (LgTree (Just tree)) = do+ entries <- liftIO $ withForeignPtr tree $ \tr -> do+ ior <- newIORef []+ r <- bracket+ (mk'git_treewalk_cb (callback ior)) freeHaskellFunPtr- (flip (c'git_treebuilder_filter tb) nullPtr)- readIORef ior- concat <$> mapM (uncurry handler) entries+ (flip (c'git_tree_walk tr c'GIT_TREEWALK_PRE) nullPtr)+ when (r < 0) $ failure Git.TreeWalkFailed+ readIORef ior+ concat <$> mapM (uncurry handler) entries - handler path entry@(Git.TreeEntry tref) = do- x <- f path entry- xs <- Git.resolveTreeRef tref >>= go path- return (x:xs)+ where handler path entry = liftM2 (:) (f path entry) (return []) - callback fp ior te _ = do+ callback ior root te _ = do+ fp <- F.decodeString <$> peekCString root cname <- c'git_tree_entry_name te name <- (fp </>) . F.decodeString <$> peekCString cname entry <- entryToTreeEntry te- modifyIORef ior $- seq name $ seq entry (\xs -> (name,entry):xs)+ seq name $ seq entry $ modifyIORef ior $ \xs -> (name,entry):xs return 0 lgMakeTree :: Git.MonadGit m- => IORef (HashMap Text (Tree m Git.MutableTree))- -> ForeignPtr C'git_treebuilder- -> LgRepository m (Tree m Git.MutableTree)-lgMakeTree contents builder = return $ TreeBuilder contents builder+ => ForeignPtr C'git_treebuilder -> TreeBuilder m+lgMakeTree builder = mempty <> Git.TreeBuilder+ { Git.mtbBaseTreeRef = Nothing+ , Git.mtbPendingUpdates = mempty+ , Git.mtbNewBuilder = lgNewTreeBuilder+ , Git.mtbWriteContents = \tb -> (,) <$> pure (Git.BuilderUnchanged tb)+ <*> lgWriteBuilder builder+ , Git.mtbLookupEntry = lgLookupBuilderEntry builder+ , Git.mtbEntryCount = lgBuilderEntryCount builder+ , Git.mtbPutEntry = \tb name ent ->+ lgPutEntry builder name ent >> return (Git.BuilderUnchanged tb)+ , Git.mtbDropEntry = \tb name ->+ lgDropEntry builder name >> return (Git.BuilderUnchanged tb)+ } -- | Create a new, empty tree. -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op.-lgNewTree :: Git.MonadGit m => LgRepository m (Tree m Git.MutableTree)-lgNewTree = do- -- size <- liftIO $ newIORef 0+lgNewTreeBuilder :: Git.MonadGit m+ => Maybe (Tree m) -> LgRepository m (TreeBuilder m)+lgNewTreeBuilder mtree = do+ mfptr <- liftIO $ alloca $ \pptr -> do+ r <- case mtree of+ Nothing -> c'git_treebuilder_create pptr nullPtr+ Just (LgTree Nothing) ->+ c'git_treebuilder_create pptr nullPtr+ Just (LgTree (Just tree)) ->+ withForeignPtr tree $ \treePtr ->+ c'git_treebuilder_create pptr treePtr+ if r < 0+ then return Nothing+ else do+ builder <- peek pptr+ fptr <- FC.newForeignPtr builder+ (c'git_treebuilder_free builder)+ return $ Just fptr+ case mfptr of+ Nothing ->+ failure (Git.TreeCreateFailed "Failed to create new tree builder")+ Just fptr ->+ return (lgMakeTree fptr)+ { Git.mtbBaseTreeRef = Git.treeRef <$> mtree } - (r,fptr) <- liftIO $ alloca $ \pptr -> do- r <- c'git_treebuilder_create pptr nullPtr- builder <- peek pptr- fptr <- FC.newForeignPtr builder (c'git_treebuilder_free builder)- return (r,fptr)+lgPutEntry :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder -> Text -> TreeEntry m+ -> LgRepository m ()+lgPutEntry builder key (treeEntryToOid -> (oid,mode)) = do+ r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid ->+ withForeignPtr builder $ \ptr ->+ withCString (T.unpack key) $ \name ->+ c'git_treebuilder_insert nullPtr ptr name coid+ (fromIntegral mode)+ when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed key) - if r < 0- then failure (Git.TreeCreateFailed "Failed to create new tree builder")- else do- contents <- liftIO (newIORef HashMap.empty)- lgMakeTree contents fptr+treeEntryToOid :: TreeEntry m -> (Oid, CUInt)+treeEntryToOid (Git.BlobEntry oid kind) =+ (untag oid, case kind of+ Git.PlainBlob -> 0o100644+ Git.ExecutableBlob -> 0o100755+ Git.SymlinkBlob -> 0o120000+ Git.UnknownBlob -> 0o100000)+treeEntryToOid (Git.CommitEntry coid) =+ (untag coid, 0o160000)+treeEntryToOid (Git.TreeEntry toid) =+ (untag toid, 0o040000) -lgCloneTree :: Git.MonadGit m => Tree m Git.MutableTree -> LgRepository m (Tree m Git.MutableTree)-lgCloneTree (TreeBuilder pending contents) =- TreeBuilder <$> liftIO (newIORef =<< readIORef pending)- <*> liftIO (copyBuilder contents)- where- copyBuilder fptr = withForeignPtr fptr $ \builder -> alloca $ \pptr -> do+lgDropEntry :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder -> Text -> LgRepository m ()+lgDropEntry builder key = do+ void $ liftIO $ withForeignPtr builder $ \ptr ->+ withCString (T.unpack key) $ c'git_treebuilder_remove ptr++lgLookupBuilderEntry :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder+ -> Text+ -> LgRepository m (Maybe (TreeEntry m))+lgLookupBuilderEntry builderPtr name = do+ entry <- liftIO $ withForeignPtr builderPtr $ \builder -> do+ withCString (T.unpack name) (c'git_treebuilder_get builder)+ if entry == nullPtr+ then return Nothing+ else Just <$> liftIO (entryToTreeEntry entry)++lgBuilderEntryCount :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder -> LgRepository m Int+lgBuilderEntryCount tb = do+ fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount)++lgTreeEntryCount :: Git.MonadGit m => Tree m -> LgRepository m Int+lgTreeEntryCount (LgTree Nothing) = return 0+lgTreeEntryCount (LgTree (Just tree)) = do+ fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount)++lgWriteBuilder :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder+ -> LgRepository m (TreeRef m)+lgWriteBuilder tb = do+ repo <- lgGet+ (r3,coid) <- liftIO $ do+ coid <- mallocForeignPtr+ withForeignPtr coid $ \coid' ->+ withForeignPtr tb $ \builder ->+ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r3 <- c'git_treebuilder_write coid' repoPtr builder+ return (r3,coid)+ when (r3 < 0) $ do+ errStr <- liftIO $ do+ errPtr <- c'giterr_last+ err <- peek errPtr+ peekCString (c'git_error'message err)+ failure (Git.TreeBuilderWriteFailed $ T.pack $+ "c'git_treebuilder_write failed with " ++ show r3+ ++ ": " ++ errStr)+ return $ Git.ByOid (Tagged (mkOid coid))++lgCloneBuilder :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder+ -> LgRepository m (ForeignPtr C'git_treebuilder)+lgCloneBuilder fptr =+ liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do r <- c'git_treebuilder_create pptr nullPtr when (r < 0) $ failure (Git.BackendError "Could not create new treebuilder")@@ -340,7 +439,7 @@ freeHaskellFunPtr (flip (c'git_treebuilder_filter builder) nullPtr) FC.newForeignPtr builder'(c'git_treebuilder_free builder')-+ where callback builder te _ = do cname <- c'git_tree_entry_name te coid <- c'git_tree_entry_id te@@ -355,29 +454,20 @@ failure (Git.BackendError "Could not insert entry in treebuilder") return 0 -lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m Git.MutableTree) Oid- -> LgRepository m (Tree m Git.MutableTree)-lgLookupTree len oid = do- -- jww (2013-01-28): Verify the oid here- (upds,fptr) <- lookupObject' (getOid (unTagged oid)) len- c'git_tree_lookup c'git_tree_lookup_prefix $- \_coid obj _ ->- withForeignPtr obj $ \objPtr -> do- (r,fptr) <- alloca $ \pptr -> do- r <- c'git_treebuilder_create pptr objPtr- builder <- peek pptr- fptr <- FC.newForeignPtr builder- (c'git_treebuilder_free builder)- return (r,fptr)- if r < 0- then failure (Git.TreeCreateFailed- "Failed to create tree builder")- else do- upds <- liftIO $ newIORef HashMap.empty- return (upds,fptr)- lgMakeTree upds fptr+lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m) Oid+ -> LgRepository m (Tree m)+lgLookupTree len (getOid . untag -> oid) = do+ str <- liftIO $ withForeignPtr oid $ \oidPtr -> oidToStr oidPtr+ if str == T.unpack Git.emptyTreeId+ then return (LgTree Nothing)+ else do+ -- jww (2013-01-28): Verify the oid here+ fptr <- lookupObject' oid len+ c'git_tree_lookup c'git_tree_lookup_prefix $+ \_coid obj _ -> return obj+ return $ LgTree (Just fptr) -entryToTreeEntry :: Git.MonadGit m => Ptr C'git_tree_entry -> IO (TreeEntry m)+entryToTreeEntry :: Ptr C'git_tree_entry -> IO (TreeEntry m) entryToTreeEntry entry = do coid <- c'git_tree_entry_id entry oid <- coidPtrToOid coid@@ -392,197 +482,15 @@ 0o120000 -> Git.SymlinkBlob _ -> Git.UnknownBlob | typ == c'GIT_OBJ_TREE ->- return $ Git.TreeEntry (Git.ByOid (Tagged (mkOid oid)))+ return $ Git.TreeEntry (Tagged (mkOid oid)) | typ == c'GIT_OBJ_COMMIT -> return $ Git.CommitEntry (Tagged (mkOid oid)) | otherwise -> error "Unexpected" --- | Write out a tree to its repository. If it has already been written,--- nothing will happen.-lgWriteTree :: Git.MonadGit m => Tree m Git.MutableTree -> LgRepository m (TreeOid m)-lgWriteTree t = do- -- This is the Oid of every empty tree- emptyTreeOid <- Git.parseOid "4b825dc642cb6eb9a060e54bf8d69288fbee4904"- doWriteTree t- >>= return . Tagged . fromMaybe emptyTreeOid- where- doWriteTree tr = do- repo <- lgGet- let contents = lgTreeContents tr-- upds <- liftIO $ readIORef (lgPendingUpdates tr)- forM_ (HashMap.toList upds) $ \(k,v) -> do- oid <- doWriteTree v- case oid of- Nothing -> dropEntry contents (T.unpack k)- Just oid' -> insertEntry contents (T.unpack k) oid' 0o040000- liftIO $ writeIORef (lgPendingUpdates tr) HashMap.empty-- cnt <- liftIO $ withForeignPtr contents c'git_treebuilder_entrycount- if cnt == 0- then return Nothing- else go contents (repoObj repo)-- go :: Git.MonadGit m- => ForeignPtr C'git_treebuilder- -> ForeignPtr C'git_repository- -> LgRepository m (Maybe Oid)- go fptr repo = do- (r3,coid) <- liftIO $ do- coid <- mallocForeignPtr- withForeignPtr coid $ \coid' ->- withForeignPtr fptr $ \builder ->- withForeignPtr repo $ \repoPtr -> do- r3 <- c'git_treebuilder_write coid' repoPtr builder- return (r3,coid)- when (r3 < 0) $ do- errPtr <- liftIO $ c'giterr_last- err <- liftIO $ peek errPtr- errStr <- liftIO $ peekCString (c'git_error'message err)- failure (Git.TreeBuilderWriteFailed $ T.pack $- "c'git_treebuilder_write failed with " ++ show r3- ++ ": " ++ errStr)- return (Just (mkOid coid))--lgTreeEntryCount :: Git.MonadGit m => Tree m Git.MutableTree -> LgRepository m Int-lgTreeEntryCount t = do- let contents = lgTreeContents t- fromIntegral- <$> liftIO (withForeignPtr contents c'git_treebuilder_entrycount)--insertEntry :: Git.MonadGit m- => ForeignPtr C'git_treebuilder -> String -> Oid -> CUInt- -> LgRepository m ()-insertEntry builder key oid attrs = do- r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid ->- withForeignPtr builder $ \ptr ->- withCString key $ \name ->- c'git_treebuilder_insert nullPtr ptr name coid attrs- when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed (T.pack key))--dropEntry :: Git.MonadGit m- => ForeignPtr C'git_treebuilder -> String -> LgRepository m ()-dropEntry builder key = do- r2 <- liftIO $ withForeignPtr builder $ \ptr ->- withCString key $ \name ->- c'git_treebuilder_remove ptr name- when (r2 < 0) $ failure (Git.TreeBuilderRemoveFailed (T.pack key))--lgModifyTree :: Git.MonadGit m- => Tree m Git.MutableTree -> FilePath -> Bool- -> (Maybe (TreeEntry m) -> Git.ModifyTreeResult (LgRepository m))- -> LgRepository m (Tree m Git.MutableTree, Maybe (TreeEntry m))-lgModifyTree t path createIfNotExist f =- fmap Git.fromModifyTreeResult- <$> doModifyTree t (splitPath path) createIfNotExist- where- -- Lookup the current name in this tree. If it doesn't exist, and there- -- are more names in the path and 'createIfNotExist' is True, create a new- -- Tree and descend into it. Otherwise, if it exists we'll have @Just- -- (TreeEntry {})@, and if not we'll have Nothing.- doModifyTree tr [] _ =- return (tr, Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ tr)- doModifyTree tr (name:names) createIfNotExist = do- y' <- doLookupTreeEntry tr [name]- y <- if isNothing y' && createIfNotExist && not (null names)- then Just . Git.TreeEntry . Git.Known <$> Git.newTree- else return y'- go tr name names y-- -- If there are no further names in the path, call the transformer- -- function, f. It receives a @Maybe TreeEntry@ to indicate if there was- -- a previous entry at this path. It should return a 'Left' value to- -- propagate out a user-defined error, or a @Maybe TreeEntry@ to indicate- -- whether the entry at this path should be deleted or replaced with- -- something new.- --- -- NOTE: There is no provision for leaving the entry unchanged! It is- -- assumed to always be changed, as we have no reliable method of testing- -- object equality that is not O(n).- go tr name [] y = returnTree tr (T.unpack name) (f y)-- go tr _ _ Nothing = return (tr, Git.TreeEntryNotFound)- go _ _ _ (Just Git.BlobEntry {}) = failure Git.TreeCannotTraverseBlob- go _ _ _ (Just Git.CommitEntry {}) = failure Git.TreeCannotTraverseCommit-- -- If there are further names in the path, descend them now. If- -- 'createIfNotExist' was False and there is no 'Tree' under the current- -- name, or if we encountered a 'Blob' when a 'Tree' was required, throw- -- an exception to avoid colliding with user-defined 'Left' values.- go tr name names (Just (Git.TreeEntry st')) = do- st <- Git.resolveTreeRef st'- (st'', ze) <- doModifyTree st names createIfNotExist- case ze of- Git.TreeEntryNotFound -> return ()- Git.TreeEntryPersistent _ -> return ()- Git.TreeEntryDeleted -> postUpdate tr st'' name- Git.TreeEntryMutated _ -> postUpdate tr st'' name- return (tr, ze)-- postUpdate tr st name =- liftIO $ modifyIORef (lgPendingUpdates tr) $- HashMap.insert name st-- returnTree tr n z = do- let contents = lgTreeContents tr- case z of- Git.TreeEntryNotFound -> return ()- Git.TreeEntryPersistent _ -> return ()- Git.TreeEntryDeleted -> dropEntry contents n- Git.TreeEntryMutated z' -> do- (oid,mode) <- treeEntryToOid z'- insertEntry contents n oid mode- return (tr, z)-- treeEntryToOid (Git.BlobEntry oid kind) =- return (unTagged oid,- case kind of- Git.PlainBlob -> 0o100644- Git.ExecutableBlob -> 0o100755- Git.SymlinkBlob -> 0o120000- Git.UnknownBlob -> 0o100000)- treeEntryToOid (Git.CommitEntry coid) =- return (unTagged coid, 0o160000)- treeEntryToOid (Git.TreeEntry tr) = do- oid <- Git.treeRefOid tr- return (unTagged oid, 0o040000)-- -- Lookup the current name in this tree. If it doesn't exist, and there- -- are more names in the path and 'createIfNotExist' is True, create a new- -- Tree and descend into it. Otherwise, if it exists we'll have @Just- -- (TreeEntry {})@, and if not we'll have Nothing.- doLookupTreeEntry tr [] = return (Just (Git.treeEntry tr))- doLookupTreeEntry tr (name:names) = do- upds <- liftIO $ readIORef (lgPendingUpdates tr)- y <- case HashMap.lookup name upds of- Just m -> return . Just . Git.TreeEntry . Git.Known $ m- Nothing ->- liftIO $ withForeignPtr (lgTreeContents tr) $ \builder -> do- entry <- withCString (T.unpack name)- (c'git_treebuilder_get builder)- if entry == nullPtr- then return Nothing- else Just <$> entryToTreeEntry entry- if null names- then return y- else case y of- Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob- Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit- Just (Git.TreeEntry st) -> do- st' <- Git.resolveTreeRef st- doLookupTreeEntry st' names- _ -> return Nothing--splitPath :: FilePath -> [Text]-splitPath path = T.splitOn "/" text- where text = case F.toText path of- Left x -> error $ "Invalid path: " ++ T.unpack x- Right y -> y- lgLookupCommit :: Git.MonadGit m => Int -> CommitOid m -> LgRepository m (Commit m) lgLookupCommit len oid =- lookupObject' (getOid (unTagged oid)) len c'git_commit_lookup+ lookupObject' (getOid (untag oid)) len c'git_commit_lookup c'git_commit_lookup_prefix $ \_ obj _ -> withForeignPtr obj $ \cobj -> do let c = castPtr cobj@@ -690,12 +598,12 @@ case name of Git.CommitObjectId (Tagged coid) -> pushOid (getOid coid) Git.CommitRefName rname -> pushRef (T.unpack rname)- Git.CommitReference ref -> pushRef (T.unpack (Git.refName ref))+ Git.CommitReference ref -> pushRef (T.unpack (Git.referenceName ref)) case moid of Nothing -> return () Just oid ->- withForeignPtr (getOid (unTagged oid)) $ \coid -> do+ withForeignPtr (getOid (untag oid)) $ \coid -> do r2 <- c'git_revwalk_hide walker coid when (r2 < 0) $ failure (Git.BackendError@@ -755,8 +663,8 @@ concat <$> mapM getCommitContents refs where getCommitContents cref = do- c <- lgLookupCommit 40 (Git.commitRefOid cref)- toid <- Git.treeRefOid (Git.commitTree c)+ c <- lgLookupCommit 40 (Git.commitRefOid cref)+ let toid = Git.treeRefOid (Git.commitTree c) return [Git.CommitObj (Git.Known c), Git.TreeObj (Git.ByOid toid)] -- | Write out a commit to its repository. If it has already been written,@@ -771,14 +679,14 @@ -> LgRepository m (Commit m) lgCreateCommit parents tree author committer logText ref = do repo <- lgGet- toid <- getOid . unTagged <$> Git.treeRefOid tree- let pptrs = map Git.commitRefOid parents+ let toid = getOid . untag . Git.treeRefOid $ tree+ pptrs = map Git.commitRefOid parents coid <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do coid <- mallocForeignPtr conv <- U.open "utf-8" (Just True) withForeignPtr coid $ \coid' -> withForeignPtr toid $ \toid' ->- withForeignPtrs (map (getOid . unTagged) pptrs) $ \pptrs' ->+ withForeignPtrs (map (getOid . untag) pptrs) $ \pptrs' -> B.useAsCString (U.fromUnicode conv logText) $ \message -> withRef ref $ \update_ref -> withSignature conv author $ \author' ->@@ -841,8 +749,8 @@ return (Just targ) for targ $ \targ' -> return Git.Reference- { Git.refName = name- , Git.refTarget = targ' }+ { Git.referenceName = name+ , Git.referenceTarget = targ' } lgUpdateRef :: Git.MonadGit m => Text -> Git.RefTarget (LgRepository m) (Commit m)@@ -854,13 +762,13 @@ withCString (T.unpack name) $ \namePtr -> do r <- case refTarg of Git.RefObj (Git.ByOid oid) ->- withForeignPtr (getOid (unTagged oid)) $ \coidPtr ->+ withForeignPtr (getOid (untag oid)) $ \coidPtr -> c'git_reference_create ptr repoPtr namePtr coidPtr (fromBool True) Git.RefObj (Git.Known c) -> withForeignPtr- (getOid (unTagged (Git.commitOid c))) $ \coidPtr ->+ (getOid (untag (Git.commitOid c))) $ \coidPtr -> c'git_reference_create ptr repoPtr namePtr coidPtr (fromBool True) @@ -870,8 +778,8 @@ symPtr (fromBool True) when (r < 0) $ failure Git.ReferenceCreateFailed - return Git.Reference { Git.refName = name- , Git.refTarget = refTarg }+ return Git.Reference { Git.referenceName = name+ , Git.referenceTarget = refTarg } -- int git_reference_name_to_oid(git_oid *out, git_repository *repo, -- const char *name)@@ -1059,12 +967,12 @@ Left coid -> actOnOid (flip (c'git_packbuilder_insert bPtr) nullPtr)- (unTagged coid)+ (untag coid) "c'git_packbuilder_insert failed" Right toid -> actOnOid (c'git_packbuilder_insert_tree bPtr)- (unTagged toid)+ (untag toid) "c'git_packbuilder_insert_tree failed" liftIO $ do@@ -1120,8 +1028,8 @@ debug "Discovering the hash used to identify the pack file" sha <- liftIO $ oidToSha =<< c'git_indexer_stream_hash idxPtr- debug $ "The hash used is: " ++ show (shaToText sha)- return (shaToText sha)+ debug $ "The hash used is: " ++ show (Git.shaToText sha)+ return (Git.shaToText sha) strToOid :: String -> IO (ForeignPtr C'git_oid) strToOid oidStr = do@@ -1132,35 +1040,18 @@ when (r < 0) $ throwIO Git.OidCopyFailed return ptr -newtype SHA = SHA B.ByteString deriving (Eq, Ord, Read, Show)--instance Bin.Binary SHA where- put (SHA t) = Bin.put t- get = SHA <$> Bin.get--instance Hashable SHA where- hashWithSalt salt (SHA bs) = hashWithSalt salt bs--oidToSha :: Ptr C'git_oid -> IO SHA+oidToSha :: Ptr C'git_oid -> IO Git.SHA oidToSha oidPtr =- SHA <$> B.packCStringLen (castPtr oidPtr, sizeOf (undefined :: C'git_oid))+ Git.SHA <$> B.packCStringLen+ (castPtr oidPtr, sizeOf (undefined :: C'git_oid)) -shaToOid :: SHA -> IO (ForeignPtr C'git_oid)-shaToOid (SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do+shaToOid :: Git.SHA -> IO (ForeignPtr C'git_oid)+shaToOid (Git.SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do ptr <- mallocForeignPtr withForeignPtr ptr $ \ptr' -> do c'git_oid_fromraw ptr' (castPtr bytes) return ptr -shaToText :: SHA -> Text-shaToText (SHA bs) = T.decodeUtf8 (B16.encode bs)--textToSha :: Monad m => Text -> m SHA-textToSha t =- case B16.decode $ T.encodeUtf8 t of- (bs, "") -> return (SHA bs)- _ -> fail "Invalid base16 encoding"- lgWritePackFile :: Git.MonadGit m => FilePath -> LgRepository m () lgWritePackFile packFile = do -- jww (2013-04-23): This would be much more efficient (we already have@@ -1263,7 +1154,7 @@ debug "Calling function using in-memory odb" f odbPtr -lgReadFromPack :: FilePath -> SHA -> Bool+lgReadFromPack :: FilePath -> Git.SHA -> Bool -> IO (Maybe (C'git_otype, CSize, B.ByteString)) lgReadFromPack idxPath sha metadataOnly = alloca $ \objectPtrPtr ->@@ -1337,6 +1228,11 @@ , Git.shutdownBackend = shutdownLgBackend } +withFilePath :: FilePath -> (CString -> IO a) -> IO a+withFilePath fp f = case F.toText fp of+ Left _ -> error $ "Could not translate path: " ++ show fp+ Right p -> withCString (T.unpack p) f+ openLgRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository openLgRepository opts = do let path = Git.repoPath opts@@ -1349,15 +1245,12 @@ where openRepositoryWith path fn = do fptr <- alloca $ \ptr ->- case F.toText path of- Left p -> error $ "Could not translate repository path: "- ++ T.unpack p- Right p -> withCString (T.unpack p) $ \str -> do- r <- fn ptr str- when (r < 0) $- error $ "Could not open repository " ++ T.unpack p- ptr' <- peek ptr- newForeignPtr p'git_repository_free ptr'+ withFilePath path $ \str -> do+ r <- fn ptr str+ when (r < 0) $+ error $ "Could not open repository " ++ show path+ ptr' <- peek ptr+ newForeignPtr p'git_repository_free ptr' excTrap <- newIORef Nothing return Repository { repoOptions = opts , repoObj = fptr
Git/Libgit2/Types.hs view
@@ -88,22 +88,23 @@ liftBaseWith = defaultLiftBaseWith StMT restoreM = defaultRestoreM unStMT -type BlobOid m = Git.BlobOid (LgRepository m)-type TreeOid m = Git.TreeOid (LgRepository m)-type CommitOid m = Git.CommitOid (LgRepository m)+type BlobOid m = Git.BlobOid (LgRepository m)+type TreeOid m = Git.TreeOid (LgRepository m)+type CommitOid m = Git.CommitOid (LgRepository m) -type Tree m = Git.Tree (LgRepository m)-type Commit m = Git.Commit (LgRepository m)-type Tag m = Git.Tag (LgRepository m)+type Tree m = Git.Tree (LgRepository m)+type Commit m = Git.Commit (LgRepository m)+type Tag m = Git.Tag (LgRepository m) -type TreeRef m = Git.TreeRef (LgRepository m)-type CommitRef m = Git.CommitRef (LgRepository m)-type CommitName m = Git.CommitName (LgRepository m)+type TreeRef m = Git.TreeRef (LgRepository m)+type CommitRef m = Git.CommitRef (LgRepository m)+type CommitName m = Git.CommitName (LgRepository m) -type Reference m = Git.Reference (LgRepository m) (Commit m)-type Object m = Git.Object (LgRepository m)+type Reference m = Git.Reference (LgRepository m) (Commit m)+type Object m = Git.Object (LgRepository m) -type Options m = Git.Options (LgRepository m)+type TreeBuilder m = Git.TreeBuilder (LgRepository m)+type Options m = Git.Options (LgRepository m) lgGet :: Monad m => LgRepository m Repository lgGet = LgRepository ask
gitlib-libgit2.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-libgit2-Version: 1.2.2+Version: 1.3.1 Synopsis: Libgit2 backend for gitlib License-file: LICENSE License: MIT@@ -9,7 +9,7 @@ Cabal-Version: >=1.10 Category: FFI Description:- Libgit2 (<http://libgit2.github.com>) backend for @gitlib@.+ Libgit2 (<http://libgit2.github.com>) backend for @gitlib@. Source-repository head type: git@@ -23,9 +23,9 @@ Hs-source-dirs: test Build-depends: base >=3- , gitlib >= 1.1.0- , gitlib-test >= 1.1.0- , gitlib-libgit2 >= 1.1.0+ , gitlib >= 1.3.1+ , gitlib-test >= 1.3.1+ , gitlib-libgit2 >= 1.3.1 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3@@ -36,8 +36,7 @@ ghc-options: -Wall build-depends: base >= 3 && < 5- , gitlib >= 1.1.0- , gitlib-utils >= 1.1.0+ , gitlib >= 1.3.1 , hlibgit2 >= 0.18.0.7 , attempt >= 0.4.0 , binary >= 0.5.1.0@@ -48,7 +47,7 @@ , data-default >= 0.5.0 , directory >= 1.1.0.2 , failure >= 0.2.0.1- , hashable >= 1.2.0.5+ , hashable >= 1.1.2.5 , hex >= 0.1.2 , lifted-base >= 0.2.0.2 , missing-foreign >= 0.1.1