diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -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 diff --git a/Git/Libgit2/Types.hs b/Git/Libgit2/Types.hs --- a/Git/Libgit2/Types.hs +++ b/Git/Libgit2/Types.hs @@ -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 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: 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 () backend for @gitlib@. + Libgit2 () 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