gitlib 0.1.0 → 0.2.0
raw patch · 7 files changed
+81/−45 lines, 7 files
Files
- Data/Git/Blob.hs +3/−1
- Data/Git/Errors.hs +2/−0
- Data/Git/Internal.hs +3/−2
- Data/Git/Oid.hs +4/−1
- Data/Git/Tree.hs +62/−34
- gitlib.cabal +1/−1
- tests/Main.hs +6/−6
Data/Git/Blob.hs view
@@ -31,7 +31,9 @@ instance Updatable Blob where update = writeBlob- objectId = undefined+ objectId b = case b^.blobInfo.gitId of+ Left f -> Oid <$> (f b)+ Right x -> return $ Oid x -- | Create a new blob in the 'Repository', with 'ByteString' as its contents. --
Data/Git/Errors.hs view
@@ -13,6 +13,8 @@ | BlobCreateFailed | TreeCreateFailed | TreeBuilderCreateFailed+ | TreeBuilderInsertFailed+ | TreeBuilderWriteFailed | ObjectLookupFailed | ObjectIdTooLong | OidCopyFailed
Data/Git/Internal.hs view
@@ -60,9 +60,10 @@ type ObjPtr a = Maybe (ForeignPtr a) class Updatable a where- update :: a -> IO a+ update :: a -> IO a update_ :: a -> IO ()- update_ x = void (update x)+ update_ = void . update+ objectId :: a -> IO Oid data Repository = Repository { _repoPath :: FilePath
Data/Git/Oid.hs view
@@ -30,7 +30,10 @@ data Oid = Oid COid | PartialOid COid Int- deriving Show++instance Show Oid where+ show (Oid x) = show x+ show (PartialOid x l) = take l $ show x compareCOid :: COid -> COid -> Ordering (COid x) `compareCOid` (COid y) =
Data/Git/Tree.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-} module Data.Git.Tree where @@ -14,13 +15,16 @@ import qualified Data.Map as M hiding (map) import Data.Text as T hiding (map) import Filesystem.Path.CurrentOS as F-import Prelude hiding (FilePath)+import Prelude hiding (FilePath, sequence) default (Text) -type TreeOrBlob = Either Blob Tree-type TreeMap = M.Map Text TreeOrBlob+data TreeEntry = BlobEntry { blobEntry :: Blob+ , blobEntryIsExe :: Bool }+ | TreeEntry { treeEntry :: Tree } +type TreeMap = M.Map Text TreeEntry+ data Tree = Tree { _treeInfo :: Base Tree , _treeContents :: TreeMap } @@ -33,17 +37,19 @@ instance Updatable Tree where update = writeTree- --objectId t = return $ t^.treeInfo.gitId- objectId t = undefined+ objectId t = case t^.treeInfo.gitId of+ Left f -> Oid <$> (f t)+ Right x -> return $ Oid x newTreeBase :: Tree -> Base Tree-newTreeBase t = newBase (t^.treeInfo.gitRepo) (Left doWriteTree) Nothing+newTreeBase t =+ newBase (t^.treeInfo.gitRepo) (Left (doWriteTree >=> return . snd)) 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 :: Repository -> FilePath -> TreeEntry -> Tree createTree repo path item = updateTree path item (emptyTree repo) lookupTree :: Repository -> Oid -> IO (Maybe Tree)@@ -58,38 +64,60 @@ -- nothing will happen. writeTree :: Tree -> IO Tree writeTree t@(Tree { _treeInfo = Base { _gitId = Right _ } }) = return t-writeTree t = do hash <- doWriteTree t- return $ treeInfo.gitId .~ Right hash $ t+writeTree t = fst <$> doWriteTree t -doWriteTree :: Tree -> IO COid-doWriteTree t = do- ptr <- mallocForeignPtr- r <- withForeignPtr repo (createFromTreeMap ptr)- -- when (r < 0) $ throwIO TreeCreateFailed- return (COid ptr)+doWriteTree :: Tree -> IO (Tree, COid)+doWriteTree t = alloca $ \ptr ->+ withForeignPtr repo $ \repoPtr -> do+ r <- c'git_treebuilder_create ptr nullPtr+ when (r < 0) $ throwIO TreeBuilderCreateFailed+ builder <- peek ptr - where repo = fromMaybe (error "Repository invalid") $- t^.treeInfo.gitRepo.repoObj+ newList <-+ for (M.toList (t^.treeContents)) $ \(k, v) -> do+ newObj <-+ case v of+ BlobEntry bl exe ->+ flip BlobEntry exe <$>+ insertObject builder k bl (if exe+ then 0o100755+ else 0o100644)+ TreeEntry tr ->+ TreeEntry <$> insertObject builder k tr 0o040000+ return (k, newObj) -createFromTreeMap t repoPtr = alloca $ \ptr -> do- r <- c'git_treebuilder_create ptr nullPtr- when (r < 0) $ throwIO TreeBuilderCreateFailed- builder <- peek ptr- return undefined-{-- for (M.toList (t^.treeContents)) $ \k v -> do- v' <- update v -- make sure the object is updated- oid <- objectId v'- withCStringable k $ \name ->- c'git_treebuilder_insert nullPtr builder name oid 0--}+ coid <- mallocForeignPtr+ withForeignPtr coid $ \coid' -> do+ r3 <- c'git_treebuilder_write coid' repoPtr builder+ when (r3 < 0) $ throwIO TreeBuilderWriteFailed + return (treeInfo.gitId .~ Right (COid coid) $+ treeContents .~ M.fromList newList $ t, COid coid)++ where+ repo = fromMaybe (error "Repository invalid") $+ t^.treeInfo.gitRepo.repoObj++ insertObject :: (CStringable a, Updatable b)+ => Ptr C'git_treebuilder -> a -> b -> CUInt -> IO b+ insertObject builder key obj attrs = do+ obj' <- update obj+ Oid (COid coid) <- objectId obj'++ withForeignPtr coid $ \coid' ->+ withCStringable key $ \name -> do+ r2 <- c'git_treebuilder_insert nullPtr builder name coid' attrs+ when (r2 < 0) $ throwIO TreeBuilderInsertFailed++ return obj'+ emptyTree :: Repository -> Tree emptyTree repo =- Tree { _treeInfo = newBase repo (Left doWriteTree) Nothing+ Tree { _treeInfo =+ newBase repo (Left (doWriteTree >=> return . snd)) Nothing , _treeContents = M.empty } -doUpdateTree :: [Text] -> TreeOrBlob -> Tree -> Tree+doUpdateTree :: [Text] -> TreeEntry -> Tree -> Tree doUpdateTree (x:xs) item t = treeInfo .~ newTreeBase t $ treeContents .~ update' xs $ t@@ -98,13 +126,13 @@ treeMap = t^.treeContents update' [] = M.insert x item treeMap update' _ = M.insert x subTree treeMap- subTree = Right $ doUpdateTree xs item tree'+ subTree = TreeEntry $ doUpdateTree xs item tree' tree' = case M.lookup x treeMap of- Just (Right m) -> m+ Just (TreeEntry m) -> m _ -> emptyTree repo doUpdateTree [] _ _ = undefined -updateTree :: FilePath -> TreeOrBlob -> Tree -> Tree+updateTree :: FilePath -> TreeEntry -> Tree -> Tree updateTree = doUpdateTree . splitPath splitPath :: FilePath -> [Text]
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 0.1.0+Version: 0.2.0 Synopsis: Higher-level types for working with hlibgit2 Description: Higher-level types for working with hlibgit2 License-file: LICENSE
tests/Main.hs view
@@ -2,19 +2,14 @@ module Main where -import Control.Monad import Data.Foldable import Data.Git+import Data.Monoid 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) @@ -23,6 +18,11 @@ putStrLn "Accessing via higher-level types..." repo <- createRepository (fromText "smoke.git") True update_ $ createBlob repo (E.encodeUtf8 "Hello, world!\n")++ let bl = createBlob repo (E.encodeUtf8 "Goodbye, world!\n")+ tr = createTree repo "hello/world.txt" (BlobEntry bl False)+ oid <- objectId tr+ putStrLn $ "Wrote tree: " <> T.pack (show oid) putStrLn "Looking up Blob by its full SHA..." catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b"