gitlib 0.4.1 → 0.5.0
raw patch · 16 files changed
+544/−479 lines, 16 filesdep +HTFdep +parallel-iodep ~basedep ~hlibgit2
Dependencies added: HTF, parallel-io
Dependency ranges changed: base, hlibgit2
Files
- Data/Git/Blob.hs +23/−26
- Data/Git/Commit.hs +51/−53
- Data/Git/Common.hs +15/−18
- Data/Git/Internal.hs +22/−24
- Data/Git/Object.hs +6/−6
- Data/Git/Oid.hs +4/−0
- Data/Git/Reference.hs +60/−24
- Data/Git/Repository.hs +0/−3
- Data/Git/Tag.hs +3/−7
- Data/Git/Tree.hs +91/−64
- gitlib.cabal +25/−16
- test/Doctest.hs +29/−0
- test/Main.hs +0/−209
- test/Smoke.hs +206/−0
- test/Unit.hs +9/−0
- test/doctests.hs +0/−29
Data/Git/Blob.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Git.Blob- ( Blob(..), HasBlob(..)+ ( Blob(..) , newBlobBase , createBlob , getBlobContents@@ -18,26 +17,24 @@ default (Text) -data Blob = Blob { _blobInfo :: Base Blob- , _blobContents :: B.ByteString }--makeClassy ''Blob+data Blob = Blob { blobInfo :: Base Blob+ , blobContents :: B.ByteString } instance Show Blob where- show x = case x^.blobInfo.gitId of+ show x = case gitId (blobInfo x) of Pending _ -> "Blob" Stored y -> "Blob#" ++ show y instance Updatable Blob where- getId x = x^.blobInfo.gitId- objectRepo x = x^.blobInfo.gitRepo- objectPtr x = x^.blobInfo.gitObj+ getId x = gitId (blobInfo x)+ objectRepo x = gitRepo (blobInfo x)+ objectPtr x = gitObj (blobInfo x) update = writeBlob lookupFunction = lookupBlob newBlobBase :: Blob -> Base Blob newBlobBase b =- newBase (b^.blobInfo.gitRepo) (Pending doWriteBlob) Nothing+ newBase (gitRepo (blobInfo b)) (Pending doWriteBlob) Nothing -- | Create a new blob in the 'Repository', with 'ByteString' as its contents. --@@ -47,32 +44,32 @@ createBlob text repo | text == B.empty = error "Cannot create an empty blob" | otherwise =- Blob { _blobInfo = newBase repo (Pending doWriteBlob) Nothing- , _blobContents = text }+ Blob { blobInfo = newBase repo (Pending doWriteBlob) Nothing+ , blobContents = 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 }+ return Blob { blobInfo = newBase repo (Stored coid) (Just obj)+ , blobContents = B.empty } getBlobContents :: Blob -> IO (Blob, B.ByteString) getBlobContents b =- case b^.blobInfo.gitId of- Pending _ -> return $ (b, contents)+ case gitId (blobInfo b) of+ Pending _ -> return (b, contents) Stored hash -> if contents /= B.empty then return (b, contents) else- case b^.blobInfo.gitObj of+ 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 (blobContents .~ bstr $ b, bstr)+ return (b { blobContents = bstr }, bstr) Nothing -> do b' <- lookupBlob (Oid hash) repo@@ -80,16 +77,16 @@ Just blobPtr' -> getBlobContents blobPtr' Nothing -> return (b, B.empty) - where repo = b^.blobInfo.gitRepo- contents = b^.blobContents+ where repo = gitRepo (blobInfo b)+ contents = blobContents b -- | 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 = Stored _ } }) = return b+writeBlob b@(Blob { blobInfo = Base { gitId = Stored _ } }) = return b writeBlob b = do hash <- doWriteBlob b- return $ blobInfo.gitId .~ Stored hash $- blobContents .~ B.empty $ b+ return b { blobInfo = (blobInfo b) { gitId = Stored hash }+ , blobContents = B.empty } doWriteBlob :: Blob -> IO COid doWriteBlob b = do@@ -100,10 +97,10 @@ where repo = fromMaybe (error "Repository invalid")- (b^.blobInfo.gitRepo.repoObj)+ (repoObj (gitRepo (blobInfo b))) createFromBuffer ptr repoPtr =- unsafeUseAsCStringLen (b^.blobContents) $+ unsafeUseAsCStringLen (blobContents b) $ uncurry (\cstr len -> withForeignPtr ptr $ \ptr' -> c'git_blob_create_frombuffer
Data/Git/Commit.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Git.Commit where @@ -20,32 +19,30 @@ default (Text) -data Commit = Commit { _commitInfo :: Base Commit- , _commitAuthor :: Signature- , _commitCommitter :: Signature- , _commitLog :: Text- , _commitEncoding :: Prelude.String- , _commitTree :: ObjRef Tree- , _commitParents :: [ObjRef Commit]- , _commitObj :: ObjPtr C'git_commit }--makeClassy ''Commit+data Commit = Commit { commitInfo :: Base Commit+ , commitAuthor :: Signature+ , commitCommitter :: Signature+ , commitLog :: Text+ , commitEncoding :: Prelude.String+ , commitTree :: ObjRef Tree+ , commitParents :: [ObjRef Commit]+ , commitObj :: ObjPtr C'git_commit } instance Show Commit where- show x = case x^.commitInfo.gitId of+ show x = case gitId (commitInfo x) of Pending _ -> "Commit" Stored y -> "Commit#" ++ show y instance Updatable Commit where- getId x = x^.commitInfo.gitId- objectRepo x = x^.commitInfo.gitRepo- objectPtr x = x^.commitInfo.gitObj+ getId x = gitId (commitInfo x)+ objectRepo x = gitRepo (commitInfo x)+ objectPtr x = gitObj (commitInfo x) update = writeCommit Nothing lookupFunction = lookupCommit newCommitBase :: Commit -> Base Commit newCommitBase t =- newBase (t^.commitInfo.gitRepo)+ newBase (gitRepo (commitInfo t)) (Pending (doWriteCommit Nothing >=> return . snd)) Nothing -- | Create a new, empty commit.@@ -54,16 +51,16 @@ -- commit is a no-op. createCommit :: Repository -> Commit createCommit repo =- Commit { _commitInfo =- newBase repo (Pending (doWriteCommit Nothing >=> return . snd))- Nothing- , _commitAuthor = createSignature- , _commitCommitter = createSignature- , _commitTree = ObjRef (createTree repo)- , _commitParents = []- , _commitLog = T.empty- , _commitEncoding = ""- , _commitObj = Nothing }+ Commit { commitInfo =+ newBase repo (Pending (doWriteCommit Nothing >=> return . snd))+ Nothing+ , commitAuthor = createSignature+ , commitCommitter = createSignature+ , commitTree = ObjRef (createTree repo)+ , commitParents = []+ , commitLog = T.empty+ , commitEncoding = ""+ , commitObj = Nothing } lookupCommit :: Oid -> Repository -> IO (Maybe Commit) lookupCommit oid repo =@@ -90,19 +87,19 @@ (c'git_commit_parent_oid c)) [0..pn]) - return Commit { _commitInfo = newBase repo (Stored coid) (Just obj)- , _commitAuthor = auth- , _commitCommitter = comm- , _commitTree = toid- , _commitParents = poids- , _commitLog = U.toUnicode conv msg- , _commitEncoding = encs- , _commitObj = Just $ unsafeCoerce obj }+ return Commit { commitInfo = newBase repo (Stored coid) (Just obj)+ , commitAuthor = auth+ , commitCommitter = comm+ , commitTree = toid+ , commitParents = poids+ , commitLog = U.toUnicode conv msg+ , commitEncoding = encs+ , commitObj = Just $ unsafeCoerce obj } -- | Write out a commit to its repository. If it has already been written, -- nothing will happen. writeCommit :: Maybe Text -> Commit -> IO Commit-writeCommit _ c@(Commit { _commitInfo = Base { _gitId = Stored _ } }) =+writeCommit _ c@(Commit { commitInfo = Base { gitId = Stored _ } }) = return c writeCommit ref c = fst <$> doWriteCommit ref c @@ -111,29 +108,30 @@ coid <- withForeignPtr repo $ \repoPtr -> do coid <- mallocForeignPtr withForeignPtr coid $ \coid' -> do- conv <- U.open (c^.commitEncoding) (Just True)- BS.useAsCString (U.fromUnicode conv (c^.commitLog)) $ \message ->+ conv <- U.open (commitEncoding c) (Just True)+ BS.useAsCString (U.fromUnicode conv (commitLog c)) $ \message -> withRef ref $ \update_ref ->- withSignature conv (c^.commitAuthor) $ \author ->- withSignature conv (c^.commitCommitter) $ \committer ->- withEncStr (c^.commitEncoding) $ \message_encoding ->- withGitTree (c^.commitTree) c $ \commit_tree -> do+ withSignature conv (commitAuthor c) $ \author ->+ withSignature conv (commitCommitter c) $ \committer ->+ withEncStr (commitEncoding c) $ \message_encoding ->+ withGitTree (commitTree c) c $ \commit_tree -> do parentPtrs <- getCommitParentPtrs c parents <- newArray $ map FU.unsafeForeignPtrToPtr parentPtrs r <- c'git_commit_create coid' repoPtr update_ref author committer message_encoding message commit_tree- (fromIntegral (length (c^.commitParents)))+ (fromIntegral (length (commitParents c))) parents when (r < 0) $ throwIO CommitCreateFailed return coid - return (commitInfo.gitId .~ Stored (COid coid) $ c, COid coid)+ return (c { commitInfo = (commitInfo c) { gitId = Stored (COid coid) } }+ , COid coid) where repo = fromMaybe (error "Repository invalid")- (c^.commitInfo.gitRepo.repoObj)+ (repoObj (gitRepo (commitInfo c))) withRef refName = if isJust refName@@ -151,14 +149,14 @@ case parent of Nothing -> error "Cannot find Git commit" Just p' -> return p')- (c^.commitParents)+ (commitParents c) getCommitParentPtrs :: Commit -> IO [ForeignPtr C'git_commit] getCommitParentPtrs c = withForeignPtr (repositoryPtr (objectRepo c)) $ \repoPtr ->- for (c^.commitParents) $ \p ->+ for (commitParents c) $ \p -> case p of- ObjRef (Commit { _commitObj = Just obj }) -> return obj+ ObjRef (Commit { commitObj = Just obj }) -> return obj _ -> do Oid (COid oid) <- case p of@@ -176,27 +174,27 @@ :: FilePath -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool -> Commit -> IO (Either a Commit) modifyCommitTree path f createIfNotExist c =- withObject (c^.commitTree) c $ \tr -> do+ withObject (commitTree c) c $ \tr -> do result <- modifyTree path f createIfNotExist tr case result of Left x -> return (Left x)- Right tr' -> return $ Right $ commitTree .~ ObjRef tr' $ c+ Right tr' -> return $ Right $ c { commitTree = ObjRef tr' } removeFromCommitTree :: FilePath -> Commit -> IO Commit removeFromCommitTree path c =- withObject (c^.commitTree) c $ \tr -> do+ withObject (commitTree c) c $ \tr -> do tr' <- removeFromTree path tr- return $ commitTree .~ ObjRef tr' $ c+ return c { commitTree = ObjRef tr' } doUpdateCommit :: [Text] -> TreeEntry -> Commit -> IO Commit doUpdateCommit xs item c = do- t <- loadObject (c^.commitTree) c+ t <- loadObject (commitTree c) c case t of Nothing -> error "Failed to load tree for commit" Just t' -> do tr <- doModifyTree xs (const (Right (Just item))) True t' case tr of- Right tr' -> return $ commitTree .~ ObjRef tr' $ c+ Right tr' -> return c { commitTree = ObjRef tr' } _ -> undefined updateCommit :: FilePath -> TreeEntry -> Commit -> IO Commit
Data/Git/Common.hs view
@@ -1,16 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Git.Common- ( Signature(..), HasSignature(..)+ ( Signature(..) , createSignature , packSignature , withSignature- , Base(..), gitId, gitRepo++ , Base(..) , newBase ) where -import Control.Lens import qualified Data.ByteString as BS import Data.Git.Internal import qualified Data.Text as T@@ -22,13 +21,11 @@ default (Text) -data Signature = Signature { _signatureName :: Text- , _signatureEmail :: Text- , _signatureWhen :: UTCTime }+data Signature = Signature { signatureName :: Text+ , signatureEmail :: Text+ , signatureWhen :: UTCTime } deriving (Show, Eq) -makeClassy ''Signature- -- | Convert a time in seconds (from Stripe's servers) to 'UTCTime'. See -- "Data.Time.Format" for more on working with 'UTCTime'. fromSeconds :: Integer -> UTCTime@@ -50,9 +47,9 @@ createSignature :: Signature createSignature =- Signature { _signatureName = T.empty- , _signatureEmail = T.empty- , _signatureWhen =+ Signature { signatureName = T.empty+ , signatureEmail = T.empty+ , signatureWhen = UTCTime { utctDay = ModifiedJulianDay { toModifiedJulianDay = 0 }@@ -64,18 +61,18 @@ email <- peek (p'git_signature'email sig) >>= BS.packCString time <- peekGitTime (p'git_signature'when sig) return $- Signature { _signatureName = U.toUnicode conv name- , _signatureEmail = U.toUnicode conv email- , _signatureWhen = time }+ Signature { signatureName = U.toUnicode conv name+ , signatureEmail = U.toUnicode conv email+ , signatureWhen = time } withSignature :: U.Converter -> Signature -> (Ptr C'git_signature -> IO a) -> IO a withSignature conv sig f =- BS.useAsCString (U.fromUnicode conv (sig^.signatureName)) $ \nameCStr ->- BS.useAsCString (U.fromUnicode conv (sig^.signatureEmail)) $ \emailCStr ->+ BS.useAsCString (U.fromUnicode conv (signatureName sig)) $ \nameCStr ->+ BS.useAsCString (U.fromUnicode conv (signatureEmail sig)) $ \emailCStr -> alloca $ \ptr -> do poke ptr (C'git_signature nameCStr emailCStr- (packGitTime (sig^.signatureWhen)))+ (packGitTime (signatureWhen sig))) f ptr -- Common.hs
Data/Git/Internal.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,12 +8,9 @@ , Updatable(..) - , Base(..), gitId, gitRepo, gitObj- , newBase-- , Repository- , HasRepository(..)+ , Base(..), newBase + , Repository(..) , openRepository , createRepository , openOrCreateRepository@@ -31,7 +27,6 @@ import Control.Applicative as X import Control.Category as X import Control.Exception as X-import Control.Lens as X import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_, forM, forM_, msum) import Data.Bool as X@@ -85,6 +80,13 @@ Pending f -> Oid <$> f x Stored y -> return $ Oid y + objectRef :: a -> IO (ObjRef a)+ objectRef x = do+ oid <- objectId x+ case oid of+ Oid coid -> return (IdRef coid)+ PartialOid _ _ -> error "Did not expect to see a PartialOid"+ maybeObjectId :: a -> Maybe Oid maybeObjectId x = case getId x of Pending _ -> Nothing@@ -100,32 +102,28 @@ getObject (IdRef _) = Nothing getObject (ObjRef x) = Just x -data Repository = Repository { _repoPath :: FilePath- , _repoObj :: ObjPtr C'git_repository }--makeClassy ''Repository+data Repository = Repository { repoPath :: FilePath+ , repoObj :: ObjPtr C'git_repository } instance Show Repository where- show x = "Repository " <> toString (x^.repoPath)+ show x = "Repository " <> toString (repoPath x) -data Base a = Base { _gitId :: Ident a- , _gitRepo :: Repository- , _gitObj :: ObjPtr C'git_object }--makeLenses ''Base+data Base a = Base { gitId :: Ident a+ , gitRepo :: Repository+ , gitObj :: ObjPtr C'git_object } instance Show (Base a) where- show x = case x^.gitId of+ show x = case gitId x of Pending _ -> "Base" Stored 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 }+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)+repositoryPtr repo = fromMaybe (error "Repository invalid") (repoObj repo) openRepository :: FilePath -> IO Repository openRepository path =@@ -154,8 +152,8 @@ when (r < 0) $ doesNotExist p ptr' <- peek ptr fptr <- newForeignPtr p'git_repository_free ptr'- return Repository { _repoPath = path- , _repoObj = Just fptr }+ return Repository { repoPath = path+ , repoObj = Just fptr } where doesNotExist = throwIO . RepositoryNotExist . toString
Data/Git/Object.hs view
@@ -48,14 +48,14 @@ -> IO Object createObject coid obj repo typ | typ == c'GIT_OBJ_BLOB =- return $ BlobObj Blob { _blobInfo =- newBase repo (Stored coid) (Just obj)- , _blobContents = B.empty }+ return $ BlobObj Blob { blobInfo =+ newBase repo (Stored coid) (Just obj)+ , blobContents = B.empty } | typ == c'GIT_OBJ_TREE =- return $ TreeObj Tree { _treeInfo =- newBase repo (Stored coid) (Just obj)- , _treeContents = M.empty }+ return $ TreeObj Tree { treeInfo =+ newBase repo (Stored coid) (Just obj)+ , treeContents = M.empty } | otherwise = return undefined
Data/Git/Oid.hs view
@@ -56,6 +56,10 @@ data Ident a = Pending (a -> IO COid) | Stored COid +instance Show (Ident a) where+ show (Pending _) = "Pending"+ show (Stored coid) = show coid+ -- | 'Oid' represents either a full or partial SHA1 hash code used to identify -- Git objects. data Oid = Oid COid
Data/Git/Reference.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Git.Reference ( RefTarget(..)- , Reference(..), HasReference(..)-+ , Reference(..) , createRef , lookupRef+ , listRefNames+ , listAll , lookupId , writeRef , writeRef_ )@@ -18,6 +18,9 @@ import Data.Git.Internal import Data.Git.Object import qualified Prelude+import Prelude ((+),(-))+import qualified Data.Text as T+import Foreign.Marshal.Array default (Text) @@ -25,23 +28,21 @@ | RefTargetSymbolic Text deriving (Show, Eq) -data Reference = Reference { _refRepo :: Repository- , _refName :: Text- , _refTarget :: RefTarget- , _refObj :: ObjPtr C'git_reference }+data Reference = Reference { refRepo :: Repository+ , refName :: Text+ , refTarget :: RefTarget+ , refObj :: ObjPtr C'git_reference } deriving Show -makeClassy ''Reference- -- int git_reference_lookup(git_reference **reference_out, -- git_repository *repo, const char *name) createRef :: Text -> RefTarget -> Repository -> Reference createRef name target repo =- Reference { _refRepo = repo- , _refName = name- , _refTarget = target- , _refObj = Nothing }+ Reference { refRepo = repo+ , refName = name+ , refTarget = target+ , refObj = Nothing } lookupRef :: Text -> Repository -> IO (Maybe Reference) lookupRef name repo = alloca $ \ptr -> do@@ -53,16 +54,16 @@ else do ref <- peek ptr fptr <- newForeignPtr p'git_reference_free ref- return $ Just $ Reference { _refRepo = repo- , _refName = name- , _refTarget = undefined- , _refObj = Just fptr }+ return $ Just $ Reference { refRepo = repo+ , refName = name+ , refTarget = undefined+ , refObj = Just fptr } writeRef :: Reference -> IO Reference writeRef ref = alloca $ \ptr -> do withForeignPtr repo $ \repoPtr ->- withCStringable (ref^.refName) $ \namePtr -> do- r <- case ref^.refTarget of+ withCStringable (refName ref) $ \namePtr -> do+ r <- case refTarget ref of RefTargetId (PartialOid {}) -> throwIO RefCannotCreateFromPartialOid @@ -78,10 +79,10 @@ when (r < 0) $ throwIO ReferenceCreateFailed fptr <- newForeignPtr_ =<< peek ptr- return $ refObj .~ Just fptr $ ref+ return ref { refObj = Just fptr } where- repo = fromMaybe (error "Repository invalid") (ref^.refRepo.repoObj)+ repo = fromMaybe (error "Repository invalid") (repoObj (refRepo ref)) writeRef_ :: Reference -> IO () writeRef_ = void . writeRef@@ -98,7 +99,7 @@ Oid <$> COid <$> newForeignPtr_ ptr where- repo = fromMaybe (error "Repository invalid") (repos^.repoObj)+ repo = fromMaybe (error "Repository invalid") (repoObj repos) -- int git_reference_create_symbolic(git_reference **ref_out, -- git_repository *repo, const char *name, const char *target, int force)@@ -151,8 +152,43 @@ --packallRefs = c'git_reference_packall --- int git_reference_list(git_strarray *array, git_repository *repo,--- unsigned int list_flags)+data ListFlags = ListFlags { invalid :: Bool+ , oid :: Bool+ , symbolic :: Bool+ , packed :: Bool+ , hasPeel :: Bool }+ deriving Show++listAll :: ListFlags+listAll = ListFlags { invalid = False+ , oid = True+ , symbolic = True+ , packed = True+ , hasPeel = 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++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 ->+ withForeignPtr (repositoryPtr repo) $ \repoPtr -> do+ r <- c'git_reference_list c'refs repoPtr intFlags+ when (r < 0) $ throwIO ReferenceLookupFailed++ refs <- gitStrArray2List c'refs+ c'git_strarray_free c'refs+ return refs --listRefs = c'git_reference_list
Data/Git/Repository.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} -- | Interface for opening and creating repositories. Repository objects are -- immutable, and serve only to refer to the given repository. Any data@@ -11,8 +10,6 @@ , Updatable(..) , Repository- , HasRepository(..)- , openRepository , createRepository , openOrCreateRepository
Data/Git/Tag.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Git.Tag where -import Control.Lens import Data.Git.Common import Data.Git.Internal import qualified Data.Text as T@@ -11,13 +9,11 @@ default (Text) -data Tag = Tag { _tagInfo :: Base Tag- , _tagRef :: Oid }--makeClassy ''Tag+data Tag = Tag { tagInfo :: Base Tag+ , tagRef :: Oid } instance Show Tag where- show x = case x^.tagInfo.gitId of+ show x = case gitId (tagInfo x) of Pending _ -> "Tag" Stored y -> "Tag#" ++ show y
Data/Git/Tree.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module Data.Git.Tree where import Bindings.Libgit2+import Control.Concurrent.ParallelIO import Data.Git.Blob import Data.Git.Common import Data.Git.Errors@@ -49,26 +49,28 @@ type TreeMap = M.Map Text TreeEntry -data Tree = Tree { _treeInfo :: Base Tree- , _treeContents :: TreeMap }--makeClassy ''Tree+data Tree = Tree { treeInfo :: Base Tree+ , treeContents :: TreeMap } instance Show Tree where- show x = case x^.treeInfo.gitId of+ show x = case gitId (treeInfo x) of Pending _ -> "Tree" Stored y -> "Tree#" ++ show y +instance Show TreeEntry where+ show be@(BlobEntry {}) = show be+ show te@(TreeEntry {}) = show te+ instance Updatable Tree where- getId x = x^.treeInfo.gitId- objectRepo x = x^.treeInfo.gitRepo- objectPtr x = x^.treeInfo.gitObj+ getId x = gitId (treeInfo x)+ objectRepo x = gitRepo (treeInfo x)+ objectPtr x = gitObj (treeInfo x) update = writeTree lookupFunction = lookupTree newTreeBase :: Tree -> Base Tree newTreeBase t =- newBase (t^.treeInfo.gitRepo)+ newBase (gitRepo (treeInfo t)) (Pending (doWriteTree >=> return . snd)) Nothing -- | Create a new, empty tree.@@ -77,26 +79,51 @@ -- tree is a no-op. createTree :: Repository -> Tree createTree repo =- Tree { _treeInfo =+ Tree { treeInfo = newBase repo (Pending (doWriteTree >=> return . snd)) Nothing- , _treeContents = M.empty }+ , treeContents = M.empty } lookupTree :: Oid -> Repository -> IO (Maybe Tree) lookupTree oid repo = lookupObject' oid repo c'git_tree_lookup c'git_tree_lookup_prefix $- \coid obj _ ->- return Tree { _treeInfo =+ \coid obj _ -> do+ entriesMap <- withForeignPtr obj $ \treePtr -> do+ entryCount <- c'git_tree_entrycount (castPtr treePtr)+ foldM+ (\m idx -> do+ entry <- c'git_tree_entry_byindex (castPtr treePtr)+ (fromIntegral idx)+ entryId <- c'git_tree_entry_id entry+ coid <- mallocForeignPtr+ withForeignPtr coid $ \coid' ->+ c'git_oid_cpy coid' entryId++ entryName <- c'git_tree_entry_name entry+ >>= peekCString >>= return . T.pack+ entryAttrs <- c'git_tree_entry_attributes entry+ entryType <- c'git_tree_entry_type entry++ let entryObj = if entryType == c'GIT_OBJ_BLOB+ then BlobEntry (IdRef (COid coid)) False+ else TreeEntry (IdRef (COid coid))++ return $ M.insert entryName entryObj m)+ M.empty [1..entryCount]+ return Tree { treeInfo = newBase repo (Stored coid) (Just obj)- , _treeContents = M.empty }+ , treeContents = entriesMap } doLookupTreeEntry :: [Text] -> Tree -> IO (Maybe TreeEntry)-doLookupTreeEntry [] _ = throw TreeEntryLookupFailed+doLookupTreeEntry [] t = return (Just (TreeEntry (ObjRef t))) doLookupTreeEntry (name:names) t = 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 <- case M.lookup name (t^.treeContents) of+ Prelude.putStrLn $ "Tree: " ++ show t+ Prelude.putStrLn $ "Tree Entries: " ++ show (treeContents t)+ Prelude.putStrLn $ "Lookup: " ++ toString name+ y <- case M.lookup name (treeContents t) of Nothing -> return Nothing Just j -> case j of BlobEntry b mode -> do@@ -106,13 +133,15 @@ tr <- loadObject t' t for tr $ \x -> return $ TreeEntry (ObjRef x) + Prelude.putStrLn $ "Result: " ++ show y+ Prelude.putStrLn $ "Names: " ++ show names if null names then return y else case y of Just (BlobEntry {}) -> throw TreeCannotTraverseBlob Just (TreeEntry (ObjRef t')) -> doLookupTreeEntry names t'- _ -> throw TreeEntryLookupFailed+ _ -> return Nothing lookupTreeEntry :: FilePath -> Tree -> IO (Maybe TreeEntry) lookupTreeEntry = doLookupTreeEntry . splitPath@@ -124,10 +153,10 @@ case tref of IdRef (COid oid) -> withGitTreeOid repoPtr oid - ObjRef (Tree { _treeInfo = Base { _gitId = Stored (COid oid) } }) ->+ ObjRef (Tree { treeInfo = Base { gitId = Stored (COid oid) } }) -> withGitTreeOid repoPtr oid - ObjRef (Tree { _treeInfo = Base { _gitObj = Just t } }) ->+ ObjRef (Tree { treeInfo = Base { gitObj = Just t } }) -> withForeignPtr t (f . castPtr) ObjRef t -> do t' <- update t@@ -143,7 +172,7 @@ -- | Write out a tree to its repository. If it has already been written, -- nothing will happen. writeTree :: Tree -> IO Tree-writeTree t@(Tree { _treeInfo = Base { _gitId = Stored _ } }) = return t+writeTree t@(Tree { treeInfo = Base { gitId = Stored _ } }) = return t writeTree t = fst <$> doWriteTree t doWriteTree :: Tree -> IO (Tree, COid)@@ -153,50 +182,48 @@ when (r < 0) $ throwIO TreeBuilderCreateFailed builder <- peek ptr - 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)+ -- jww (2012-10-14): With the loose object backend, there should be no+ -- race conditions here as there will never be a request to access the+ -- same file by multiple threads. If that ever does happen, or if this+ -- code is changed to write to the packed object backend, simply change+ -- the function 'parallel' to 'sequence' here.+ oids <- parallel $+ flip map (M.toList (treeContents t)) $ \(k, v) ->+ case v of+ BlobEntry bl exe ->+ withObject bl t $ \bl' -> do+ (Oid coid) <- objectId bl'+ return (k, BlobEntry (IdRef coid) exe, coid,+ if exe then 0o100755 else 0o100644)+ TreeEntry tr ->+ withObject tr t $ \tr' -> do+ (Oid coid) <- objectId tr'+ return (k, TreeEntry (IdRef coid), coid, 0o040000) + newList <- for oids $ \(k, entry, coid, flags) -> do+ insertObject builder k coid flags+ return (k, entry)+ coid <- mallocForeignPtr withForeignPtr coid $ \coid' -> do r3 <- c'git_treebuilder_write coid' repoPtr builder when (r3 < 0) $ throwIO TreeBuilderWriteFailed - return (treeInfo.gitId .~ Stored (COid coid) $- treeContents .~ M.fromList newList $ t, COid coid)+ return (t { treeInfo = (treeInfo t) { gitId = Stored (COid coid) }+ , treeContents = M.fromList newList }, COid coid) where- repo = fromMaybe (error "Repository invalid") $- t^.treeInfo.gitRepo.repoObj-- insertObject :: (CStringable a, Updatable b, Show b)- => Ptr C'git_treebuilder -> a -> ObjRef b -> CUInt- -> IO (ObjRef b)- insertObject builder key obj attrs = do- coid <- case obj of- IdRef (COid x) -> return x- ObjRef x -> do- oid <- objectId x- case oid of- Oid (COid y) -> return y- _ -> error $ "Failed to determine object id for: " ++ show x+ repo = fromMaybe (error "Repository invalid")+ (repoObj (gitRepo (treeInfo t))) + insertObject :: (CStringable a)+ => Ptr C'git_treebuilder -> a -> COid -> CUInt -> IO ()+ insertObject builder key (COid coid) attrs = withForeignPtr coid $ \coid' -> withCStringable key $ \name -> do r2 <- c'git_treebuilder_insert nullPtr builder name coid' attrs when (r2 < 0) $ throwIO TreeBuilderInsertFailed - return (IdRef (COid coid))- doModifyTree :: [Text] -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool -> Tree -> IO (Either a Tree)@@ -206,12 +233,12 @@ -- 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 <- case M.lookup name (t^.treeContents) of+ y <- case M.lookup name (treeContents t) of Nothing -> return $ if createIfNotExist && not (null names) then Just . TreeEntry . ObjRef . createTree- $ t^.treeInfo.gitRepo+ $ gitRepo (treeInfo t) else Nothing Just j -> case j of BlobEntry b mode -> do@@ -238,11 +265,11 @@ Left err -> return $ Left err Right z -> return $ Right $- treeInfo .~ newTreeBase t $- treeContents .~- (case z of- Nothing -> M.delete name (t^.treeContents)- Just z' -> M.insert name z' (t^.treeContents)) $ t+ t { treeInfo = newTreeBase t+ , treeContents =+ case z of+ Nothing -> M.delete name (treeContents t)+ Just z' -> M.insert name z' (treeContents t) } else -- If there are further names in the path, descend them now. If@@ -258,12 +285,12 @@ err@(Left _) -> return err Right st' -> return $ Right $- treeInfo .~ newTreeBase t $- treeContents .~- (if M.null (st'^.treeContents)- then M.delete name (t^.treeContents)- else M.insert name (TreeEntry (ObjRef st'))- (t^.treeContents)) $ t+ t { treeInfo = newTreeBase t+ , treeContents =+ if M.null (treeContents st')+ then M.delete name (treeContents t)+ else M.insert name (TreeEntry (ObjRef st'))+ (treeContents t) } _ -> throw TreeLookupFailed modifyTree
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 0.4.1+Version: 0.5.0 Synopsis: Higher-level types for working with hlibgit2 Description: Higher-level types for working with hlibgit2 License-file: LICENSE@@ -15,45 +15,54 @@ location: git://github.com/jwiegley/gitlib.git Test-suite smoke- default-language: Haskell98- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: test- build-depends:- base >=3+ Default-language: Haskell98+ Type: exitcode-stdio-1.0+ Main-is: Smoke.hs+ Hs-source-dirs: test+ Ghc-options: -Wall -Werror+ Build-depends: base >=3 , gitlib , HUnit >= 1.2.5 , bytestring >= 0.9.2.1 , containers >= 0.4.2 , lens >= 2.8+ , parallel-io >= 0.3.2.1 , stringable >= 0.1.1 , system-fileio >= 0.3.9 , system-filepath >= 0.4.7 , text >= 0.11.2 , time >= 1.4 -test-suite doctests- default-language: Haskell98- type: exitcode-stdio-1.0- main-is: doctests.hs- build-depends:- base == 4.*+Test-suite doctests+ Default-language: Haskell98+ 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 , filepath >= 1.3 && < 1.4- ghc-options: -Wall -Werror- hs-source-dirs: test +Test-suite unittests+ Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-is: Unit.hs+ Hs-source-dirs: test+ Build-depends: base == 4.*+ , HTF == 0.10.*+ Library default-language: Haskell98 default-extensions: ForeignFunctionInterface build-depends: base >= 3 && < 5- , hlibgit2 >= 0.6+ , hlibgit2 >= 0.17 , bytestring >= 0.9.2.1 , containers >= 0.4.2 , lens >= 2.8+ , parallel-io >= 0.3.2.1 , stringable >= 0.1.1 , system-fileio >= 0.3.9 , system-filepath >= 0.4.7
+ test/Doctest.hs view
@@ -0,0 +1,29 @@+module Main where++import Test.DocTest+import System.Directory+import System.FilePath+import Control.Applicative+import Control.Monad+import Data.List++main :: IO ()+main = getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "Data/Git"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."])+ <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
− test/Main.hs
@@ -1,209 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# 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.Applicative-import Control.Lens-import Control.Monad-import Data.Git-import Data.Maybe-import Data.Text as T hiding (map)-import qualified Data.Text.Encoding as E-import Data.Time.Clock.POSIX-import Data.Traversable-import Filesystem (removeTree, isDirectory)-import Filesystem.Path.CurrentOS-import qualified Prelude-import Prelude hiding (FilePath, putStr, putStrLn)-import System.Exit-import Test.HUnit--default (Text)--main :: IO ()-main = do- counts' <- runTestTT tests- case counts' of- Counts _ _ errors' failures' ->- if errors' > 0 || failures' > 0- then exitFailure- else exitSuccess--catBlob :: Repository -> Text -> IO (Maybe Text)-catBlob repo sha = do- hash <- stringToOid sha- for hash $ \hash' -> do- obj <- lookupObject hash' repo- case obj of- Just (BlobObj b) -> do- (_, contents) <- getBlobContents b- return (E.decodeUtf8 contents)-- Just _ -> error "Found something else..."- Nothing -> error "Didn't find anything :("--withRepository :: Text -> (Repository -> Assertion) -> Assertion-withRepository n f = do- let p = fromText n- exists <- isDirectory p- when exists $ removeTree p-- -- we want exceptions to leave the repo behind- f =<< createRepository p True-- removeTree p--oid :: Updatable a => a -> IO Text-oid = objectId >=> return . oidToText--oidToText :: Oid -> Text-oidToText = T.pack . show--tests :: Test-tests = test [-- "singleBlob" ~:-- withRepository "singleBlob.git" $ \repo -> do- update_ $ createBlob (E.encodeUtf8 "Hello, world!\n") repo-- x <- catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b"- (@?=) x (Just "Hello, world!\n")-- x <- catBlob repo "af5626b"- (@?=) x (Just "Hello, world!\n")-- return ()-- , "singleTree" ~:-- withRepository "singleTree.git" $ \repo -> do- let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo- tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)- x <- oid tr- (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"-- return()-- , "twoTrees" ~:-- withRepository "twoTrees.git" $ \repo -> do- let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo- tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)- x <- oid tr- (@?=) 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"-- return()-- , "deleteTree" ~:-- withRepository "deleteTree.git" $ \repo -> do- let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo- tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)- x <- oid tr- (@?=) 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"-- -- 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"-- return()-- , "createCommit" ~:-- withRepository "createCommit.git" $ \repo -> do- 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"-- -- The Oid has been cleared in tr, so this tests that it gets written as- -- needed.- let sig = Signature {- _signatureName = "John Wiegley"- , _signatureEmail = "johnw@newartisans.com"- , _signatureWhen = posixSecondsToUTCTime 1348980883 }-- x <- oid $ commitTree .~ ObjRef tr- $ commitAuthor .~ sig- $ commitCommitter .~ sig- $ commitLog .~ "Sample log message."- $ createCommit repo- (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56"-- return()-- , "createTwoCommits" ~:-- withRepository "createTwoCommits.git" $ \repo -> do- 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"-- -- The Oid has been cleared in tr, so this tests that it gets written as- -- needed.- let sig = Signature {- _signatureName = "John Wiegley"- , _signatureEmail = "johnw@newartisans.com"- , _signatureWhen = posixSecondsToUTCTime 1348980883 }- c = commitTree .~ ObjRef tr- $ commitAuthor .~ sig- $ commitCommitter .~ sig- $ commitLog .~ "Sample log message."- $ createCommit repo- x <- oid c- (@?=) 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"-- let sig = Signature {- _signatureName = "John Wiegley"- , _signatureEmail = "johnw@newartisans.com"- , _signatureWhen = posixSecondsToUTCTime 1348981883 }- c2 = commitTree .~ ObjRef tr- $ commitAuthor .~ sig- $ commitCommitter .~ sig- $ commitLog .~ "Second sample log message."- $ commitParents .~ [ObjRef c]- $ createCommit repo- x <- oid c2- (@?=) 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"-- return()-- ]---- Main.hs ends here
+ test/Smoke.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}+{-# 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.Applicative+import Control.Concurrent.ParallelIO+import Control.Monad+import Data.Git+import Data.Maybe+import Data.Text as T hiding (map)+import qualified Data.Text.Encoding as E+import Data.Time.Clock.POSIX+import Data.Traversable+import Filesystem (removeTree, isDirectory)+import Filesystem.Path.CurrentOS+import qualified Prelude+import Prelude hiding (FilePath, putStr, putStrLn)+import System.Exit+import Test.HUnit++default (Text)++main :: IO ()+main = do+ counts' <- runTestTT tests+ case counts' of+ Counts _ _ errors' failures' ->+ if errors' > 0 || failures' > 0+ then exitFailure+ else exitSuccess+ stopGlobalPool++catBlob :: Repository -> Text -> IO (Maybe Text)+catBlob repo sha = do+ hash <- stringToOid sha+ for hash $ \hash' -> do+ obj <- lookupObject hash' repo+ case obj of+ Just (BlobObj b) -> do+ (_, contents) <- getBlobContents b+ return (E.decodeUtf8 contents)++ Just _ -> error "Found something else..."+ Nothing -> error "Didn't find anything :("++withRepository :: Text -> (Repository -> Assertion) -> Assertion+withRepository n f = do+ let p = fromText n+ exists <- isDirectory p+ when exists $ removeTree p++ -- we want exceptions to leave the repo behind+ f =<< createRepository p True++ removeTree p++oid :: Updatable a => a -> IO Text+oid = objectId >=> return . oidToText++oidToText :: Oid -> Text+oidToText = T.pack . show++sampleCommit :: Repository -> Tree -> Signature -> Commit+sampleCommit repo tr sig =+ (createCommit repo) { commitTree = ObjRef tr+ , commitAuthor = sig+ , commitCommitter = sig+ , commitLog = "Sample log message." }++tests :: Test+tests = test [++ "singleBlob" ~:++ withRepository "singleBlob.git" $ \repo -> do+ update_ $ createBlob (E.encodeUtf8 "Hello, world!\n") repo++ x <- catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b"+ (@?=) x (Just "Hello, world!\n")++ x <- catBlob repo "af5626b"+ (@?=) x (Just "Hello, world!\n")++ return ()++ , "singleTree" ~:++ withRepository "singleTree.git" $ \repo -> do+ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo+ tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)+ x <- oid tr+ (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271"++ return()++ , "twoTrees" ~:++ withRepository "twoTrees.git" $ \repo -> do+ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo+ tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)+ x <- oid tr+ (@?=) 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"++ return()++ , "deleteTree" ~:++ withRepository "deleteTree.git" $ \repo -> do+ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo+ tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo)+ x <- oid tr+ (@?=) 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"++ -- 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"++ return()++ , "createCommit" ~:++ withRepository "createCommit.git" $ \repo -> do+ 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"++ -- The Oid has been cleared in tr, so this tests that it gets written as+ -- needed.+ let sig = Signature {+ signatureName = "John Wiegley"+ , signatureEmail = "johnw@newartisans.com"+ , signatureWhen = posixSecondsToUTCTime 1348980883 }++ x <- oid $ sampleCommit repo tr sig+ (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56"++ return()++ , "createTwoCommits" ~:++ withRepository "createTwoCommits.git" $ \repo -> do+ 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"++ -- The Oid has been cleared in tr, so this tests that it gets written as+ -- needed.+ let sig = Signature {+ signatureName = "John Wiegley"+ , signatureEmail = "johnw@newartisans.com"+ , signatureWhen = posixSecondsToUTCTime 1348980883 }+ c = sampleCommit repo tr sig+ x <- oid c+ (@?=) 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"++ let sig = Signature {+ signatureName = "John Wiegley"+ , signatureEmail = "johnw@newartisans.com"+ , signatureWhen = posixSecondsToUTCTime 1348981883 }+ c2 = (sampleCommit repo tr sig) {+ commitLog = "Second sample log message."+ , commitParents = [ObjRef c] }+ x <- oid c2+ (@?=) 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"++ return()++ ]++-- Main.hs ends here
+ test/Unit.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import System.Environment ( getArgs )+import System.Exit ( exitWith )+import Test.Framework++test_equality = assertEqual "foo" "foo"++main = htfMain htf_thisModulesTests
− test/doctests.hs
@@ -1,29 +0,0 @@-module Main where--import Test.DocTest-import System.Directory-import System.FilePath-import Control.Applicative-import Control.Monad-import Data.List--main :: IO ()-main = getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "Data/Git"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."])- <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c