diff --git a/Data/Git/Blob.hs b/Data/Git/Blob.hs --- a/Data/Git/Blob.hs +++ b/Data/Git/Blob.hs @@ -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. -- diff --git a/Data/Git/Errors.hs b/Data/Git/Errors.hs --- a/Data/Git/Errors.hs +++ b/Data/Git/Errors.hs @@ -13,6 +13,8 @@ | BlobCreateFailed | TreeCreateFailed | TreeBuilderCreateFailed + | TreeBuilderInsertFailed + | TreeBuilderWriteFailed | ObjectLookupFailed | ObjectIdTooLong | OidCopyFailed diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs --- a/Data/Git/Internal.hs +++ b/Data/Git/Internal.hs @@ -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 diff --git a/Data/Git/Oid.hs b/Data/Git/Oid.hs --- a/Data/Git/Oid.hs +++ b/Data/Git/Oid.hs @@ -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) = diff --git a/Data/Git/Tree.hs b/Data/Git/Tree.hs --- a/Data/Git/Tree.hs +++ b/Data/Git/Tree.hs @@ -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] diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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"