gitlib 0.5.0 → 0.5.1
raw patch · 13 files changed
+459/−136 lines, 13 filesdep +conduit
Dependencies added: conduit
Files
- Data/Git.hs +2/−2
- Data/Git/Backend.hs +63/−0
- Data/Git/Backend/Trace.hs +118/−0
- Data/Git/Blob.hs +56/−32
- Data/Git/Error.hs +42/−0
- Data/Git/Errors.hs +0/−38
- Data/Git/Internal.hs +8/−2
- Data/Git/Object.hs +4/−1
- Data/Git/Oid.hs +17/−12
- Data/Git/Reference.hs +103/−26
- Data/Git/Tree.hs +1/−1
- gitlib.cabal +8/−5
- test/Smoke.hs +37/−17
Data/Git.hs view
@@ -6,7 +6,7 @@ module Data.Git.Commit, -- module Data.Git.Index, module Data.Git.Blob,- module Data.Git.Errors,+ module Data.Git.Error, module Data.Git.Oid, module Data.Git.Tree, module Data.Git.Reference,@@ -22,7 +22,7 @@ import Data.Git.Commit -- import Data.Git.Index import Data.Git.Blob-import Data.Git.Errors+import Data.Git.Error import Data.Git.Oid import Data.Git.Tree import Data.Git.Reference
+ Data/Git/Backend.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Git.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_free_callback+ )+ where++import Data.Git.Error+import Data.Git.Internal+import qualified Prelude++default (Text)++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 -> CUInt -> 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 -> IO CInt+type F'git_odb_backend_free_callback = Ptr C'git_odb_backend -> IO ()++odbBackendAdd :: Repository -> Ptr C'git_odb_backend -> Int+ -> IO (Result Repository)+odbBackendAdd repo' backend priority =+ withForeignPtr 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')++ where+ repo = fromMaybe (throw RepositoryInvalid) (repoObj repo')++-- Backend.hs
+ Data/Git/Backend/Trace.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ImpredicativeTypes #-}++module Data.Git.Backend.Trace ( traceBackend ) where++import Data.ByteString.Unsafe+import Data.Git.Backend+import Data.Git.Error+import Data.Git.Internal+import Data.Git.Oid+import Debug.Trace (trace)+import Prelude hiding ((.), mapM_)++data TraceBackend = TraceBackend { traceParent :: C'git_odb_backend+ , traceNext :: Ptr C'git_odb_backend }++instance Storable TraceBackend where+ sizeOf p = 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 ()++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 = 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++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'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'free = traceBackendFreeCallbackPtr }+ , traceNext = be }++-- Trace.hs
Data/Git/Blob.hs view
@@ -1,24 +1,42 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternGuards #-} module Data.Git.Blob ( Blob(..)+ , BlobContents(..) , newBlobBase , createBlob , getBlobContents+ , blobSourceToString , writeBlob ) where import Data.ByteString as B hiding (map) import Data.ByteString.Unsafe+import Data.Conduit import Data.Git.Common-import Data.Git.Errors+import Data.Git.Error import Data.Git.Internal import qualified Prelude default (Text) +data BlobContents = BlobEmpty+ | BlobString B.ByteString+ | BlobStream ByteSource++blobSourceToString :: BlobContents -> IO (Maybe B.ByteString)+blobSourceToString BlobEmpty = return Nothing+blobSourceToString (BlobString bs) = return (Just bs)+blobSourceToString (BlobStream bs) = do str <- bs $$ await+ case str of+ Nothing -> return Nothing+ Just str' -> return (Just str')+ data Blob = Blob { blobInfo :: Base Blob- , blobContents :: B.ByteString }+ , blobContents :: BlobContents } instance Show Blob where show x = case gitId (blobInfo x) of@@ -45,38 +63,37 @@ | text == B.empty = error "Cannot create an empty blob" | otherwise = Blob { blobInfo = newBase repo (Pending doWriteBlob) Nothing- , blobContents = text }+ , blobContents = BlobString text } lookupBlob :: Oid -> Repository -> IO (Maybe Blob) lookupBlob oid repo = lookupObject' oid repo c'git_blob_lookup c'git_blob_lookup_prefix $ \coid obj _ -> return Blob { blobInfo = newBase repo (Stored coid) (Just obj)- , blobContents = B.empty }+ , blobContents = BlobEmpty } -getBlobContents :: Blob -> IO (Blob, B.ByteString)-getBlobContents b =- case gitId (blobInfo b) of- Pending _ -> return (b, contents)- Stored hash ->- if contents /= B.empty- then return (b, contents)- else- case gitObj (blobInfo b) of- Just blobPtr ->- withForeignPtr blobPtr $ \ptr -> do- size <- c'git_blob_rawsize (castPtr ptr)- buf <- c'git_blob_rawcontent (castPtr ptr)- bstr <- curry unsafePackCStringLen (castPtr buf)- (fromIntegral size)- return (b { blobContents = bstr }, bstr)+getBlobContents :: Blob -> IO (Blob, BlobContents)+getBlobContents b@(gitId . blobInfo -> Pending _) = return (b, blobContents b)+getBlobContents b@(gitId . blobInfo -> Stored hash)+ | BlobEmpty <- contents =+ case gitObj (blobInfo b) of+ Just blobPtr ->+ withForeignPtr blobPtr $ \ptr -> do+ size <- c'git_blob_rawsize (castPtr ptr)+ buf <- c'git_blob_rawcontent (castPtr ptr)+ bstr <- curry unsafePackCStringLen (castPtr buf)+ (fromIntegral size)+ let contents' = BlobString bstr+ return (b { blobContents = contents' }, contents' ) - Nothing -> do- b' <- lookupBlob (Oid hash) repo- case b' of- Just blobPtr' -> getBlobContents blobPtr'- Nothing -> return (b, B.empty)+ Nothing -> do+ b' <- lookupBlob (Oid hash) repo+ case b' of+ Just blobPtr' -> getBlobContents blobPtr'+ Nothing -> return (b, BlobEmpty) + | otherwise = return (b, contents)+ where repo = gitRepo (blobInfo b) contents = blobContents b @@ -86,8 +103,9 @@ writeBlob b@(Blob { blobInfo = Base { gitId = Stored _ } }) = return b writeBlob b = do hash <- doWriteBlob b return b { blobInfo = (blobInfo b) { gitId = Stored hash }- , blobContents = B.empty }+ , blobContents = BlobEmpty } +-- jww (2012-12-14): Have the write functions return Either instead doWriteBlob :: Blob -> IO COid doWriteBlob b = do ptr <- mallocForeignPtr@@ -99,11 +117,17 @@ repo = fromMaybe (error "Repository invalid") (repoObj (gitRepo (blobInfo b))) - createFromBuffer ptr repoPtr =- unsafeUseAsCStringLen (blobContents b) $- uncurry (\cstr len ->- withForeignPtr ptr $ \ptr' ->- c'git_blob_create_frombuffer- ptr' repoPtr (castPtr cstr) (fromIntegral len))+ createFromBuffer ptr repoPtr = do+ str <- blobSourceToString (blobContents b)+ case str of+ Nothing -> throw BlobCreateFailed+ Just str' -> createBlobFromByteString ptr repoPtr str'++ createBlobFromByteString ptr repoPtr bs =+ unsafeUseAsCStringLen bs $+ uncurry (\cstr len ->+ withForeignPtr ptr $ \ptr' ->+ c'git_blob_create_frombuffer+ ptr' repoPtr (castPtr cstr) (fromIntegral len)) -- Blob.hs
+ Data/Git/Error.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Error types which may be thrown during Git operations, using+-- 'Control.Exception.throwIO'.+module Data.Git.Error+ ( GitException(..), Result )+ where++import Control.Exception+import Data.Typeable+import Data.Text+import Prelude hiding (FilePath)++-- | There is a separate 'GitException' for each possible failure when+-- interacting with the Git repository.+data GitException = RepositoryNotExist String+ | RepositoryInvalid+ | BlobCreateFailed+ | BlobEmptyCreateFailed+ | TreeCreateFailed+ | TreeBuilderCreateFailed+ | TreeBuilderInsertFailed+ | TreeBuilderWriteFailed+ | TreeLookupFailed+ | TreeCannotTraverseBlob+ | TreeEntryLookupFailed+ | CommitCreateFailed+ | CommitLookupFailed+ | ReferenceCreateFailed+ | RefCannotCreateFromPartialOid+ | ReferenceLookupFailed+ | ObjectLookupFailed+ | ObjectIdTooLong+ | ObjectRefRequiresFullOid+ | OidCopyFailed+ deriving (Show, Typeable)++type Result = Either Text++instance Exception GitException++-- Error.hs
− Data/Git/Errors.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | Error types which may be thrown during Git operations, using--- 'Control.Exception.throwIO'.-module Data.Git.Errors- ( GitException(..) )- where--import Control.Exception-import Data.Typeable-import Prelude hiding (FilePath)---- | There is a separate 'GitException' for each possible failure when--- interacting with the Git repository.-data GitException = RepositoryNotExist String- | RepositoryInvalid- | BlobCreateFailed- | TreeCreateFailed- | TreeBuilderCreateFailed- | TreeBuilderInsertFailed- | TreeBuilderWriteFailed- | TreeLookupFailed- | TreeCannotTraverseBlob- | TreeEntryLookupFailed- | CommitCreateFailed- | CommitLookupFailed- | ReferenceCreateFailed- | RefCannotCreateFromPartialOid- | ReferenceLookupFailed- | ObjectLookupFailed- | ObjectIdTooLong- | ObjectRefRequiresFullOid- | OidCopyFailed- deriving (Show, Typeable)--instance Exception GitException---- Errors.hs
Data/Git/Internal.hs view
@@ -1,10 +1,12 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Data.Git.Internal ( ObjPtr+ , ByteSource , Updatable(..) @@ -30,10 +32,12 @@ import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_, forM, forM_, msum) import Data.Bool as X+import Data.ByteString as B hiding (map)+import Data.Conduit import Data.Either as X hiding (lefts, rights) import Data.Foldable as X import Data.Function as X hiding ((.), id)-import Data.Git.Errors as X+import Data.Git.Error as X import Data.Git.Oid as X import Data.List as X hiding (foldl, foldl', foldl1, foldr1, foldl1', foldr, concat, maximum, minimum,@@ -58,13 +62,15 @@ import Foreign.StablePtr as X import Foreign.Storable as X import Prelude as X (undefined, error, otherwise, IO, Show, show,- Enum, Eq, Ord, (<), (==), (/=), round,+ Enum, Eq, Ord, (<), (==), (/=), round, Int, Integer, fromIntegral, fromInteger, toInteger) import Unsafe.Coerce as X default (Text) type ObjPtr a = Maybe (ForeignPtr a)++type ByteSource = GSource IO B.ByteString class Updatable a where getId :: a -> Ident a
Data/Git/Object.hs view
@@ -2,6 +2,7 @@ module Data.Git.Object ( Object(..)+ , ObjectType(..) , NamedRef(..) , revParse , lookupObject )@@ -15,6 +16,8 @@ import Data.Git.Tree import qualified Data.Map as M +data ObjectType = BlobType | TreeType | CommitType | TagType+ data Object = BlobObj Blob | TreeObj Tree | CommitObj Commit@@ -50,7 +53,7 @@ | typ == c'GIT_OBJ_BLOB = return $ BlobObj Blob { blobInfo = newBase repo (Stored coid) (Just obj)- , blobContents = B.empty }+ , blobContents = BlobEmpty } | typ == c'GIT_OBJ_TREE = return $ TreeObj Tree { treeInfo =
Data/Git/Oid.hs view
@@ -6,6 +6,7 @@ module Data.Git.Oid ( Oid(..) , COid(..)+ , oidToStr , ObjRef(..) , Ident(..) , wrapOidPtr@@ -15,24 +16,28 @@ , stringToOid ) where -import Bindings.Libgit2.Oid-import Control.Exception-import Control.Monad-import Data.ByteString.Unsafe-import Data.Git.Errors-import Data.Stringable as S-import Foreign.Ptr-import Foreign.ForeignPtr-import System.IO.Unsafe+import Bindings.Libgit2.Oid+import Control.Applicative+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Char8 as BC+import Data.ByteString.Unsafe+import Data.Git.Error+import Data.Stringable as S+import Foreign.C.String+import Foreign.ForeignPtr+import Foreign.Ptr+import System.IO.Unsafe -- | 'COid' is a type wrapper for a foreign pointer to libgit2's 'git_oid' -- structure. Users should not have to deal with this type. newtype COid = COid (ForeignPtr C'git_oid) +oidToStr :: Ptr C'git_oid -> IO String+oidToStr = c'git_oid_allocfmt >=> peekCString+ instance Show COid where- show (COid x) =- toString $ unsafePerformIO $- withForeignPtr x (unsafePackMallocCString <=< c'git_oid_allocfmt)+ show (COid coid) = unsafePerformIO $ withForeignPtr coid oidToStr -- | 'ObjRef' refers to either a Git object of a particular type (if it has -- already been loaded into memory), or it refers to the 'COid' of that
Data/Git/Reference.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} module Data.Git.Reference ( RefTarget(..)@@ -7,20 +8,28 @@ , createRef , lookupRef , listRefNames- , listAll+ , allRefsFlag+ , oidRefsFlag+ , looseOidRefsFlag+ , symbolicRefsFlag+ , mapRefs+ , mapAllRefs+ , mapOidRefs+ , mapLooseOidRefs+ , mapSymbolicRefs , lookupId , writeRef , writeRef_ ) where import Bindings.Libgit2-import Data.Git.Common+import Data.ByteString.Unsafe import Data.Git.Internal-import Data.Git.Object-import qualified Prelude-import Prelude ((+),(-)) import qualified Data.Text as T+import qualified Data.Text.Encoding as E import Foreign.Marshal.Array+import qualified Prelude+import Prelude ((+),(-)) default (Text) @@ -152,21 +161,42 @@ --packallRefs = c'git_reference_packall -data ListFlags = ListFlags { invalid :: Bool- , oid :: Bool- , symbolic :: Bool- , packed :: Bool- , hasPeel :: Bool }- deriving Show+data ListFlags = ListFlags { listFlagInvalid :: Bool+ , listFlagOid :: Bool+ , listFlagSymbolic :: Bool+ , listFlagPacked :: Bool+ , listFlagHasPeel :: Bool }+ deriving (Show, Eq) -listAll :: ListFlags-listAll = ListFlags { invalid = False- , oid = True- , symbolic = True- , packed = True- , hasPeel = False }+allRefsFlag :: ListFlags+allRefsFlag = ListFlags { listFlagInvalid = False+ , listFlagOid = True+ , listFlagSymbolic = True+ , listFlagPacked = True+ , listFlagHasPeel = False } -gitStrArray2List :: Ptr C'git_strarray -> IO [ Text ]+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@@ -175,15 +205,17 @@ r1 <- sequence $ fmap peekCString r0 return $ fmap T.pack r1 -listRefNames :: Repository -> ListFlags -> IO [ Text ]+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 :: Repository -> ListFlags -> IO [Text] listRefNames repo flags =- let intFlags = (if oid flags then 1 else 0)- + (if symbolic flags then 2 else 0)- + (if packed flags then 4 else 0)- + (if hasPeel flags then 8 else 0)- in alloca $ \c'refs ->+ alloca $ \c'refs -> withForeignPtr (repositoryPtr repo) $ \repoPtr -> do- r <- c'git_reference_list c'refs repoPtr intFlags+ r <- c'git_reference_list c'refs repoPtr (flagsToInt flags) when (r < 0) $ throwIO ReferenceLookupFailed refs <- gitStrArray2List c'refs@@ -195,7 +227,52 @@ -- int git_reference_foreach(git_repository *repo, unsigned int list_flags, -- int (*callback)(const char *, void *), void *payload) ---foreachRef = c'git_reference_foreach+type ForeachRefCallback = Text -> IO ()++foreachRefCallbackThunk :: ForeachRefCallback -> CString -> Ptr () -> IO CInt+foreachRefCallbackThunk callback name _ = do+ nameText <- E.decodeUtf8 <$> unsafePackCString name+ callback nameText+ return 0++mapRefs :: Repository -> ListFlags -> ForeachRefCallback -> IO ()+mapRefs repo flags cb =+ withForeignPtr (repositoryPtr repo) $ \repoPtr -> do+ fun <- mk'git_reference_foreach_callback (foreachRefCallbackThunk cb)+ r <- c'git_reference_foreach repoPtr (flagsToInt flags) fun nullPtr+ -- jww (2012-12-14): Does the return type mean anything here?+ when (r < 0) $ return ()+ return ()++mapAllRefs :: Repository -> ForeachRefCallback -> IO ()+mapAllRefs repo = mapRefs repo allRefsFlag+mapOidRefs :: Repository -> ForeachRefCallback -> IO ()+mapOidRefs repo = mapRefs repo oidRefsFlag+mapLooseOidRefs :: Repository -> ForeachRefCallback -> IO ()+mapLooseOidRefs repo = mapRefs repo looseOidRefsFlag+mapSymbolicRefs :: Repository -> ForeachRefCallback -> IO ()+mapSymbolicRefs repo = mapRefs repo symbolicRefsFlag++{-+foreachRefCallbackThunk :: Storable a =>+ ForeachRefCallback a -> CString -> Ptr () -> IO CInt+foreachRefCallbackThunk callback name payload = do+ nameText <- E.decodeUtf8 <$> unsafePackCString name+ payloadValue <- peek (castPtr payload)+ maybe (-1) (const 0) <$> callback nameText payloadValue++mapRefsWith ::+ Storable a => Repository -> ListFlags -> a -> ForeachRefCallback a -> IO ()+mapRefsWith repo flags payload cb =+ withForeignPtr (repositoryPtr repo) $ \repoPtr -> do+ fun <- mk'git_reference_foreach_callback (foreachRefCallbackThunk cb)+ with payload $ \payloadPtr -> do+ r <- c'git_reference_foreach repoPtr (flagsToInt flags) fun+ (castPtr payloadPtr)+ -- jww (2012-12-14): Does the return type mean anything here?+ when (r < 0) $ return ()+ return ()+-} -- int git_reference_is_packed(git_reference *ref)
Data/Git/Tree.hs view
@@ -9,7 +9,7 @@ import Control.Concurrent.ParallelIO import Data.Git.Blob import Data.Git.Common-import Data.Git.Errors+import Data.Git.Error import Data.Git.Internal import qualified Data.Map as M import qualified Data.Text as T
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 0.5.0+Version: 0.5.1 Synopsis: Higher-level types for working with hlibgit2 Description: Higher-level types for working with hlibgit2 License-file: LICENSE@@ -19,9 +19,9 @@ Type: exitcode-stdio-1.0 Main-is: Smoke.hs Hs-source-dirs: test- Ghc-options: -Wall -Werror Build-depends: base >=3 , gitlib+ , hlibgit2 >= 0.17 , HUnit >= 1.2.5 , bytestring >= 0.9.2.1 , containers >= 0.4.2@@ -38,7 +38,6 @@ Type: exitcode-stdio-1.0 Main-is: Doctest.hs Hs-source-dirs: test- Ghc-options: -Wall -Werror Build-depends: base == 4.* , directory >= 1.0 && < 1.3 , doctest >= 0.8 && <= 0.10@@ -60,6 +59,7 @@ base >= 3 && < 5 , hlibgit2 >= 0.17 , bytestring >= 0.9.2.1+ , conduit >= 0.5.5 , containers >= 0.4.2 , lens >= 2.8 , parallel-io >= 0.3.2.1@@ -71,15 +71,18 @@ , time >= 1.4 exposed-modules: Data.Git+ Data.Git.Backend+ Data.Git.Backend.Trace Data.Git.Blob Data.Git.Commit Data.Git.Common- Data.Git.Errors+ Data.Git.Error Data.Git.Object Data.Git.Oid Data.Git.Repository Data.Git.Tag Data.Git.Tree Data.Git.Reference- other-modules: Data.Git.Internal+ -- other-modules:+ -- Data.Git.Internal
test/Smoke.hs view
@@ -5,10 +5,13 @@ module Main where +import Bindings.Libgit2.OdbBackend import Control.Applicative import Control.Concurrent.ParallelIO import Control.Monad import Data.Git+import Data.Git.Backend+import Data.Git.Backend.Trace import Data.Maybe import Data.Text as T hiding (map) import qualified Data.Text.Encoding as E@@ -16,7 +19,12 @@ import Data.Traversable import Filesystem (removeTree, isDirectory) import Filesystem.Path.CurrentOS+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable import qualified Prelude+import Prelude (putStrLn) import Prelude hiding (FilePath, putStr, putStrLn) import System.Exit import Test.HUnit@@ -41,7 +49,10 @@ case obj of Just (BlobObj b) -> do (_, contents) <- getBlobContents b- return (E.decodeUtf8 contents)+ str <- blobSourceToString contents+ case str of+ Nothing -> return T.empty+ Just str' -> return (E.decodeUtf8 str') Just _ -> error "Found something else..." Nothing -> error "Didn't find anything :("@@ -79,10 +90,10 @@ update_ $ createBlob (E.encodeUtf8 "Hello, world!\n") repo x <- catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b"- (@?=) x (Just "Hello, world!\n")+ x @?= (Just "Hello, world!\n") x <- catBlob repo "af5626b"- (@?=) x (Just "Hello, world!\n")+ x @?= (Just "Hello, world!\n") return () @@ -92,7 +103,7 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr- (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"+ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" return() @@ -102,12 +113,12 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr- (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"+ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr- (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a"+ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" return() @@ -117,19 +128,19 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr- (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"+ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr- (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a"+ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- Confirm that deleting world.txt also deletes the now-empty subtree -- goodbye/files, which also deletes the then-empty subtree goodbye, -- returning us back the original tree. tr <- removeFromTree "goodbye/files/world.txt" tr x <- oid tr- (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"+ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" return() @@ -142,7 +153,7 @@ let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr- (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a"+ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- The Oid has been cleared in tr, so this tests that it gets written as -- needed.@@ -152,20 +163,27 @@ , signatureWhen = posixSecondsToUTCTime 1348980883 } x <- oid $ sampleCommit repo tr sig- (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56"+ x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" return() , "createTwoCommits" ~: - withRepository "createTwoCommits.git" $ \repo -> do+ withRepository "createTwoCommits.git" $ \repo -> alloca $ \loosePtr -> do+ withCString "createTwoCommits.git/objects" $ \objectsDir -> 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'+ odbBackendAdd repo backend 3+ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr- (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a"+ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- The Oid has been cleared in tr, so this tests that it gets written as -- needed.@@ -175,12 +193,12 @@ , signatureWhen = posixSecondsToUTCTime 1348980883 } c = sampleCommit repo tr sig x <- oid c- (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56"+ x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" let goodbye2 = createBlob (E.encodeUtf8 "Goodbye, world again!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye2) tr x <- oid tr- (@?=) x "f2b42168651a45a4b7ce98464f09c7ec7c06d706"+ x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706" let sig = Signature { signatureName = "John Wiegley"@@ -190,14 +208,16 @@ commitLog = "Second sample log message." , commitParents = [ObjRef c] } x <- oid c2- (@?=) x "2506e7fcc2dbfe4c083e2bd741871e2e14126603"+ x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" cid <- objectId c2 writeRef $ createRef "refs/heads/master" (RefTargetId cid) repo writeRef $ createRef "HEAD" (RefTargetSymbolic "refs/heads/master") repo x <- oidToText <$> lookupId "refs/heads/master" repo- (@?=) x "2506e7fcc2dbfe4c083e2bd741871e2e14126603"+ x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603"++ mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name) return()