diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds @@ -20,7 +21,9 @@ , Commit() , CommitOid() , CommitRef() - , Git.Oid(..) + , Git.Oid + , OidPtr(..) + , mkOid , Reference() , Repository(..) , Tree() @@ -96,68 +99,22 @@ debug :: MonadIO m => String -> m () --debug = liftIO . putStrLn debug = const (return ()) - -instance Git.MonadGit m => Git.Repository (LgRepository m) where - data Oid (LgRepository m) = Oid - { getOid :: ForeignPtr C'git_oid - } - data TreeData (LgRepository m) = TreeData - { lgPendingUpdates :: IORef (HashMap Text (Tree m)) - , lgTreeContents :: ForeignPtr C'git_treebuilder - } - - data Options (LgRepository m) = Options - - facts = return Git.RepositoryFacts - { Git.hasSymbolicReferences = True - } - - parseOid = lgParseOid - renderOid = lgRenderOid - 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 - hashContents = lgHashContents - createBlob = lgWrap . lgCreateBlob - createTag = undefined - - createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r - - deleteRepository = lgGet >>= liftIO . removeTree . repoPath + +type Oid = OidPtr - buildPackFile = lgBuildPackFile - buildPackIndex = lgBuildPackIndexWrapper - writePackFile = lgWrap . lgWritePackFile +data OidPtr = OidPtr { getOid :: ForeignPtr C'git_oid } - remoteFetch = lgRemoteFetch +instance Git.IsOid OidPtr where + renderOid = lgRenderOid -lgWrap :: (MonadIO m, MonadBaseControl IO m) - => LgRepository m a -> LgRepository m a -lgWrap f = f `Exc.catch` \e -> do - etrap <- lgExcTrap - mexc <- liftIO $ readIORef etrap - liftIO $ writeIORef etrap Nothing - maybe (throw (e :: SomeException)) throw mexc +mkOid :: ForeignPtr C'git_oid -> OidPtr +mkOid = OidPtr -lgParseOid :: Git.MonadGit m => Text -> LgRepository m (Oid m) +lgParseOid :: Git.MonadGit m => Text -> LgRepository m Oid lgParseOid str | len > 40 = failure (Git.OidParseFailed str) | otherwise = do - oid <- liftIO mallocForeignPtr + oid <- liftIO $ mallocForeignPtr r <- liftIO $ withCString (T.unpack str) $ \cstr -> withForeignPtr oid $ \ptr -> if len == 40 @@ -165,18 +122,18 @@ else c'git_oid_fromstrn ptr cstr (fromIntegral len) if r < 0 then failure (Git.OidParseFailed str) - else return (Oid oid) + else return (mkOid oid) where len = T.length str lgRenderOid :: Git.Oid (LgRepository m) -> Text lgRenderOid = T.pack . show -instance Show (Git.Oid (LgRepository m)) where - show (Oid coid) = SU.unsafePerformIO $ withForeignPtr coid oidToStr +instance Show OidPtr where + show (getOid -> coid) = SU.unsafePerformIO $ withForeignPtr coid oidToStr -instance Ord (Git.Oid (LgRepository m)) where - Oid coid1 `compare` Oid coid2 = +instance Ord OidPtr where + (getOid -> coid1) `compare` (getOid -> coid2) = SU.unsafePerformIO $ withForeignPtr coid1 $ \coid1Ptr -> withForeignPtr coid2 $ \coid2Ptr -> do @@ -187,9 +144,68 @@ then GT else EQ -instance Eq (Git.Oid (LgRepository m)) where +instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ + +data TreeBuilder m = TreeBuilder + { lgPendingUpdates :: IORef (HashMap Text (Tree m)) + , lgTreeContents :: ForeignPtr C'git_treebuilder + } +instance Git.MonadGit m => Git.Repository (LgRepository m) where + type Oid (LgRepository m) = OidPtr + type Tree (LgRepository m) = TreeBuilder m + + 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 + + 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 + + remoteFetch = lgRemoteFetch + +lgWrap :: (MonadIO m, MonadBaseControl IO m) + => LgRepository m a -> LgRepository m a +lgWrap f = f `Exc.catch` \e -> do + etrap <- lgExcTrap + mexc <- liftIO $ readIORef etrap + liftIO $ writeIORef etrap Nothing + maybe (throw (e :: SomeException)) throw mexc + lgHashContents :: Git.MonadGit m => Git.BlobContents (LgRepository m) -> LgRepository m (BlobOid m) lgHashContents b = do @@ -201,7 +217,7 @@ c'git_odb_hash oidPtr (castPtr cstr) (fromIntegral len) c'GIT_OBJ_BLOB) when (r < 0) $ failure Git.BlobCreateFailed - return (Tagged (Oid ptr)) + return (Tagged (mkOid ptr)) -- | Create a new blob in the 'Repository', with 'ByteString' as its contents. -- @@ -216,7 +232,7 @@ r <- Git.blobContentsToByteString b >>= \bs -> liftIO $ createBlobFromByteString repo ptr bs when (r < 0) $ failure Git.BlobCreateFailed - return (Tagged (Oid ptr)) + return (Tagged (mkOid ptr)) where createBlobFromByteString repo coid bs = @@ -246,43 +262,40 @@ type TreeEntry m = Git.TreeEntry (LgRepository m) lgTraverseEntries :: Git.MonadGit m - => Tree m - -> (FilePath -> TreeEntry m -> LgRepository m a) + =>(FilePath -> TreeEntry m -> LgRepository m a) + -> Tree m -> LgRepository m [a] -lgTraverseEntries initialTree f = go "" initialTree - where - go fp tree = do - entries <- liftIO $ withForeignPtr - (lgTreeContents (Git.getTreeData tree)) $ \tb -> do - ior <- newIORef [] - bracket - (mk'git_treebuilder_filter_cb (callback fp ior)) - freeHaskellFunPtr - (flip (c'git_treebuilder_filter tb) nullPtr) - readIORef ior - concat <$> mapM (uncurry handler) entries +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)) + freeHaskellFunPtr + (flip (c'git_treebuilder_filter tb) nullPtr) + 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) - handler path entry = liftM2 (:) (f path entry) (return []) + handler path entry@(Git.TreeEntry tref) = do + x <- f path entry + xs <- Git.resolveTreeRef tref >>= go path + return (x:xs) + handler path entry = liftM2 (:) (f path entry) (return []) - callback fp ior te _ = do - 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) - return 0 + callback fp ior te _ = do + 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) + return 0 lgMakeTree :: Git.MonadGit m => IORef (HashMap Text (Tree m)) -> ForeignPtr C'git_treebuilder - -> Tree m -lgMakeTree updates contents = - Git.mkTree lgModifyTree lgWriteTree lgTraverseEntries $ - TreeData updates contents + -> LgRepository m (Tree m) +lgMakeTree contents builder = return $ TreeBuilder contents builder -- | Create a new, empty tree. -- @@ -300,10 +313,41 @@ if r < 0 then failure (Git.TreeCreateFailed "Failed to create new tree builder") - else lgMakeTree <$> liftIO (newIORef HashMap.empty) - <*> pure fptr + else do + contents <- liftIO (newIORef HashMap.empty) + lgMakeTree contents fptr -lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m) (Oid m) +lgCloneTree :: Git.MonadGit m => Tree m -> LgRepository m (Tree m) +lgCloneTree (TreeBuilder pending contents) = + TreeBuilder <$> liftIO (newIORef =<< readIORef pending) + <*> liftIO (copyBuilder contents) + where + copyBuilder fptr = withForeignPtr fptr $ \builder -> alloca $ \pptr -> do + r <- c'git_treebuilder_create pptr nullPtr + when (r < 0) $ + failure (Git.BackendError "Could not create new treebuilder") + builder' <- peek pptr + bracket + (mk'git_treebuilder_filter_cb (callback builder')) + freeHaskellFunPtr + (flip (c'git_treebuilder_filter builder) nullPtr) + FC.newForeignPtr builder'(c'git_treebuilder_free builder') + + callback builder te _ = do + cname <- c'git_tree_entry_name te + coid <- c'git_tree_entry_id te + fmode <- c'git_tree_entry_filemode te + r <- c'git_treebuilder_insert + nullPtr + builder + cname + coid + fmode + when (r < 0) $ + failure (Git.BackendError "Could not insert entry in treebuilder") + return 0 + +lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m) Oid -> LgRepository m (Tree m) lgLookupTree len oid = do -- jww (2013-01-28): Verify the oid here @@ -323,7 +367,7 @@ else do upds <- liftIO $ newIORef HashMap.empty return (upds,fptr) - return $ lgMakeTree upds fptr + lgMakeTree upds fptr entryToTreeEntry :: Git.MonadGit m => Ptr C'git_tree_entry -> IO (TreeEntry m) entryToTreeEntry entry = do @@ -333,49 +377,18 @@ case () of () | typ == c'GIT_OBJ_BLOB -> do mode <- c'git_tree_entry_filemode entry - return $ Git.BlobEntry (Tagged (Oid oid)) $ + return $ Git.BlobEntry (Tagged (mkOid oid)) $ case mode of 0o100644 -> Git.PlainBlob 0o100755 -> Git.ExecutableBlob 0o120000 -> Git.SymlinkBlob _ -> Git.UnknownBlob | typ == c'GIT_OBJ_TREE -> - return $ Git.TreeEntry (Git.ByOid (Tagged (Oid oid))) + return $ Git.TreeEntry (Git.ByOid (Tagged (mkOid oid))) | typ == c'GIT_OBJ_COMMIT -> - return $ Git.CommitEntry (Tagged (Oid oid)) + return $ Git.CommitEntry (Tagged (mkOid oid)) | otherwise -> error "Unexpected" -doLookupTreeEntry :: Git.MonadGit m - => Tree m - -> [Text] - -> LgRepository m (Maybe (TreeEntry m)) -doLookupTreeEntry t [] = return (Just (Git.treeEntry t)) -doLookupTreeEntry t (name:names) = do - -- 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. - upds <- liftIO $ readIORef (lgPendingUpdates (Git.getTreeData t)) - y <- case HashMap.lookup name upds of - Just m -> return . Just . Git.TreeEntry . Git.Known $ m - Nothing -> - liftIO $ withForeignPtr - (lgTreeContents (Git.getTreeData t)) $ \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 t') -> do - t'' <- Git.resolveTreeRef t' - doLookupTreeEntry t'' names - _ -> return Nothing - -- | Write out a tree to its repository. If it has already been written, -- nothing will happen. lgWriteTree :: Git.MonadGit m => Tree m -> LgRepository m (TreeOid m) @@ -384,16 +397,53 @@ 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 -> LgRepository m Int lgTreeEntryCount t = do - let tdata = Git.getTreeData t - contents = lgTreeContents tdata + let contents = lgTreeContents t fromIntegral <$> liftIO (withForeignPtr contents c'git_treebuilder_entrycount) insertEntry :: Git.MonadGit m - => ForeignPtr C'git_treebuilder -> String -> Oid m -> CUInt + => ForeignPtr C'git_treebuilder -> String -> Oid -> CUInt -> LgRepository m () insertEntry builder key oid attrs = do r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid -> @@ -410,105 +460,61 @@ c'git_treebuilder_remove ptr name when (r2 < 0) $ failure (Git.TreeBuilderRemoveFailed (T.pack key)) -doWriteTree :: Git.MonadGit m => Tree m -> LgRepository m (Maybe (Oid m)) -doWriteTree t = do - repo <- lgGet - let tdata = Git.getTreeData t - contents = lgTreeContents tdata - - upds <- liftIO $ readIORef (lgPendingUpdates tdata) - 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 tdata) HashMap.empty - - cnt <- liftIO $ withForeignPtr contents c'git_treebuilder_entrycount - if cnt == 0 - then return Nothing - else go contents (repoObj repo) +lgModifyTree :: Git.MonadGit m + => Tree m -> FilePath -> Bool + -> (Maybe (TreeEntry m) -> Git.ModifyTreeResult (LgRepository m)) + -> LgRepository m (Tree m, Maybe (TreeEntry m)) +lgModifyTree t path createIfNotExist f = + fmap Git.fromModifyTreeResult + <$> doModifyTree t (splitPath path) createIfNotExist where - go :: Git.MonadGit m - => ForeignPtr C'git_treebuilder - -> ForeignPtr C'git_repository - -> LgRepository m (Maybe (Oid m)) - 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 (Oid coid)) - -doModifyTree :: Git.MonadGit m - => Tree m - -> [Text] - -> Bool - -> (Maybe (TreeEntry m) - -> LgRepository m (Git.ModifyTreeResult (LgRepository m))) - -> LgRepository m (Git.ModifyTreeResult (LgRepository m)) -doModifyTree t [] _ _ = - return . Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ t -doModifyTree t (name:names) createIfNotExist f = do -- 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. - y' <- doLookupTreeEntry t [name] - y <- if isNothing y' && createIfNotExist && not (null names) - then Just . Git.TreeEntry . Git.Known <$> Git.newTree - else return y' + 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 null names - then do - -- 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). - ze <- f y - returnTree (Git.getTreeData t) (T.unpack name) ze + -- 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) - else - -- 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. - case y of - Nothing -> return Git.TreeEntryNotFound - Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob - Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit - Just (Git.TreeEntry st') -> do - st <- Git.resolveTreeRef st' - ze <- doModifyTree st names createIfNotExist f - case ze of - Git.TreeEntryNotFound -> return ze - Git.TreeEntryPersistent _ -> return ze - Git.TreeEntryDeleted -> postUpdate st ze - Git.TreeEntryMutated _ -> postUpdate st ze - where - postUpdate st ze = do - liftIO $ modifyIORef - (lgPendingUpdates (Git.getTreeData t)) - (HashMap.insert name st) - return ze + 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 @@ -518,7 +524,7 @@ Git.TreeEntryMutated z' -> do (oid,mode) <- treeEntryToOid z' insertEntry contents n oid mode - return z + return (tr, z) treeEntryToOid (Git.BlobEntry oid kind) = return (unTagged oid, @@ -533,15 +539,31 @@ oid <- Git.treeRefOid tr return (unTagged oid, 0o040000) -lgModifyTree - :: Git.MonadGit m - => Tree m -> FilePath -> Bool - -> (Maybe (TreeEntry m) - -> LgRepository m (Git.ModifyTreeResult (LgRepository m))) - -> LgRepository m (Maybe (TreeEntry m)) -lgModifyTree t path createIfNotExist f = - Git.fromModifyTreeResult <$> - doModifyTree t (splitPath path) createIfNotExist f + -- 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 @@ -574,14 +596,15 @@ (replicate (fromIntegral (toInteger pn)) (c'git_commit_parent_id c)) [0..pn] - poids' <- mapM (\x -> Git.ByOid . Tagged . Oid <$> coidPtrToOid x) poids + poids' <- mapM (\x -> Git.ByOid . Tagged . mkOid + <$> coidPtrToOid x) poids return Git.Commit { -- Git.commitInfo = Base (Just (Tagged (Oid coid))) (Just obj) -- , Git.commitOid = oid - , Git.commitTree = Git.ByOid (Tagged (Oid toid')) + , Git.commitTree = Git.ByOid (Tagged (mkOid toid')) , Git.commitParents = poids' , Git.commitAuthor = auth , Git.commitCommitter = comm @@ -616,15 +639,15 @@ go coid _ y = do typ <- liftIO $ c'git_object_type y case () of - () | typ == c'GIT_OBJ_BLOB -> ret Git.BlobObj (Oid coid) - | typ == c'GIT_OBJ_TREE -> ret Git.TreeObj (Oid coid) - | typ == c'GIT_OBJ_COMMIT -> ret Git.CommitObj (Oid coid) - | typ == c'GIT_OBJ_TAG -> ret Git.TagObj (Oid coid) + () | typ == c'GIT_OBJ_BLOB -> ret Git.BlobObj (mkOid coid) + | typ == c'GIT_OBJ_TREE -> ret Git.TreeObj (mkOid coid) + | typ == c'GIT_OBJ_COMMIT -> ret Git.CommitObj (mkOid coid) + | typ == c'GIT_OBJ_TAG -> ret Git.TagObj (mkOid coid) | otherwise -> failure (Git.ObjectLookupFailed str len) ret f = return . f . Git.ByOid . Tagged -lgExistsObject :: Git.MonadGit m => Oid m -> LgRepository m Bool +lgExistsObject :: Git.MonadGit m => Oid -> LgRepository m Bool lgExistsObject oid = do repo <- lgGet result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> @@ -675,7 +698,7 @@ (fromIntegral ((1 :: Int) .|. (4 :: Int))) whileM ((==) <$> pure 0 <*> c'git_revwalk_next coidPtr walker) - (Git.ByOid . Tagged . Oid <$> coidPtrToOid coidPtr) + (Git.ByOid . Tagged . mkOid <$> coidPtrToOid coidPtr) where pushOid oid = withForeignPtr oid $ \coid -> do @@ -765,7 +788,7 @@ { -- Git.commitInfo = Base (Just (Tagged (Oid coid))) Nothing -- , - Git.commitOid = Tagged (Oid coid) + Git.commitOid = Tagged (mkOid coid) , Git.commitTree = tree , Git.commitParents = parents , Git.commitAuthor = author @@ -801,7 +824,7 @@ typ <- c'git_reference_type ref targ <- if typ == c'GIT_REF_OID then do oidPtr <- c'git_reference_target ref - Git.RefObj . Git.ByOid . Tagged . Oid + Git.RefObj . Git.ByOid . Tagged . mkOid <$> coidPtrToOid oidPtr else do targName <- c'git_reference_symbolic_target ref Git.RefSymbolic . T.decodeUtf8 @@ -855,7 +878,7 @@ if r < 0 then return Nothing else Just <$> coidPtrToOid ptr - return (Git.ByOid . Tagged . Oid <$> oid) + return (Git.ByOid . Tagged . mkOid <$> oid) -- int git_reference_rename(git_reference *ref, const char *new_name, -- int force) diff --git a/Git/Libgit2/Types.hs b/Git/Libgit2/Types.hs --- a/Git/Libgit2/Types.hs +++ b/Git/Libgit2/Types.hs @@ -88,8 +88,6 @@ liftBaseWith = defaultLiftBaseWith StMT restoreM = defaultRestoreM unStMT -type Oid m = Git.Oid (LgRepository m) - type BlobOid m = Git.BlobOid (LgRepository m) type TreeOid m = Git.TreeOid (LgRepository m) type CommitOid m = Git.CommitOid (LgRepository m) 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.0.2 +Version: 1.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 - , gitlib-test - , gitlib-libgit2 + , gitlib >= 1.1.0 + , gitlib-test >= 1.1.0 + , gitlib-libgit2 >= 1.1.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3 @@ -36,8 +36,8 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib - , gitlib-utils + , gitlib >= 1.1.0 + , gitlib-utils >= 1.1.0 , hlibgit2 >= 0.18.0.7 , attempt >= 0.4.0 , bytestring >= 0.9.2.1