gitlib-libgit2 (empty) → 1.0.1
raw patch · 9 files changed
+1977/−0 lines, 9 filesdep +HUnitdep +attemptdep +basesetup-changed
Dependencies added: HUnit, attempt, base, bytestring, conduit, containers, data-default, directory, failure, gitlib, gitlib-libgit2, gitlib-test, gitlib-utils, hex, hlibgit2, hspec, hspec-expectations, lifted-base, missing-foreign, monad-control, monad-loops, parallel-io, pointless-fun, resourcet, system-fileio, system-filepath, tagged, temporary, text, text-icu, time, transformers, transformers-base, unordered-containers
Files
- Git/Libgit2.hs +1327/−0
- Git/Libgit2/Backend.hs +85/−0
- Git/Libgit2/Internal.hs +179/−0
- Git/Libgit2/Trace.hs +152/−0
- Git/Libgit2/Types.hs +116/−0
- LICENSE +19/−0
- Setup.hs +2/−0
- gitlib-libgit2.cabal +72/−0
- test/Smoke.hs +25/−0
+ Git/Libgit2.hs view
@@ -0,0 +1,1327 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing+ -fno-warn-unused-binds+ -fno-warn-orphans #-}++-- | Interface for opening and creating repositories. Repository objects are+-- immutable, and serve only to refer to the given repository. Any data+-- associated with the repository — such as the list of branches — is+-- queried as needed.+module Git.Libgit2+ ( LgRepository(..)+ , BlobOid()+ , Commit()+ , CommitOid()+ , CommitRef()+ , Git.Oid(..)+ , Reference()+ , Repository(..)+ , Tree()+ , TreeOid()+ , TreeRef()+ , addTracingBackend+ , checkResult+ , closeLgRepository+ , defaultLgOptions+ , lgBuildPackIndex+ , lgFactory+ , lgForEachObject+ , lgGet+ , lgExcTrap+ , lgLoadPackFileInMemory+ , lgReadFromPack+ , lgWithPackFile+ , oidToSha+ , openLgRepository+ , runLgRepository+ , strToOid+ , withLibGitDo+ ) where++import Bindings.Libgit2+import Control.Applicative+import Control.Exception+import qualified Control.Exception.Lifted as Exc+import Control.Failure+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Loops+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.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.IORef+import Data.List as L+import Data.Maybe+import Data.Monoid+import Data.Tagged+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.ICU.Convert as U+import Data.Traversable (for)+import Filesystem hiding (removeFile)+import Filesystem.Path.CurrentOS (FilePath, (</>))+import qualified Filesystem.Path.CurrentOS as F+import Foreign.C.String+import Foreign.C.Types+import qualified Foreign.Concurrent as FC+import Foreign.ForeignPtr+import qualified Foreign.ForeignPtr.Unsafe as FU+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.MissingAlloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+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)+import qualified System.IO.Unsafe as SU++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++ 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++lgParseOid :: Git.MonadGit m => Text -> LgRepository m (Oid m)+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 (Oid 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 Ord (Git.Oid (LgRepository m)) where+ Oid coid1 `compare` Oid coid2 =+ SU.unsafePerformIO $+ withForeignPtr coid1 $ \coid1Ptr ->+ withForeignPtr coid2 $ \coid2Ptr -> do+ r <- c'git_oid_cmp coid1Ptr coid2Ptr+ return $ if r < 0+ then LT+ else if r > 0+ then GT+ else EQ++instance Eq (Git.Oid (LgRepository m)) where+ oid1 == oid2 = oid1 `compare` oid2 == EQ++lgHashContents :: Git.MonadGit m => Git.BlobContents (LgRepository m)+ -> LgRepository m (BlobOid m)+lgHashContents b = do+ ptr <- liftIO mallocForeignPtr+ r <- Git.blobContentsToByteString b >>= \bs ->+ liftIO $ withForeignPtr ptr $ \oidPtr ->+ BU.unsafeUseAsCStringLen bs $+ uncurry (\cstr len ->+ c'git_odb_hash oidPtr (castPtr cstr)+ (fromIntegral len) c'GIT_OBJ_BLOB)+ when (r < 0) $ failure Git.BlobCreateFailed+ return (Tagged (Oid ptr))++-- | Create a new blob in the 'Repository', with 'ByteString' as its contents.+--+-- Note that since empty blobs cannot exist in Git, no means is provided for+-- creating one; if the given string is 'empty', it is an error.+lgCreateBlob :: Git.MonadGit m+ => Git.BlobContents (LgRepository m)+ -> LgRepository m (BlobOid m)+lgCreateBlob b = do+ repo <- lgGet+ ptr <- liftIO mallocForeignPtr+ r <- Git.blobContentsToByteString b+ >>= \bs -> liftIO $ createBlobFromByteString repo ptr bs+ when (r < 0) $ failure Git.BlobCreateFailed+ return (Tagged (Oid ptr))++ where+ createBlobFromByteString repo coid bs =+ BU.unsafeUseAsCStringLen bs $+ uncurry (\cstr len ->+ withForeignPtr coid $ \coid' ->+ withForeignPtr (repoObj repo) $ \repoPtr ->+ c'git_blob_create_frombuffer+ coid' repoPtr (castPtr cstr) (fromIntegral len))++lgLookupBlob :: Git.MonadGit m => BlobOid m+ -> LgRepository m (Git.Blob (LgRepository m))+lgLookupBlob oid =+ lookupObject' (getOid (unTagged oid)) 40+ c'git_blob_lookup c'git_blob_lookup_prefix+ $ \_ obj _ ->+ withForeignPtr obj $ \ptr -> do+ size <- c'git_blob_rawsize (castPtr ptr)+ buf <- c'git_blob_rawcontent (castPtr ptr)+ -- The lifetime of buf is tied to the lifetime of the blob object+ -- in libgit2, which this Blob object controls, so we can use+ -- unsafePackCStringLen to refer to its bytes.+ bstr <- curry BU.unsafePackCStringLen (castPtr buf)+ (fromIntegral size)+ return (Git.Blob oid (Git.BlobString bstr))++type TreeEntry m = Git.TreeEntry (LgRepository m)++lgTraverseEntries :: Git.MonadGit m+ => Tree m+ -> (FilePath -> TreeEntry m -> LgRepository m a)+ -> 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++ 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++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++-- | 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)+lgNewTree = do+ -- size <- liftIO $ newIORef 0++ (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)++ if r < 0+ then failure (Git.TreeCreateFailed "Failed to create new tree builder")+ else lgMakeTree <$> liftIO (newIORef HashMap.empty)+ <*> pure fptr++lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m) (Oid m)+ -> LgRepository m (Tree m)+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)+ return $ lgMakeTree upds fptr++entryToTreeEntry :: Git.MonadGit m => Ptr C'git_tree_entry -> IO (TreeEntry m)+entryToTreeEntry entry = do+ coid <- c'git_tree_entry_id entry+ oid <- coidPtrToOid coid+ typ <- c'git_tree_entry_type entry+ case () of+ () | typ == c'GIT_OBJ_BLOB ->+ do mode <- c'git_tree_entry_filemode entry+ return $ Git.BlobEntry (Tagged (Oid 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)))+ | typ == c'GIT_OBJ_COMMIT ->+ return $ Git.CommitEntry (Tagged (Oid 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)+lgWriteTree t = do+ -- This is the Oid of every empty tree+ emptyTreeOid <- Git.parseOid "4b825dc642cb6eb9a060e54bf8d69288fbee4904"+ doWriteTree t+ >>= return . Tagged . fromMaybe emptyTreeOid++lgTreeEntryCount :: Git.MonadGit m => Tree m -> LgRepository m Int+lgTreeEntryCount t = do+ let tdata = Git.getTreeData t+ contents = lgTreeContents tdata+ fromIntegral+ <$> liftIO (withForeignPtr contents c'git_treebuilder_entrycount)++insertEntry :: Git.MonadGit m+ => ForeignPtr C'git_treebuilder -> String -> Oid m -> 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))++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)+ 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'++ 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++ 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++ 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 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)++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++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+ c'git_commit_lookup_prefix $ \_ obj _ ->+ withForeignPtr obj $ \cobj -> do+ let c = castPtr cobj++ enc <- c'git_commit_message_encoding c+ encs <- if enc == nullPtr+ then return "UTF-8"+ else peekCString enc+ conv <- U.open encs (Just False)++ msg <- c'git_commit_message c >>= B.packCString+ auth <- c'git_commit_author c >>= packSignature conv+ comm <- c'git_commit_committer c >>= packSignature conv+ toid <- c'git_commit_tree_id c+ toid' <- coidPtrToOid toid++ pn <- c'git_commit_parentcount c+ poids <- zipWithM ($)+ (replicate (fromIntegral (toInteger pn))+ (c'git_commit_parent_id c))+ [0..pn]+ poids' <- mapM (\x -> Git.ByOid . Tagged . Oid <$> 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.commitParents = poids'+ , Git.commitAuthor = auth+ , Git.commitCommitter = comm+ , Git.commitLog = U.toUnicode conv msg+ , Git.commitEncoding = "utf-8"+ }++lgLookupObject :: Git.MonadGit m => Text+ -> LgRepository m (Git.Object (LgRepository m))+lgLookupObject str+ | len > 40 = failure (Git.ObjectLookupFailed str len)+ | otherwise = do+ fptr <- liftIO $ do+ fptr <- mallocForeignPtr+ withForeignPtr fptr $ \ptr ->+ withCString (T.unpack str) $ \cstr -> do+ r <- 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 fptr++ case fptr of+ Nothing -> failure (Git.ObjectLookupFailed str len)+ Just x' ->+ lookupObject' x' len+ (\x y z -> c'git_object_lookup x y z c'GIT_OBJ_ANY)+ (\x y z l ->+ c'git_object_lookup_prefix x y z l c'GIT_OBJ_ANY) go+ where+ len = T.length str++ 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)+ | otherwise -> failure (Git.ObjectLookupFailed str len)++ ret f = return . f . Git.ByOid . Tagged++lgExistsObject :: Git.MonadGit m => Oid m -> LgRepository m Bool+lgExistsObject oid = do+ repo <- lgGet+ result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->+ alloca $ \pptr -> do+ r0 <- c'git_repository_odb pptr repoPtr+ if r0 < 0+ then return Nothing+ else+ -- jww (2013-02-28): Need to guard against exceptions so that+ -- ptr doesn't leak.+ withForeignPtr (getOid oid) $ \coid -> do+ ptr <- peek pptr+ r <- c'git_odb_exists ptr coid 0+ c'git_odb_free ptr+ return (Just (r == 0))+ maybe (failure Git.RepositoryInvalid) return result++lgForEachObject :: Ptr C'git_odb+ -> (Ptr C'git_oid -> Ptr () -> IO CInt)+ -> Ptr ()+ -> IO CInt+lgForEachObject odbPtr f payload =+ bracket+ (mk'git_odb_foreach_cb f)+ freeHaskellFunPtr+ (flip (c'git_odb_foreach odbPtr) payload)++lgRevWalker :: Git.MonadGit m+ => CommitName m -> Maybe (CommitOid m) -> Ptr C'git_revwalk+ -> IO [CommitRef m]+lgRevWalker name moid walker = do+ 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))++ case moid of+ Nothing -> return ()+ Just oid ->+ withForeignPtr (getOid (unTagged 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)+ (Git.ByOid . Tagged . Oid <$> 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")++ 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")++lgTraverseCommits :: Git.MonadGit m+ => (CommitRef m -> LgRepository m a)+ -> CommitName m+ -> LgRepository m [a]+lgTraverseCommits f name = 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 name Nothing)+ mapM f refs++lgMissingObjects :: Git.MonadGit m+ => Maybe (CommitName m) -> CommitName m+ -> LgRepository m [Object m]+lgMissingObjects mhave need = do+ repo <- lgGet+ mref <- maybe (return Nothing) Git.commitNameToRef mhave+ 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 (Git.commitRefOid <$> mref))+ concat <$> mapM getCommitContents refs+ where+ getCommitContents cref = do+ c <- lgLookupCommit 40 (Git.commitRefOid cref)+ 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,+-- nothing will happen.+lgCreateCommit :: Git.MonadGit m+ => [CommitRef m]+ -> TreeRef m+ -> Git.Signature+ -> Git.Signature+ -> Text+ -> Maybe Text+ -> 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+ 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' ->+ B.useAsCString (U.fromUnicode conv logText) $ \message ->+ withRef ref $ \update_ref ->+ withSignature conv author $ \author' ->+ withSignature conv committer $ \committer' ->+ withEncStr "utf-8" $ \_ {-message_encoding-} -> do+ parents' <- newArray pptrs'+ r <- c'git_commit_create_oid coid' repoPtr+ update_ref author' committer'+ nullPtr message toid'+ (fromIntegral (L.length parents)) parents'+ when (r < 0) $ throwIO Git.CommitCreateFailed+ return coid++ return Git.Commit+ {+ -- Git.commitInfo = Base (Just (Tagged (Oid coid))) Nothing+ -- ,+ Git.commitOid = Tagged (Oid coid)+ , Git.commitTree = tree+ , Git.commitParents = parents+ , Git.commitAuthor = author+ , Git.commitCommitter = committer+ , Git.commitLog = logText+ , Git.commitEncoding = "utf-8"+ }++ where+ withRef Nothing = flip ($) nullPtr+ withRef (Just name) = B.useAsCString (T.encodeUtf8 name)++ withEncStr "" = flip ($) nullPtr+ withEncStr enc = withCString enc++withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b+withForeignPtrs fos io = do+ r <- io (map FU.unsafeForeignPtrToPtr fos)+ mapM_ touchForeignPtr fos+ return r++lgLookupRef :: Git.MonadGit m => Text -> LgRepository m (Maybe (Reference m))+lgLookupRef name = do+ repo <- lgGet+ targ <- liftIO $ alloca $ \ptr -> do+ r <- withForeignPtr (repoObj repo) $ \repoPtr ->+ withCString (T.unpack name) $ \namePtr ->+ c'git_reference_lookup ptr repoPtr namePtr+ if r < 0+ then return Nothing+ else do+ ref <- peek ptr+ 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+ <$> coidPtrToOid oidPtr+ else do targName <- c'git_reference_symbolic_target ref+ Git.RefSymbolic . T.decodeUtf8+ <$> B.packCString targName+ c'git_reference_free ref+ return (Just targ)+ for targ $ \targ' ->+ return Git.Reference+ { Git.refName = name+ , Git.refTarget = targ' }++lgUpdateRef :: Git.MonadGit m+ => Text -> Git.RefTarget (LgRepository m) (Commit m)+ -> LgRepository m (Reference m)+lgUpdateRef name refTarg = do+ repo <- lgGet+ liftIO $ alloca $ \ptr ->+ withForeignPtr (repoObj repo) $ \repoPtr ->+ withCString (T.unpack name) $ \namePtr -> do+ r <- case refTarg of+ Git.RefObj (Git.ByOid oid) ->+ withForeignPtr (getOid (unTagged oid)) $ \coidPtr ->+ c'git_reference_create ptr repoPtr namePtr+ coidPtr (fromBool True)++ Git.RefObj (Git.Known c) ->+ withForeignPtr+ (getOid (unTagged (Git.commitOid c))) $ \coidPtr ->+ c'git_reference_create ptr repoPtr namePtr+ coidPtr (fromBool True)++ Git.RefSymbolic symName ->+ withCString (T.unpack symName) $ \symPtr ->+ c'git_reference_symbolic_create ptr repoPtr namePtr+ symPtr (fromBool True)+ when (r < 0) $ failure Git.ReferenceCreateFailed++ return Git.Reference { Git.refName = name+ , Git.refTarget = refTarg }++-- int git_reference_name_to_oid(git_oid *out, git_repository *repo,+-- const char *name)++lgResolveRef :: Git.MonadGit m => Text -> LgRepository m (Maybe (CommitRef m))+lgResolveRef name = do+ repo <- lgGet+ oid <- liftIO $ alloca $ \ptr ->+ withCString (T.unpack name) $ \namePtr ->+ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r <- c'git_reference_name_to_id ptr repoPtr namePtr+ if r < 0+ then return Nothing+ else Just <$> coidPtrToOid ptr+ return (Git.ByOid . Tagged . Oid <$> oid)++-- int git_reference_rename(git_reference *ref, const char *new_name,+-- int force)++--renameRef = c'git_reference_rename++lgDeleteRef :: Git.MonadGit m => Text -> LgRepository m ()+lgDeleteRef name = do+ repo <- lgGet+ r <- liftIO $ alloca $ \ptr ->+ withCString (T.unpack name) $ \namePtr ->+ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r <- c'git_reference_lookup ptr repoPtr namePtr+ if r < 0+ then return r+ else do+ ref <- peek ptr+ c'git_reference_delete ref+ when (r < 0) $ failure (Git.ReferenceDeleteFailed name)++-- int git_reference_packall(git_repository *repo)++--packallRefs = c'git_reference_packall++data ListFlags = ListFlags { listFlagInvalid :: Bool+ , listFlagOid :: Bool+ , listFlagSymbolic :: Bool+ , listFlagPacked :: Bool+ , listFlagHasPeel :: Bool }+ deriving (Show, Eq)++allRefsFlag :: ListFlags+allRefsFlag = ListFlags { listFlagInvalid = False+ , listFlagOid = True+ , listFlagSymbolic = True+ , listFlagPacked = True+ , listFlagHasPeel = False }++-- symbolicRefsFlag :: ListFlags+-- symbolicRefsFlag = ListFlags { listFlagInvalid = False+-- , listFlagOid = False+-- , listFlagSymbolic = True+-- , listFlagPacked = False+-- , listFlagHasPeel = False }++-- oidRefsFlag :: ListFlags+-- oidRefsFlag = ListFlags { listFlagInvalid = False+-- , listFlagOid = True+-- , listFlagSymbolic = False+-- , listFlagPacked = True+-- , listFlagHasPeel = False }++-- looseOidRefsFlag :: ListFlags+-- looseOidRefsFlag = ListFlags { listFlagInvalid = False+-- , listFlagOid = True+-- , listFlagSymbolic = False+-- , listFlagPacked = False+-- , listFlagHasPeel = False }++gitStrArray2List :: Ptr C'git_strarray -> IO [Text]+gitStrArray2List gitStrs = do+ count <- fromIntegral <$> peek (p'git_strarray'count gitStrs)+ strings <- peek $ p'git_strarray'strings gitStrs++ r0 <- Foreign.Marshal.Array.peekArray count strings+ r1 <- sequence $ fmap peekCString r0+ return $ fmap T.pack r1++flagsToInt :: ListFlags -> CUInt+flagsToInt flags = (if listFlagOid flags then 1 else 0)+ + (if listFlagSymbolic flags then 2 else 0)+ + (if listFlagPacked flags then 4 else 0)+ + (if listFlagHasPeel flags then 8 else 0)++listRefNames :: Git.MonadGit m+ => ListFlags -> LgRepository m [Text]+listRefNames flags = do+ repo <- lgGet+ refs <- liftIO $ alloca $ \c'refs ->+ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r <- c'git_reference_list c'refs repoPtr (flagsToInt flags)+ if r < 0+ then return Nothing+ else do refs <- gitStrArray2List c'refs+ c'git_strarray_free c'refs+ return (Just refs)+ maybe (failure Git.ReferenceListingFailed) return refs++lgAllRefNames :: Git.MonadGit m+ => LgRepository m [Text]+lgAllRefNames = listRefNames allRefsFlag++-- foreachRefCallback :: CString -> Ptr () -> IO CInt+-- foreachRefCallback name payload = do+-- (callback,results) <- deRefStablePtr =<< peek (castPtr payload)+-- nameStr <- peekCString name+-- result <- callback (T.pack nameStr)+-- modifyIORef results (\xs -> result:xs)+-- return 0++-- foreign export ccall "foreachRefCallback"+-- foreachRefCallback :: CString -> Ptr () -> IO CInt+-- foreign import ccall "&foreachRefCallback"+-- foreachRefCallbackPtr :: FunPtr (CString -> Ptr () -> IO CInt)++-- lgMapRefs :: (Text -> LgRepository a) -> LgRepository [a]+-- lgMapRefs cb = do+-- repo <- lgGet+-- liftIO $ do+-- withForeignPtr (repoObj repo) $ \repoPtr -> do+-- ioRef <- newIORef []+-- bracket+-- (newStablePtr (cb,ioRef))+-- freeStablePtr+-- (\ptr -> with ptr $ \pptr -> do+-- _ <- c'git_reference_foreach+-- repoPtr (flagsToInt allRefsFlag)+-- foreachRefCallbackPtr (castPtr pptr)+-- readIORef ioRef)++-- mapAllRefs :: (Text -> LgRepository a) -> LgRepository [a]+-- mapAllRefs repo = mapRefs repo allRefsFlag+-- mapOidRefs :: (Text -> LgRepository a) -> LgRepository [a]+-- mapOidRefs repo = mapRefs repo oidRefsFlag+-- mapLooseOidRefs :: (Text -> LgRepository a) -> LgRepository [a]+-- mapLooseOidRefs repo = mapRefs repo looseOidRefsFlag+-- mapSymbolicRefs :: (Text -> LgRepository a) -> LgRepository [a]+-- mapSymbolicRefs repo = mapRefs repo symbolicRefsFlag++-- int git_reference_is_packed(git_reference *ref)++--refIsPacked = c'git_reference_is_packed++-- int git_reference_reload(git_reference *ref)++--reloadRef = c'git_reference_reload++-- int git_reference_cmp(git_reference *ref1, git_reference *ref2)++--compareRef = c'git_reference_cmp++checkResult :: (Eq a, Num a, Failure Git.GitException m) => a -> Text -> m ()+checkResult r why = when (r /= 0) $ failure (Git.BackendError why)++lgBuildPackFile :: Git.MonadGit m+ => FilePath -> [Either (CommitOid m) (TreeOid m)]+ -> LgRepository m FilePath+lgBuildPackFile dir oids = do+ repo <- lgGet+ liftIO $ do+ (filePath, fHandle) <- openBinaryTempFile (pathStr dir) "pack"+ hClose fHandle+ go repo filePath+ return . F.fromText . T.pack $ filePath+ where+ go repo path = runResourceT $ do+ delKey <- register $ removeFile path++ (_,bPtrPtr) <- allocate malloc free+ (_,bPtr) <- flip allocate c'git_packbuilder_free $+ liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r <- c'git_packbuilder_new bPtrPtr repoPtr+ checkResult r "c'git_packbuilder_new failed"+ peek bPtrPtr++ forM_ oids $ \oid -> case oid of+ -- jww (2013-04-24): When libgit2 0.19 comes out, we will only+ -- need to call c'git_packbuilder_insert_commit here, as it will+ -- insert both the commit and its tree.+ Left coid ->+ actOnOid+ (flip (c'git_packbuilder_insert bPtr) nullPtr)+ (unTagged coid)+ "c'git_packbuilder_insert failed"+ Right toid ->+ actOnOid+ (c'git_packbuilder_insert_tree bPtr)+ (unTagged toid)+ "c'git_packbuilder_insert_tree failed"++ liftIO $ do+ r1 <- c'git_packbuilder_set_threads bPtr 0+ checkResult r1 "c'git_packbuilder_set_threads failed"++ withCString path $ \cstr -> do+ r2 <- c'git_packbuilder_write bPtr cstr+ checkResult r2 "c'git_packbuilder_write failed"++ void $ unprotect delKey++ actOnOid f oid msg =+ liftIO $ withForeignPtr (getOid oid) $ \oidPtr -> do+ r <- f oidPtr+ checkResult r msg++lgBuildPackIndexWrapper :: Git.MonadGit m+ => FilePath+ -> B.ByteString+ -> LgRepository m (Text, FilePath, FilePath)+lgBuildPackIndexWrapper = (liftIO .) . lgBuildPackIndex++lgBuildPackIndex :: FilePath -> B.ByteString+ -> IO (Text, FilePath, FilePath)+lgBuildPackIndex dir bytes = do+ sha <- go dir bytes+ (,,) <$> pure sha+ <*> pure (dir </> F.fromText ("pack-" <> sha <> ".pack"))+ <*> pure (dir </> F.fromText ("pack-" <> sha <> ".idx"))+ where+ go dir bytes = alloca $ \idxPtrPtr -> runResourceT $ do+ debug "Allocate a new indexer stream"+ (_,idxPtr) <- flip allocate c'git_indexer_stream_free $+ withCString (pathStr dir) $ \dirStr -> do+ r <- c'git_indexer_stream_new idxPtrPtr dirStr+ nullFunPtr nullPtr+ checkResult r "c'git_indexer_stream_new failed"+ peek idxPtrPtr++ debug $ "Add the incoming packfile data to the stream ("+ ++ show (B.length bytes) ++ " bytes)"+ (_,statsPtr) <- allocate calloc free+ liftIO $ BU.unsafeUseAsCStringLen bytes $+ uncurry $ \dataPtr dataLen -> do+ r <- c'git_indexer_stream_add idxPtr (castPtr dataPtr)+ (fromIntegral dataLen) statsPtr+ checkResult r "c'git_indexer_stream_add failed"++ debug "Finalizing the stream"+ r <- liftIO $ c'git_indexer_stream_finalize idxPtr statsPtr+ checkResult r "c'git_indexer_stream_finalize failed"++ 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 sha+ return sha++strToOid :: String -> IO (ForeignPtr C'git_oid)+strToOid oidStr = do+ ptr <- mallocForeignPtr+ withCString oidStr $ \cstr ->+ withForeignPtr ptr $ \ptr' -> do+ r <- c'git_oid_fromstr ptr' cstr+ when (r < 0) $ throwIO Git.OidCopyFailed+ return ptr++oidToSha :: Ptr C'git_oid -> IO Text+oidToSha oidPtr = allocaBytes 42 $ \oidStr ->+ T.decodeUtf8 <$> (B.packCString =<< c'git_oid_tostr oidStr 41 oidPtr)++lgWritePackFile :: Git.MonadGit m => FilePath -> LgRepository m ()+lgWritePackFile packFile = do+ -- jww (2013-04-23): This would be much more efficient (we already have+ -- the pack file on disk, why not just copy it?), but we have no way at+ -- present of communicating with the S3 backend directly.+ -- S3.uploadPackAndIndex undefined (F.directory packFile) packSha++ -- Use the ODB backend interface to transfer the pack file, which+ -- inefficiently transfers the pack file as a strict ByteString in memory,+ -- only to be written to disk again on the other side. However, since+ -- this algorithm knows nothing about S3 or the S3 backend, this is our+ -- only way of talking to that backend.+ --+ -- The abstract API does have a writePackFile method, but we can't use it+ -- yet because it only calls into the Libgit2 backend, which doesn't know+ -- anything about the S3 backend. As far as Libgit2 is concerned, the S3+ -- backend is just a black box with no special properties.+ repo <- lgGet+ liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->+ alloca $ \odbPtrPtr ->+ alloca $ \statsPtr ->+ alloca $ \writepackPtrPtr ->+ runResourceT $ go repoPtr odbPtrPtr writepackPtrPtr statsPtr+ where+ go repoPtr odbPtrPtr writepackPtrPtr statsPtr = do+ debug "Obtaining odb for repository"+ (_,odbPtr) <- flip allocate c'git_odb_free $ do+ r <- c'git_repository_odb odbPtrPtr repoPtr+ checkResult r "c'git_repository_odb failed"+ peek odbPtrPtr++ debug "Opening pack writer into odb"+ (_,writepackPtr) <- allocate+ (do r <- c'git_odb_write_pack writepackPtrPtr odbPtr+ nullFunPtr nullPtr+ checkResult r "c'git_odb_write_pack failed"+ peek writepackPtrPtr)+ (\writepackPtr -> do+ writepack <- peek writepackPtr+ mK'git_odb_writepack_free_callback+ (c'git_odb_writepack'free writepack) writepackPtr)+ writepack <- liftIO $ peek writepackPtr++ bs <- liftIO $ B.readFile (pathStr packFile)+ debug $ "Writing pack file " ++ show packFile ++ " into odb"+ debug $ "Writing " ++ show (B.length bs) ++ " pack bytes into odb"+ liftIO $ BU.unsafeUseAsCStringLen bs $+ uncurry $ \dataPtr dataLen -> do+ r <- mK'git_odb_writepack_add_callback+ (c'git_odb_writepack'add writepack)+ writepackPtr (castPtr dataPtr)+ (fromIntegral dataLen) statsPtr+ checkResult r "c'git_odb_writepack'add failed"++ debug "Committing pack into odb"+ r <- liftIO $ mK'git_odb_writepack_commit_callback+ (c'git_odb_writepack'commit writepack) writepackPtr+ statsPtr+ checkResult r "c'git_odb_writepack'commit failed"++lgLoadPackFileInMemory :: FilePath+ -> Ptr (Ptr C'git_odb_backend)+ -> Ptr (Ptr C'git_odb)+ -> ResourceT IO (Ptr C'git_odb)+lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr = do+ debug "Creating temporary, in-memory object database"+ (freeKey,odbPtr) <- flip allocate c'git_odb_free $ do+ r <- c'git_odb_new odbPtrPtr+ checkResult r "c'git_odb_new failed"+ peek odbPtrPtr++ debug $ "Load pack index " ++ show idxPath ++ " into temporary odb"+ (_,backendPtr) <- allocate+ (do r <- withCString (pathStr idxPath) $ \idxPathStr ->+ c'git_odb_backend_one_pack backendPtrPtr idxPathStr+ checkResult r "c'git_odb_backend_one_pack failed"+ peek backendPtrPtr)+ (\backendPtr -> do+ backend <- peek backendPtr+ mK'git_odb_backend_free_callback+ (c'git_odb_backend'free backend) backendPtr)++ -- Since freeing the backend will now free the object database, unregister+ -- the finalizer we had setup for the odbPtr+ void $ unprotect freeKey++ -- Associate the new backend containing our single index file with the+ -- in-memory object database+ debug "Associate odb with backend"+ r <- liftIO $ c'git_odb_add_backend odbPtr backendPtr 1+ checkResult r "c'git_odb_add_backend failed"++ return odbPtr++lgWithPackFile :: FilePath -> (Ptr C'git_odb -> ResourceT IO a) -> IO a+lgWithPackFile idxPath f = alloca $ \odbPtrPtr ->+ alloca $ \backendPtrPtr -> runResourceT $ do+ debug "Load pack file into an in-memory object database"+ odbPtr <- lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr+ debug "Calling function using in-memory odb"+ f odbPtr++lgReadFromPack :: FilePath -> Text -> Bool+ -> IO (Maybe (C'git_otype, CSize, B.ByteString))+lgReadFromPack idxPath sha metadataOnly =+ alloca $ \objectPtrPtr ->+ lgWithPackFile idxPath $ \odbPtr -> do+ foid <- liftIO $ strToOid (T.unpack sha)+ if metadataOnly+ then liftIO $ alloca $ \sizePtr -> alloca $ \typPtr -> do+ r <- withForeignPtr foid $+ c'git_odb_read_header sizePtr typPtr odbPtr+ if r == 0+ then Just <$> ((,,) <$> peek typPtr+ <*> peek sizePtr+ <*> pure B.empty)+ else do+ unless (r == c'GIT_ENOTFOUND) $+ checkResult r "c'git_odb_read_header failed"+ return Nothing+ else do+ r <- liftIO $ withForeignPtr foid $+ c'git_odb_read objectPtrPtr odbPtr+ mr <- if r == 0+ then do+ objectPtr <- liftIO $ peek objectPtrPtr+ void $ register $ c'git_odb_object_free objectPtr+ return $ Just objectPtr+ else do+ unless (r == c'GIT_ENOTFOUND) $+ checkResult r "c'git_odb_read failed"+ return Nothing+ case mr of+ Just objectPtr -> liftIO $ do+ typ <- c'git_odb_object_type objectPtr+ len <- c'git_odb_object_size objectPtr+ ptr <- c'git_odb_object_data objectPtr+ bytes <- curry B.packCStringLen (castPtr ptr)+ (fromIntegral len)+ return $ Just (typ,len,bytes)+ Nothing -> return Nothing++lgRemoteFetch :: Git.MonadGit m => Text -> Text -> LgRepository m ()+lgRemoteFetch uri fetchSpec = do+ xferRepo <- lgGet+ liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr ->+ withCString (T.unpack uri) $ \uriStr ->+ withCString (T.unpack fetchSpec) $ \fetchStr ->+ alloca $ runResourceT . go repoPtr uriStr fetchStr+ where+ go repoPtr uriStr fetchStr remotePtrPtr = do+ (_,remotePtr) <- flip allocate c'git_remote_free $ do+ r <- c'git_remote_create_inmemory remotePtrPtr repoPtr+ fetchStr uriStr+ checkResult r "c'git_remote_create_inmemory failed"+ peek remotePtrPtr++ r1 <- liftIO $ c'git_remote_connect remotePtr c'GIT_DIRECTION_FETCH+ checkResult r1 "c'git_remote_connect failed"+ void $ register $ c'git_remote_disconnect remotePtr++ r2 <- liftIO $ c'git_remote_download remotePtr nullFunPtr nullPtr+ checkResult r2 "c'git_remote_download failed"++lgFactory :: Git.MonadGit m+ => Git.RepositoryFactory LgRepository m Repository+lgFactory = Git.RepositoryFactory+ { Git.openRepository = openLgRepository+ , Git.runRepository = runLgRepository+ , Git.closeRepository = closeLgRepository+ , Git.getRepository = lgGet+ , Git.defaultOptions = defaultLgOptions+ , Git.startupBackend = startupLgBackend+ , Git.shutdownBackend = shutdownLgBackend+ }++openLgRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository+openLgRepository opts = do+ let path = Git.repoPath opts+ p <- liftIO $ isDirectory path+ liftIO $ openRepositoryWith path $+ if not (Git.repoAutoCreate opts) || p+ then c'git_repository_open+ else \x y -> c'git_repository_init x y+ (fromBool (Git.repoIsBare opts))+ 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'+ excTrap <- newIORef Nothing+ return Repository { repoOptions = opts+ , repoObj = fptr+ , repoExcTrap = excTrap+ }++runLgRepository :: Repository -> LgRepository m a -> m a+runLgRepository repo action =+ runReaderT (lgRepositoryReaderT action) repo++closeLgRepository :: Git.MonadGit m => Repository -> m ()+closeLgRepository = const (return ())++defaultLgOptions :: Git.RepositoryOptions+defaultLgOptions = Git.RepositoryOptions "" False False++startupLgBackend :: MonadIO m => m ()+startupLgBackend = liftIO (void c'git_threads_init)++shutdownLgBackend :: MonadIO m => m ()+shutdownLgBackend = liftIO c'git_threads_shutdown++-- Libgit2.hs
+ Git/Libgit2/Backend.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Git.Libgit2.Backend+ ( odbBackendAdd++ , F'git_odb_backend_read_callback+ , F'git_odb_backend_read_prefix_callback+ , F'git_odb_backend_readstream_callback+ , F'git_odb_backend_read_header_callback+ , F'git_odb_backend_write_callback+ , F'git_odb_backend_writestream_callback+ , F'git_odb_backend_exists_callback+ , F'git_odb_backend_refresh_callback+ , F'git_odb_backend_foreach_callback+ , F'git_odb_backend_writepack_callback+ , F'git_odb_backend_free_callback++ , F'git_odb_writepack_add_callback+ , F'git_odb_writepack_commit_callback+ , F'git_odb_writepack_free_callback+ )+ where++import Bindings.Libgit2+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Git.Libgit2.Types++type F'git_odb_backend_read_callback =+ Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend+ -> Ptr C'git_oid -> IO CInt+type F'git_odb_backend_read_prefix_callback =+ Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype+ -> Ptr C'git_odb_backend -> Ptr C'git_oid -> CSize -> IO CInt+type F'git_odb_backend_readstream_callback =+ Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> Ptr C'git_oid+ -> IO CInt+type F'git_odb_backend_read_header_callback =+ Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid+ -> IO CInt+type F'git_odb_backend_write_callback =+ Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr () -> CSize -> C'git_otype+ -> IO CInt+type F'git_odb_backend_writestream_callback =+ Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> CSize+ -> C'git_otype -> IO CInt+type F'git_odb_backend_exists_callback =+ Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> IO CInt+type F'git_odb_backend_refresh_callback = Ptr C'git_odb_backend -> IO CInt+type F'git_odb_backend_foreach_callback =+ Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr () -> IO CInt+type F'git_odb_backend_writepack_callback =+ Ptr (Ptr C'git_odb_writepack) -> Ptr C'git_odb_backend+ -> C'git_transfer_progress_callback -> Ptr () -> IO CInt+type F'git_odb_backend_free_callback = Ptr C'git_odb_backend -> IO ()++type F'git_odb_writepack_add_callback =+ Ptr C'git_odb_writepack -> Ptr () -> CSize -> Ptr C'git_transfer_progress+ -> IO CInt+type F'git_odb_writepack_commit_callback =+ Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress -> IO CInt+type F'git_odb_writepack_free_callback = Ptr C'git_odb_writepack -> IO ()+++odbBackendAdd :: Repository -> Ptr C'git_odb_backend -> Int+ -> IO (Either String Repository)+odbBackendAdd repo backend priority =+ withForeignPtr (repoObj repo) $ \repoPtr ->+ alloca $ \odbPtr -> do+ r <- c'git_repository_odb odbPtr repoPtr+ if r < 0+ then return (Left "Cannot get repository ODB")+ else do+ odb <- peek odbPtr+ r2 <- c'git_odb_add_backend odb backend (fromIntegral priority)+ if r2 < 0+ then return (Left "Cannot add backend to repository ODB")+ else return (Right repo)++-- Backend.hs
+ Git/Libgit2/Internal.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Git.Libgit2.Internal (module Git.Libgit2.Internal, oidToStr) where++import Bindings.Libgit2+import Control.Applicative+import Control.Failure+import Control.Monad+import Control.Monad.IO.Class+import Data.ByteString+import Data.Tagged+import qualified Data.Text as T+import qualified Data.Text.ICU.Convert as U+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import Filesystem.Path.CurrentOS ((</>))+import qualified Filesystem.Path.CurrentOS as F+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import qualified Git+import Git.Libgit2.Backend+import Git.Libgit2.Trace+import Git.Libgit2.Types+import Prelude hiding (FilePath)++type ObjPtr a = Maybe (ForeignPtr a)++data Base m a b = Base+ { gitId :: Maybe (Tagged a (Git.Oid (LgRepository m)))+ , gitObj :: ObjPtr b+ }++addTracingBackend :: Git.MonadGit m => LgRepository m ()+addTracingBackend = do+ repo <- lgGet+ case F.toText (repoPath repo </> "objects") of+ Left p -> error $ "Object directory does not exist: " ++ T.unpack p+ Right p ->+ liftIO $ withCString (T.unpack p) $ \objectsDir ->+ alloca $ \loosePtr -> do+ r <- c'git_odb_backend_loose loosePtr objectsDir (-1) 0+ when (r < 0) $+ error "Failed to create loose objects backend"++ loosePtr' <- peek loosePtr+ backend <- traceBackend loosePtr'+ void $ odbBackendAdd repo backend 3+ return ()++coidPtrToOid :: Ptr C'git_oid -> IO (ForeignPtr C'git_oid)+coidPtrToOid coidptr = do+ fptr <- mallocForeignPtr+ withForeignPtr fptr $ \ptr ->+ c'git_oid_cpy ptr coidptr+ return fptr++lookupObject'+ :: Git.MonadGit m+ => ForeignPtr C'git_oid -> Int+ -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> IO CInt)+ -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> CSize -> IO CInt)+ -> (ForeignPtr C'git_oid -> ForeignPtr a -> Ptr a -> IO b)+ -> LgRepository m b+lookupObject' oid len lookupFn lookupPrefixFn createFn = do+ repo <- lgGet+ result <- liftIO $ alloca $ \ptr -> do+ r <- withForeignPtr (repoObj repo) $ \repoPtr ->+ withForeignPtr oid $ \oidPtr ->+ if len == 40+ then lookupFn ptr repoPtr oidPtr+ else lookupPrefixFn ptr repoPtr oidPtr (fromIntegral len)+ if r < 0+ then do+ err <- c'giterr_last+ errmsg <- peekCString . c'git_error'message =<< peek err+ oidStr <- withForeignPtr oid oidToStr+ return $ Left $+ T.concat [ "Could not lookup ", T.pack oidStr+ , ": ", T.pack errmsg ]+ else do+ ptr' <- peek ptr+ coid <- c'git_object_id (castPtr ptr')+ coidCopy <- mallocForeignPtr+ withForeignPtr coidCopy $ flip c'git_oid_cpy coid++ fptr <- newForeignPtr p'git_object_free (castPtr ptr')+ Right <$> createFn coidCopy (castForeignPtr fptr) ptr'+ either (failure . Git.BackendError) return result++-- lgLookupObject :: Text -> LgRepository Dynamic+-- lgLookupObject str+-- | len > 40 = failure (Git.ObjectLookupFailed str)+-- | otherwise = do+-- fptr <- liftIO $ do+-- fptr <- mallocForeignPtr+-- withForeignPtr fptr $ \ptr ->+-- withCString str $ \cstr -> do+-- r <- c'git_oid_fromstrn ptr cstr (fromIntegral len)+-- return $ if r < 0+-- then Nothing+-- else Just fptr+-- case fptr of+-- Nothing -> failure (Git.ObjectLookupFailed str)+-- Just x ->+-- lookupObject' (coidToOid x) len+-- (\x y z -> c'git_object_lookup x y z c'GIT_OBJ_ANY)+-- (\x y z l ->+-- c'git_object_lookup_prefix x y z l c'GIT_OBJ_ANY)+-- (\coid x y ->+-- c'git_object_type y >>= createObject coid x)+-- where+-- len = T.length str++-- createObject :: COid -> ForeignPtr C'git_object -> C'git_otype -> IO Dynamic+-- createObject coid obj typ+-- | typ == c'GIT_OBJ_BLOB = undefined+-- -- return $ toDyn Git.Blob { Git.blobContents = Git.BlobString "" }++-- | typ == c'GIT_OBJ_TREE = undefined+-- -- return $ toDyn Git.Tree { treeInfo =+-- -- newBase repo (Stored coid) (Just obj)+-- -- , treeContents = M.empty }++-- | otherwise = return undefined++-- -- | Convert a time in seconds (from Stripe's servers) to 'UTCTime'. See+-- -- "Data.Time.Format" for more on working with 'UTCTime'.+-- fromSeconds :: Integer -> ZonedTime+-- fromSeconds = posixSecondsToUTCTime . fromInteger++-- -- | Convert a 'UTCTime' back to an Integer suitable for use with Stripe's API.+-- toSeconds :: ZonedTime -> Integer+-- toSeconds = round . utcTimeToPOSIXSeconds++peekGitTime :: Ptr C'git_time -> IO ZonedTime+peekGitTime tptr = do+ moment <- peek tptr+ return (utcToZonedTime+ (minutesToTimeZone (fromIntegral (c'git_time'offset moment)))+ (posixSecondsToUTCTime (fromIntegral (c'git_time'time moment))))++packGitTime :: ZonedTime -> C'git_time+packGitTime zt = C'git_time+ { c'git_time'time =+ floor (utcTimeToPOSIXSeconds (zonedTimeToUTC zt))+ , c'git_time'offset = fromIntegral (timeZoneMinutes (zonedTimeZone zt))+ }++packSignature :: U.Converter -> Ptr C'git_signature -> IO Git.Signature+packSignature conv sig = do+ name <- peek (p'git_signature'name sig) >>= packCString+ email <- peek (p'git_signature'email sig) >>= packCString+ time <- peekGitTime (p'git_signature'when sig)+ return Git.Signature+ { Git.signatureName = U.toUnicode conv name+ , Git.signatureEmail = U.toUnicode conv email+ , Git.signatureWhen = time+ }++withSignature :: U.Converter -> Git.Signature+ -> (Ptr C'git_signature -> IO a) -> IO a+withSignature conv sig f =+ useAsCString (U.fromUnicode conv (Git.signatureName sig)) $ \nameCStr ->+ useAsCString (U.fromUnicode conv (Git.signatureEmail sig)) $ \emailCStr ->+ alloca $ \ptr -> do+ poke ptr (C'git_signature nameCStr emailCStr+ (packGitTime (Git.signatureWhen sig)))+ f ptr++-- Internal.hs
+ Git/Libgit2/Trace.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ImpredicativeTypes #-}++module Git.Libgit2.Trace where++import Bindings.Libgit2+import Control.Applicative+import Control.Monad+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Git.Libgit2.Backend+import Prelude hiding ((.), mapM_)++data TraceBackend = TraceBackend { traceParent :: C'git_odb_backend+ , traceNext :: Ptr C'git_odb_backend }++instance Storable TraceBackend where+ sizeOf _ = sizeOf (undefined :: C'git_odb_backend) ++ sizeOf (undefined :: Ptr C'git_odb_backend)+ alignment p = alignment (traceParent p)+ peek p = do+ v0 <- peekByteOff p 0+ v1 <- peekByteOff p (sizeOf (undefined :: C'git_odb_backend))+ return (TraceBackend v0 v1)+ poke p (TraceBackend v0 v1) = do+ pokeByteOff p 0 v0+ pokeByteOff p (sizeOf (undefined :: C'git_odb_backend)) v1+ return ()++oidToStr :: Ptr C'git_oid -> IO String+oidToStr = c'git_oid_allocfmt >=> peekCString++traceBackendReadCallback :: F'git_odb_backend_read_callback+traceBackendReadCallback data_p len_p type_p be oid = do+ oidStr <- oidToStr oid+ putStrLn $ "Read " ++ oidStr+ tb <- peek (castPtr be :: Ptr TraceBackend)+ tn <- peek (traceNext tb)+ mK'git_odb_backend_read_callback+ (c'git_odb_backend'read tn)+ data_p+ len_p+ type_p+ (traceNext tb)+ oid++traceBackendReadPrefixCallback :: F'git_odb_backend_read_prefix_callback+traceBackendReadPrefixCallback out_oid oid_p len_p type_p be oid len = do+ oidStr <- oidToStr oid+ putStrLn $ "Read Prefix " ++ oidStr ++ " " ++ show len+ tb <- peek (castPtr be :: Ptr TraceBackend)+ tn <- peek (traceNext tb)+ mK'git_odb_backend_read_prefix_callback+ (c'git_odb_backend'read_prefix tn)+ out_oid+ oid_p+ len_p+ type_p+ (traceNext tb)+ oid+ len++traceBackendReadHeaderCallback :: F'git_odb_backend_read_header_callback+traceBackendReadHeaderCallback len_p type_p be oid = do+ oidStr <- oidToStr oid+ putStrLn $ "Read Header " ++ oidStr+ tb <- peek (castPtr be :: Ptr TraceBackend)+ tn <- peek (traceNext tb)+ mK'git_odb_backend_read_header_callback+ (c'git_odb_backend'read_header tn)+ len_p+ type_p+ (traceNext tb)+ oid++traceBackendWriteCallback :: F'git_odb_backend_write_callback+traceBackendWriteCallback oid be obj_data len obj_type = do+ r <- c'git_odb_hash oid obj_data len obj_type+ case r of+ 0 -> do+ oidStr <- oidToStr oid+ putStrLn $ "Write " ++ oidStr ++ " len " ++ show len+ tb <- peek (castPtr be :: Ptr TraceBackend)+ tn <- peek (traceNext tb)+ mK'git_odb_backend_write_callback+ (c'git_odb_backend'write tn)+ oid+ (traceNext tb)+ obj_data+ len+ obj_type+ n -> return n++traceBackendExistsCallback :: F'git_odb_backend_exists_callback+traceBackendExistsCallback be oid confirmNotExists = do+ oidStr <- oidToStr oid+ putStrLn $ "Exists " ++ oidStr+ tb <- peek (castPtr be :: Ptr TraceBackend)+ tn <- peek (traceNext tb)+ mK'git_odb_backend_exists_callback+ (c'git_odb_backend'exists tn)+ (traceNext tb)+ oid+ confirmNotExists++traceBackendFreeCallback :: F'git_odb_backend_free_callback+traceBackendFreeCallback be = do+ backend <- peek be+ freeHaskellFunPtr (c'git_odb_backend'read backend)+ freeHaskellFunPtr (c'git_odb_backend'read_prefix backend)+ freeHaskellFunPtr (c'git_odb_backend'read_header backend)+ freeHaskellFunPtr (c'git_odb_backend'write backend)+ freeHaskellFunPtr (c'git_odb_backend'exists backend)++foreign export ccall "traceBackendFreeCallback"+ traceBackendFreeCallback :: F'git_odb_backend_free_callback+foreign import ccall "&traceBackendFreeCallback"+ traceBackendFreeCallbackPtr :: FunPtr F'git_odb_backend_free_callback++traceBackend :: Ptr C'git_odb_backend -> IO (Ptr C'git_odb_backend)+traceBackend be = do+ readFun <- mk'git_odb_backend_read_callback traceBackendReadCallback+ readPrefixFun <-+ mk'git_odb_backend_read_prefix_callback traceBackendReadPrefixCallback+ readHeaderFun <-+ mk'git_odb_backend_read_header_callback traceBackendReadHeaderCallback+ writeFun <- mk'git_odb_backend_write_callback traceBackendWriteCallback+ existsFun <- mk'git_odb_backend_exists_callback traceBackendExistsCallback++ castPtr <$> new TraceBackend {+ traceParent = C'git_odb_backend {+ c'git_odb_backend'version = 1+ , c'git_odb_backend'odb = nullPtr+ , c'git_odb_backend'read = readFun+ , c'git_odb_backend'read_prefix = readPrefixFun+ , c'git_odb_backend'readstream = nullFunPtr+ , c'git_odb_backend'read_header = readHeaderFun+ , c'git_odb_backend'write = writeFun+ , c'git_odb_backend'writestream = nullFunPtr+ , c'git_odb_backend'exists = existsFun+ , c'git_odb_backend'refresh = undefined+ , c'git_odb_backend'foreach = undefined+ , c'git_odb_backend'writepack = undefined+ , c'git_odb_backend'free = traceBackendFreeCallbackPtr+ }+ , traceNext = be }++-- Trace.hs
+ Git/Libgit2/Types.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Git.Libgit2.Types where++import Bindings.Libgit2+import Control.Applicative+import Control.Exception+import Control.Monad (liftM)+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Reader+import Data.Conduit+import Data.IORef+import Data.Monoid+import Data.Text (Text)+import Data.Text as T (pack, unpack)+import Filesystem.Path.CurrentOS (FilePath, toText)+import Foreign.ForeignPtr+import qualified Git+import Prelude hiding (FilePath)+import System.IO.Unsafe++data Repository = Repository+ { repoOptions :: Git.RepositoryOptions+ , repoObj :: ForeignPtr C'git_repository+ , repoExcTrap :: IORef (Maybe Git.GitException)+ }++repoPath :: Repository -> FilePath+repoPath = Git.repoPath . repoOptions++instance Eq Repository where+ x == y = repoPath x == repoPath y && repoObj x == repoObj y++pathText :: FilePath -> Text+pathText = go . toText+ where+ go (Left e) =+ throw . Git.BackendError $ "Could not render path: " <> T.pack (show e)+ go (Right p) = p++pathStr :: FilePath -> String+pathStr = T.unpack . pathText++instance Show Repository where+ show x = "Repository " <> pathStr (repoPath x)++newtype LgRepository m a = LgRepository+ { lgRepositoryReaderT :: ReaderT Repository m a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance (Monad m, MonadIO m, Applicative m)+ => MonadBase IO (LgRepository m) where+ liftBase = liftIO++instance Monad m => MonadUnsafeIO (LgRepository m) where+ unsafeLiftIO = return . unsafePerformIO++instance Monad m => MonadThrow (LgRepository m) where+ -- monadThrow :: Exception e => e -> m a+ monadThrow = throw++instance MonadTrans LgRepository where+ lift = LgRepository . ReaderT . const++instance MonadTransControl LgRepository where+ newtype StT LgRepository a = StLgRepository+ { unLgRepository :: StT (ReaderT Repository) a+ }+ liftWith = defaultLiftWith LgRepository+ lgRepositoryReaderT StLgRepository+ restoreT = defaultRestoreT LgRepository unLgRepository++instance (MonadIO m, MonadBaseControl IO m)+ => MonadBaseControl IO (LgRepository m) where+ newtype StM (LgRepository m) a = StMT+ { unStMT :: ComposeSt LgRepository m a+ }+ 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)++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 Reference m = Git.Reference (LgRepository m) (Commit m)+type Object m = Git.Object (LgRepository m)++type Options m = Git.Options (LgRepository m)++lgGet :: Monad m => LgRepository m Repository+lgGet = LgRepository ask++lgExcTrap :: Monad m => LgRepository m (IORef (Maybe Git.GitException))+lgExcTrap = repoExcTrap `liftM` lgGet++-- Types.hs
+ LICENSE view
@@ -0,0 +1,19 @@+opyright (c) 2012 John Wiegley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gitlib-libgit2.cabal view
@@ -0,0 +1,72 @@+Name: gitlib-libgit2+Version: 1.0.1+Synopsis: Libgit2 backend for gitlib+License-file: LICENSE+License: MIT+Author: John Wiegley+Maintainer: johnw@fpcomplete.com+Build-Type: Simple+Cabal-Version: >=1.10+Category: FFI+Description:+ Libgit2 (<http://libgit2.github.com>) backend for @gitlib@.++Source-repository head+ type: git+ location: git://github.com/fpco/gitlib.git++Test-suite smoke+ Default-language: Haskell98+ ghc-options: -Wall+ Type: exitcode-stdio-1.0+ Main-is: Smoke.hs+ Hs-source-dirs: test+ Build-depends: + base >=3+ , gitlib+ , gitlib-test+ , gitlib-libgit2+ , HUnit >= 1.2.5+ , hspec >= 1.4.4+ , hspec-expectations >= 0.3++Library+ default-language: Haskell98+ default-extensions: ForeignFunctionInterface+ ghc-options: -Wall+ build-depends:+ base >= 3 && < 5+ , gitlib+ , gitlib-utils+ , hlibgit2 >= 0.18.0.1+ , attempt >= 0.4.0+ , bytestring >= 0.9.2.1+ , conduit >= 0.5.5+ , containers >= 0.4.2+ , data-default >= 0.5.0+ , directory >= 1.1.0.2+ , failure >= 0.2.0.1+ , hex >= 0.1.2+ , lifted-base >= 0.2.0.2+ , missing-foreign >= 0.1.1+ , monad-control >= 0.3.2+ , monad-loops >= 0.3.3.0+ , parallel-io >= 0.3.2.1+ , pointless-fun >= 1.1.0.1+ , resourcet >= 0.4.6+ , system-fileio >= 0.3.9+ , system-filepath >= 0.4.7+ , tagged >= 0.2.3.1+ , text >= 0.11.2+ , text-icu >= 0.6.3+ , temporary >= 1.1.2.4+ , time >= 1.4+ , transformers >= 0.3.0.0+ , transformers-base >= 0.4.1+ , unordered-containers >= 0.2.3+ exposed-modules:+ Git.Libgit2+ Git.Libgit2.Backend+ Git.Libgit2.Internal+ Git.Libgit2.Trace+ Git.Libgit2.Types
+ test/Smoke.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# OPTIONS_GHC -fno-warn-wrong-do-bind #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import Control.Exception (finally)+import qualified Git as Git+import qualified Git.Smoke as Git+import qualified Git.Libgit2 as Lg+import Test.Hspec.Runner+import Test.Hspec.HUnit ()++main :: IO ()+main = do+ Git.startupBackend Lg.lgFactory+ finally+ (hspec $ Git.smokeTestSpec Lg.lgFactory Lg.lgFactory)+ (Git.shutdownBackend Lg.lgFactory)++-- Smoke.hs ends here