hlibgit2 0.4.0 → 0.5.0
raw patch · 14 files changed
+834/−14 lines, 14 filesdep +bytestringdep +containersdep +lens
Dependencies added: bytestring, containers, lens, system-fileio, system-filepath, text, time
Files
- hlibgit2.cabal +33/−6
- src/Data/Git.hs +43/−0
- src/Data/Git/Blob.hs +105/−0
- src/Data/Git/Commit.hs +31/−0
- src/Data/Git/Common.hs +34/−0
- src/Data/Git/Errors.hs +21/−0
- src/Data/Git/Internal.hs +149/−0
- src/Data/Git/Object.hs +62/−0
- src/Data/Git/Oid.hs +84/−0
- src/Data/Git/Repository.hs +21/−0
- src/Data/Git/Stringable.hs +87/−0
- src/Data/Git/Tag.hs +25/−0
- src/Data/Git/Tree.hs +84/−0
- tests/Main.hs +55/−8
hlibgit2.cabal view
@@ -1,5 +1,5 @@ Name: hlibgit2-Version: 0.4.0+Version: 0.5.0 Synopsis: Low-level bindings to libgit2. Description: Bindings to libgit2 v0.16.0-471-g5b9fac3 License-file: LICENSE@@ -29,17 +29,31 @@ main-is: Main.hs hs-source-dirs: tests build-depends:- base >=3,- hlibgit2,- process+ base >=3+ , hlibgit2+ , process+ , system-filepath >= 0.4.7+ , system-fileio >= 0.3.9+ , time >= 1.4+ , text >= 0.11.2+ , containers >= 0.4.2+ , bytestring >= 0.9.2.1+ , lens >= 2.8 Library default-language: Haskell98 default-extensions: ForeignFunctionInterface build-depends:- base >= 3 && < 5,- bindings-DSL >= 1.0.11+ base >= 3 && < 5+ , bindings-DSL >= 1.0.11+ , system-filepath >= 0.4.7+ , system-fileio >= 0.3.9+ , time >= 1.4+ , text >= 0.11.2+ , containers >= 0.4.2+ , bytestring >= 0.9.2.1+ , lens >= 2.8 exposed-modules: Bindings.Libgit2 Bindings.Libgit2.Attr@@ -74,6 +88,19 @@ Bindings.Libgit2.Types Bindings.Libgit2.Version Bindings.Libgit2.Windows+ Data.Git+ Data.Git.Blob+ Data.Git.Commit+ Data.Git.Common+ Data.Git.Errors+ Data.Git.Object+ Data.Git.Oid+ Data.Git.Repository+ Data.Git.Tag+ Data.Git.Tree+ other-modules:+ Data.Git.Internal+ Data.Git.Stringable c-sources: src/Bindings/Libgit2/Attr.hsc.helper.c src/Bindings/Libgit2/Blob.hsc.helper.c
+ src/Data/Git.hs view
@@ -0,0 +1,43 @@+module Data.Git (+ module Data.Git.Repository,+ -- module Data.Git.Config,+ -- module Data.Git.Types,+ -- module Data.Git.Revwalk,+ -- module Data.Git.OdbBackend,+ -- module Data.Git.Tag,+ -- module Data.Git.Net,+ -- module Data.Git.Refs,+ -- module Data.Git.Refspec,+ -- module Data.Git.Reflog,+ -- module Data.Git.Commit,+ -- module Data.Git.Index,+ -- module Data.Git.Signature,+ module Data.Git.Blob,+ module Data.Git.Errors,+ module Data.Git.Oid,+ module Data.Git.Tree,+ -- module Data.Git.Odb,+ module Data.Git.Common,+ module Data.Git.Object+) where++import Data.Git.Repository+-- import Data.Git.Config+-- import Data.Git.Types+-- import Data.Git.Revwalk+-- import Data.Git.OdbBackend+-- import Data.Git.Tag+-- import Data.Git.Net+-- import Data.Git.Refs+-- import Data.Git.Refspec+-- import Data.Git.Reflog+-- import Data.Git.Commit+-- import Data.Git.Index+-- import Data.Git.Signature+import Data.Git.Blob+import Data.Git.Errors+import Data.Git.Oid+import Data.Git.Tree+-- import Data.Git.Odb+import Data.Git.Common+import Data.Git.Object
+ src/Data/Git/Blob.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Blob+ ( Blob(..), HasBlob(..)+ , createBlob+ , getBlobContents+ , writeBlob )+ where++import Bindings.Libgit2+import Data.ByteString as B hiding (map)+import Data.ByteString.Unsafe+import Data.Git.Common+import Data.Git.Errors+import Data.Git.Internal+import Data.Text as T hiding (map)+import Prelude hiding (FilePath)++default (Text)++data Blob = Blob { _blobInfo :: Base Blob+ , _blobContents :: B.ByteString }++makeClassy ''Blob++instance Show Blob where+ show x = case x^.blobInfo.gitId of+ Left _ -> "Blob"+ Right y -> "Blob#" ++ show y++instance Updatable Blob where+ update = writeBlob++-- | 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 give string is 'empty', it is an error.+createBlob :: Repository -> B.ByteString -> Blob+createBlob repo text+ | text == B.empty = error "Cannot create an empty blob"+ | otherwise = Blob { _blobInfo = newBase repo (Left doWriteBlob) Nothing+ , _blobContents = text }++lookupBlob :: Repository -> Oid -> IO (Maybe Blob)+lookupBlob repo oid =+ lookupObject' repo oid c'git_blob_lookup c'git_blob_lookup_prefix+ (\coid obj _ ->+ return Blob { _blobInfo = newBase repo (Right coid)+ (Just obj)+ , _blobContents = B.empty })++getBlobContents :: Blob -> IO (Blob, B.ByteString)+getBlobContents b =+ case b^.blobInfo.gitId of+ Left _ -> return $ (b, contents)+ Right hash ->+ if contents /= B.empty+ then return (b, contents)+ else+ case b^.blobInfo.gitObj 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 (blobContents .~ bstr $ b, bstr)++ Nothing -> do+ b' <- lookupBlob repo (Oid hash)+ case b' of+ Just blobPtr' -> getBlobContents blobPtr'+ Nothing -> return (b, B.empty)++ where repo = b^.blobInfo.gitRepo+ contents = b^.blobContents++-- | Write out a blob to its repository. If it has already been written,+-- nothing will happen.+writeBlob :: Blob -> IO Blob+writeBlob b@(Blob { _blobInfo = Base { _gitId = Right _ } }) = return b+writeBlob b = do hash <- doWriteBlob b+ return $ blobInfo.gitId .~ Right hash $+ blobContents .~ B.empty $ b++doWriteBlob :: Blob -> IO COid+doWriteBlob b = do+ ptr <- mallocForeignPtr+ r <- withForeignPtr repo (createFromBuffer ptr)+ when (r < 0) $ throwIO BlobCreateFailed+ return (COid ptr)++ where+ repo = fromMaybe (error "Repository invalid") $+ b^.blobInfo.gitRepo.repoObj++ createFromBuffer ptr repoPtr =+ unsafeUseAsCStringLen (b^.blobContents) $+ uncurry (\cstr len ->+ withForeignPtr ptr $ \ptr' ->+ c'git_blob_create_frombuffer+ ptr' repoPtr (castPtr cstr) (fromIntegral len))++-- Blob.hs
+ src/Data/Git/Commit.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Commit where++import Bindings.Libgit2+import Control.Lens+import Data.Either+import Data.Git.Common+import Data.Git.Internal+import Data.Git.Tree+import Data.Text as T hiding (map)+import Prelude hiding (FilePath)++default (Text)++data Commit = Commit { _commitInfo :: Base Commit+ , _commitWho :: WhoWhen+ , _commitLog :: Text+ , _commitTree :: Tree+ , _commitObj :: ObjPtr C'git_commit }++makeClassy ''Commit++instance Show Commit where+ show x = case x^.commitInfo.gitId of+ Left _ -> "Commit"+ Right y -> "Commit#" ++ show y++-- Commit.hs
+ src/Data/Git/Common.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Common+ ( Author, HasAuthor(..)+ , WhoWhen, HasWhoWhen(..)+ , Base(..), gitId, gitRepo+ , newBase )+ where++import Control.Lens+import Data.Either+import Data.Git.Internal+import Data.Text as T hiding (map)+import Data.Time+import Prelude hiding (FilePath)++default (Text)++data Author = Author { _authorName :: Text+ , _authorEmail :: Text }+ deriving (Show, Eq)++makeClassy ''Author++data WhoWhen = WhoWhen { _whoAuthor :: Author+ , _whoAuthorDate :: UTCTime+ , _whoCommitter :: Author+ , _whoCommitterDate :: UTCTime }+ deriving (Show, Eq)++makeClassy ''WhoWhen++-- Common.hs
+ src/Data/Git/Errors.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Git.Errors+ ( GitException(..) )+ where++import Control.Exception+import Data.Typeable+import Prelude hiding (FilePath)++data GitException = RepositoryNotExist String+ | RepositoryInvalid+ | BlobCreateFailed+ | ObjectLookupFailed+ | ObjectIdTooLong+ | OidCopyFailed+ deriving (Show, Typeable)++instance Exception GitException++-- Errors.hs
+ src/Data/Git/Internal.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.Git.Internal+ ( ObjPtr++ , Updatable(..)++ , Base(..), gitId, gitRepo, gitObj+ , newBase++ , Repository+ , HasRepository(..)++ , openRepository+ , createRepository+ , openOrCreateRepository+ , repositoryPtr++ , lookupObject'++ , module X )+ where++import Bindings.Libgit2 as X+import Control.Applicative as X+import Control.Exception as X+import Control.Lens as X hiding((<.>))+import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_,+ forM, forM_, msum)+import Data.Either as X+import Data.Foldable as X+import Data.Git.Errors as X+import Data.Git.Oid as X+import Data.Git.Stringable as X+import Data.Maybe as X+import Data.Monoid as X+import Data.Text as T hiding (map)+import Data.Traversable as X+import Filesystem as X+import Filesystem.Path.CurrentOS as X hiding (empty, concat)+import Foreign.C.String as X+import Foreign.C.Types as X+import Foreign.ForeignPtr as X+import Foreign.Marshal.Alloc as X+import Foreign.Marshal.Utils as X+import Foreign.Ptr as X+import Foreign.StablePtr as X+import Foreign.Storable as X+import Prelude hiding (FilePath, mapM, mapM_, sequence, sequence_)+import Unsafe.Coerce as X++default (Text)++type ObjPtr a = Maybe (ForeignPtr a)++class Updatable a where+ update :: a -> IO a+ update_ :: a -> IO ()+ update_ x = void (update x)++data Repository = Repository { _repoPath :: FilePath+ , _repoObj :: ObjPtr C'git_repository }++makeClassy ''Repository++instance Show Repository where+ show x = "Repository " <> toString (x^.repoPath)++data Base a = Base { _gitId :: Ident a+ , _gitRepo :: Repository+ , _gitObj :: ObjPtr C'git_object }++makeLenses ''Base++instance Show (Base a) where+ show x = case x^.gitId of+ Left _ -> "Base"+ Right y -> "Base#" ++ show y++newBase :: Repository -> Ident a -> ObjPtr C'git_object -> Base a+newBase repo oid obj = Base { _gitId = oid+ , _gitRepo = repo+ , _gitObj = obj }++repositoryPtr :: Repository -> ForeignPtr C'git_repository+repositoryPtr repo = fromMaybe (error "Repository invalid") (repo^.repoObj)++openRepository :: FilePath -> IO Repository+openRepository path =+ openRepositoryWith path c'git_repository_open++createRepository :: FilePath -> Bool -> IO Repository+createRepository path bare =+ openRepositoryWith path (\x y -> c'git_repository_init x y (fromBool bare))++openOrCreateRepository :: FilePath -> Bool -> IO Repository+openOrCreateRepository path bare = do+ b <- isDirectory path+ if b+ then openRepository path+ else createRepository path bare++openRepositoryWith :: FilePath+ -> (Ptr (Ptr C'git_repository) -> CString -> IO CInt)+ -> IO Repository+openRepositoryWith path fn = alloca $ \ptr ->+ case toText path of+ Left p -> doesNotExist p+ Right p ->+ withCStringable p $ \str -> do+ r <- fn ptr str+ when (r < 0) $ doesNotExist p+ ptr' <- peek ptr+ fptr <- newForeignPtr p'git_repository_free ptr'+ return Repository { _repoPath = path+ , _repoObj = Just fptr }++ where doesNotExist = throwIO . RepositoryNotExist . toString++lookupObject'+ :: Repository -> Oid+ -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> IO CInt)+ -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> CUInt -> IO CInt)+ -> (COid -> ForeignPtr C'git_object -> Ptr C'git_object -> IO b)+ -> IO (Maybe b)+lookupObject' repo oid lookupFn lookupPrefixFn createFn = alloca $ \ptr -> do+ r <- withForeignPtr (repositoryPtr repo) $ \repoPtr ->+ case oid of+ Oid (COid oid') ->+ withForeignPtr oid' $ \oidPtr ->+ lookupFn (castPtr ptr) repoPtr oidPtr+ PartialOid (COid oid') len ->+ withForeignPtr oid' $ \oidPtr ->+ lookupPrefixFn (castPtr ptr) repoPtr oidPtr (fromIntegral len)+ if r < 0+ then return Nothing+ else do+ ptr' <- peek ptr+ coid <- c'git_object_id ptr'+ coidCopy <- mallocForeignPtr+ withForeignPtr coidCopy $ flip c'git_oid_cpy coid++ fptr <- newForeignPtr p'git_object_free ptr'+ Just <$> createFn (COid coidCopy) fptr ptr'++-- Internal.hs
+ src/Data/Git/Object.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Git.Object+ ( Object(..)+ , Ref(..)+ , revParse+ , lookupObject )+ where++import Data.ByteString as B hiding (map)+import Data.Git.Blob+import Data.Git.Commit+import Data.Git.Internal+import Data.Git.Tag+import Data.Git.Tree+import qualified Data.Map as M++data Object = BlobObj Blob+ | TreeObj Tree+ | CommitObj Commit+ | TagObj Tag++data Ref a = FullHash a+ | PartialHash a+ | BranchName a+ | TagName a+ | RefName a+ | FullRefName a+ | Specifier a++revParse :: CStringable a => Ref a -> IO (Maybe Oid)+revParse (FullHash r) = stringToOid r+revParse (PartialHash r) = stringToOid r+revParse (BranchName r) = undefined+revParse (TagName r) = undefined+revParse (RefName r) = undefined+revParse (FullRefName r) = undefined+revParse (Specifier r) = undefined++lookupObject :: Repository -> Oid -> IO (Maybe Object)+lookupObject repo oid =+ lookupObject' repo oid+ (\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 repo coid x)++createObject :: Repository -> COid -> ForeignPtr C'git_object -> C'git_otype+ -> IO Object+createObject repo coid obj typ+ | typ == c'GIT_OBJ_BLOB =+ return $ BlobObj Blob { _blobInfo =+ newBase repo (Right coid) (Just obj)+ , _blobContents = B.empty }++ | typ == c'GIT_OBJ_TREE =+ return $ TreeObj Tree { _treeInfo =+ newBase repo (Right coid) (Just obj)+ , _treeContents = M.empty }++ | otherwise = return undefined++-- Object.hs
+ src/Data/Git/Oid.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleInstances #-}++module Data.Git.Oid+ ( Oid(..)+ , COid(..)+ , Ident+ , compareCOid+ , compareCOidLen+ , equalCOid+ , stringToOid )+ where++import Bindings.Libgit2.Oid+import Control.Exception+import Control.Monad+import Data.ByteString.Unsafe+import Data.Git.Errors+import Data.Git.Stringable+import Foreign.ForeignPtr+import System.IO.Unsafe++newtype COid = COid (ForeignPtr C'git_oid)++instance Show COid where+ show (COid x) =+ toString $ unsafePerformIO $+ withForeignPtr x (unsafePackMallocCString <=< c'git_oid_allocfmt)++type Ident a = Either (a -> IO COid) COid++data Oid = Oid COid+ | PartialOid COid Int+ deriving Show++compareCOid :: COid -> COid -> Ordering+(COid x) `compareCOid` (COid y) =+ let c = unsafePerformIO $+ withForeignPtr x $ \x' ->+ withForeignPtr y $ \y' ->+ c'git_oid_cmp x' y'+ in c `compare` 0++compareCOidLen :: COid -> COid -> Int -> Ordering+compareCOidLen (COid x) (COid y) l =+ let c = unsafePerformIO $+ withForeignPtr x $ \x' ->+ withForeignPtr y $ \y' ->+ c'git_oid_ncmp x' y' (fromIntegral l)+ in c `compare` 0++instance Ord COid where+ compare = compareCOid++equalCOid :: Ord a => a -> a -> Bool+x `equalCOid` y = (x `compare` y) == EQ++instance Eq COid where+ (==) = equalCOid++instance Eq Oid where+ (Oid x) == (Oid y) = x `equalCOid` y+ (PartialOid x xl) == (PartialOid y yl) =+ xl == yl && compareCOidLen x y xl == EQ+ _ == _ = False++stringToOid :: CStringable a => a -> IO (Maybe Oid)+stringToOid str+ | len > 40 = throwIO ObjectIdTooLong+ | otherwise = do+ oid <- mallocForeignPtr+ withCStringable str $ \cstr ->+ withForeignPtr oid $ \ptr -> do+ r <- if len == 40+ then c'git_oid_fromstr ptr cstr+ else c'git_oid_fromstrn ptr cstr (fromIntegral len)+ if r < 0+ then return Nothing+ else return . Just $ if len == 40+ then Oid (COid oid)+ else PartialOid (COid oid) len++ where len = lengthStr str++-- Oid.hs
+ src/Data/Git/Repository.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Repository+ ( Oid+ , Ident+ , ObjPtr++ , Updatable(..)++ , Repository+ , HasRepository(..)++ , openRepository+ , createRepository+ , openOrCreateRepository )+ where++import Data.Git.Internal++-- Repository.hs
+ src/Data/Git/Stringable.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleInstances #-}++module Data.Git.Stringable+ ( Stringable(..)+ , CStringable(..) )+ where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Unsafe as BU+import Data.Either+import qualified Data.Text as T hiding (map)+import qualified Data.Text.Encoding as E+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as EL+import Filesystem.Path.CurrentOS hiding (empty, concat)+import Foreign.C.String+import Prelude hiding (FilePath)++class Stringable a where+ toString :: a -> String+ fromString :: String -> a+ lengthStr :: a -> Int++instance Stringable String where+ toString = id+ fromString = id+ lengthStr = length++instance Stringable T.Text where+ toString = T.unpack+ fromString = T.pack+ lengthStr = T.length++instance Stringable TL.Text where+ toString = TL.unpack+ fromString = TL.pack+ lengthStr = undefined++instance Stringable B.ByteString where+ toString = T.unpack . E.decodeUtf8+ fromString = E.encodeUtf8 . T.pack+ lengthStr = B.length++instance Stringable BL.ByteString where+ toString = TL.unpack . EL.decodeUtf8+ fromString = EL.encodeUtf8 . TL.pack+ lengthStr = undefined++instance Stringable FilePath where+ toString = toString . either id id . toText+ fromString = fromText . T.pack+ lengthStr = undefined++class Stringable a => CStringable a where+ withCStringable :: a -> (CString -> IO b) -> IO b+ withCStringable = withCString . toString++ withCStringLenable :: a -> (CString -> Int -> IO b) -> IO b+ withCStringLenable str f = withCStringLen (toString str) (uncurry f)++instance CStringable String where+ withCStringable = withCString++withByteString :: B.ByteString -> (CString -> IO a) -> IO a+withByteString = BU.unsafeUseAsCString++withByteStringLen :: B.ByteString -> (CString -> Int -> IO a) -> IO a+withByteStringLen str f = BU.unsafeUseAsCStringLen str (uncurry f)++instance CStringable T.Text where+ withCStringable = withCStringable . E.encodeUtf8+ withCStringLenable = withCStringLenable . E.encodeUtf8++instance CStringable TL.Text where+ withCStringable = withCStringable . EL.encodeUtf8+ withCStringLenable = withCStringLenable . EL.encodeUtf8++instance CStringable B.ByteString where+ withCStringable = withByteString+ withCStringLenable = withByteStringLen++instance CStringable BL.ByteString where+ withCStringable = withByteString . B.concat . BL.toChunks+ withCStringLenable = withByteStringLen . B.concat . BL.toChunks++-- Stringable.hs
+ src/Data/Git/Tag.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Tag where++import Control.Lens+import Data.Either+import Data.Git.Common+import Data.Git.Internal+import Data.Text as T hiding (map)+import Prelude hiding (FilePath)++default (Text)++data Tag = Tag { _tagInfo :: Base Tag+ , _tagRef :: Oid }++makeClassy ''Tag++instance Show Tag where+ show x = case x^.tagInfo.gitId of+ Left _ -> "Tag"+ Right y -> "Tag#" ++ show y++-- Tag.hs
+ src/Data/Git/Tree.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Tree where++import Bindings.Libgit2+import Control.Lens+import Data.Either+import Data.Git.Common+import Data.Git.Internal+import Data.Git.Blob+import Data.Git.Errors+import Data.Map as M hiding (map)+import Data.Text as T hiding (map)+import Prelude hiding (FilePath)++default (Text)++type TreeOrBlob = Either Blob Tree+type TreeMap = Map Text TreeOrBlob++data Tree = Tree { _treeInfo :: Base Tree+ , _treeContents :: TreeMap }++makeClassy ''Tree++instance Show Tree where+ show x = case x^.treeInfo.gitId of+ Left _ -> "Tree"+ Right y -> "Tree#" ++ show y++newTreeBase :: Tree -> Base Tree+newTreeBase t = newBase (t^.treeInfo.gitRepo) (Left doWriteTree) Nothing++-- | Create a new tree, starting it with the contents at the given path.+--+-- Note that since empty trees cannot exist in Git, no means is provided for+-- creating one.+createTree :: Repository -> FilePath -> TreeOrBlob -> Tree+createTree repo path item = updateTree path item (emptyTree repo)++doWriteTree :: Tree -> IO COid+doWriteTree = undefined+{-+ alloca $ \ptr ->+ tb <- c'git_treebuilder_create ptr str+ when (r < 0) $ throwIO (RepositoryNotExist p)+ ptr' <- peek ptr+ let finalizer = newForeignPtr p'git_repository_free ptr'+ return $ Repository { _repoPath = path+ , _repoObj = finalizer }+-}++emptyTree :: Repository -> Tree+emptyTree repo =+ Tree { _treeInfo = newBase repo (Left doWriteTree) Nothing+ , _treeContents = M.empty }++doUpdateTree :: [Text] -> TreeOrBlob -> Tree -> Tree+doUpdateTree (x:xs) item t =+ treeInfo .~ newTreeBase t $+ treeContents .~ update' xs $ t++ where repo = t^.treeInfo.gitRepo+ treeMap = t^.treeContents+ update' [] = insert x item treeMap+ update' _ = insert x subTree treeMap+ subTree = Right $ doUpdateTree xs item tree'+ tree' = case M.lookup x treeMap of+ Just (Right m) -> m+ _ -> emptyTree repo+doUpdateTree [] _ _ = undefined++updateTree :: FilePath -> TreeOrBlob -> Tree -> Tree+updateTree = doUpdateTree . splitPath++splitPath :: FilePath -> [Text]+splitPath path = splitOn "/" text+ where text = case toText path of+ Left x -> error $ "Invalid path: " ++ T.unpack x+ Right y -> y++-- Tree.hs
tests/Main.hs view
@@ -1,15 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where-import Bindings.Libgit2-import Foreign-import Foreign.C.String-import System.Exit-import Control.Monad(when)-import System.Process(system) +import Bindings.Libgit2+import Control.Monad+import Data.Foldable+import Data.Git+import Data.Text as T hiding (map)+import Data.Text.IO+import qualified Data.Text.Encoding as E+import Filesystem.Path.CurrentOS+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Storable+import Prelude hiding (FilePath, putStr, putStrLn)+import System.Exit+import System.Process(system)++default (Text)++main :: IO () main = do+ putStrLn "Creating Git repository..."++ _ <- system "git init smoke.git"++ putStrLn "Accessing directly..."+ alloca $ \ptr -> do- system "git init smoke.git" withCString "smoke.git/.git" $ \str -> do r <- c'git_repository_open ptr str- when (r < 0) $ exitWith (ExitFailure 1) + when (r < 0) $ exitWith (ExitFailure 1) peek ptr >>= c'git_repository_free++ putStrLn "Accessing via higher-level types..."++ repo <- openRepository (fromText "smoke.git/.git")+ update_ $ createBlob repo (E.encodeUtf8 "Hello, world!\n")++ putStrLn "Looking up Blob by its full SHA..."+ catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b"++ putStrLn "Looking up Blob by its short SHA..."+ catBlob repo "af5626b"++catBlob :: Repository -> Text -> IO ()+catBlob repo sha = do+ hash <- stringToOid sha+ print hash+ for_ hash $ \hash' -> do+ obj <- lookupObject repo hash'+ case obj of+ Just (BlobObj b) -> do+ putStrLn "Found a blob, contents: "+ (_, contents) <- getBlobContents b+ putStr (E.decodeUtf8 contents)++ Just _ -> error "Found something else..."+ Nothing -> error "Didn't find anything :("++-- Main.hs ends here