gitlib 0.2.0 → 0.3.0
raw patch · 16 files changed
+1040/−257 lines, 16 filesdep +HUnitdep +directorydep +doctestdep −processdep ~basedep ~stringable
Dependencies added: HUnit, directory, doctest, filepath, text-icu
Dependencies removed: process
Dependency ranges changed: base, stringable
Files
- Data/Git.hs +4/−16
- Data/Git/Blob.hs +36/−32
- Data/Git/Commit.hs +163/−15
- Data/Git/Common.hs +65/−18
- Data/Git/Errors.hs +12/−0
- Data/Git/Internal.hs +64/−31
- Data/Git/Object.hs +17/−17
- Data/Git/Oid.hs +47/−2
- Data/Git/Reference.hs +176/−0
- Data/Git/Repository.hs +5/−3
- Data/Git/Tag.hs +7/−8
- Data/Git/Tree.hs +177/−52
- gitlib.cabal +29/−15
- test/Main.hs +209/−0
- test/doctests.hs +29/−0
- tests/Main.hs +0/−48
Data/Git.hs view
@@ -1,21 +1,15 @@ 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.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.Reference, -- module Data.Git.Odb, module Data.Git.Common, module Data.Git.Object@@ -23,21 +17,15 @@ 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.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.Reference -- import Data.Git.Odb import Data.Git.Common import Data.Git.Object
Data/Git/Blob.hs view
@@ -3,19 +3,18 @@ module Data.Git.Blob ( Blob(..), HasBlob(..)+ , newBlobBase , 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)+import Data.ByteString as B hiding (map)+import Data.ByteString.Unsafe+import Data.Git.Common+import Data.Git.Errors+import Data.Git.Internal+import qualified Prelude default (Text) @@ -26,38 +25,43 @@ instance Show Blob where show x = case x^.blobInfo.gitId of- Left _ -> "Blob"- Right y -> "Blob#" ++ show y+ Pending _ -> "Blob"+ Stored y -> "Blob#" ++ show y instance Updatable Blob where- update = writeBlob- objectId b = case b^.blobInfo.gitId of- Left f -> Oid <$> (f b)- Right x -> return $ Oid x+ getId x = x^.blobInfo.gitId+ objectRepo x = x^.blobInfo.gitRepo+ objectPtr x = x^.blobInfo.gitObj+ update = writeBlob+ lookupFunction = lookupBlob +newBlobBase :: Blob -> Base Blob+newBlobBase b =+ newBase (b^.blobInfo.gitRepo) (Pending doWriteBlob) Nothing+ -- | 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+createBlob :: B.ByteString -> Repository -> Blob+createBlob text repo | text == B.empty = error "Cannot create an empty blob"- | otherwise = Blob { _blobInfo = newBase repo (Left doWriteBlob) Nothing- , _blobContents = text }+ | otherwise =+ Blob { _blobInfo = newBase repo (Pending 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 })+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 } getBlobContents :: Blob -> IO (Blob, B.ByteString) getBlobContents b = case b^.blobInfo.gitId of- Left _ -> return $ (b, contents)- Right hash ->+ Pending _ -> return $ (b, contents)+ Stored hash -> if contents /= B.empty then return (b, contents) else@@ -71,7 +75,7 @@ return (blobContents .~ bstr $ b, bstr) Nothing -> do- b' <- lookupBlob repo (Oid hash)+ b' <- lookupBlob (Oid hash) repo case b' of Just blobPtr' -> getBlobContents blobPtr' Nothing -> return (b, B.empty)@@ -82,9 +86,9 @@ -- | 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@(Blob { _blobInfo = Base { _gitId = Stored _ } }) = return b writeBlob b = do hash <- doWriteBlob b- return $ blobInfo.gitId .~ Right hash $+ return $ blobInfo.gitId .~ Stored hash $ blobContents .~ B.empty $ b doWriteBlob :: Blob -> IO COid@@ -95,8 +99,8 @@ return (COid ptr) where- repo = fromMaybe (error "Repository invalid") $- b^.blobInfo.gitRepo.repoObj+ repo = fromMaybe (error "Repository invalid")+ (b^.blobInfo.gitRepo.repoObj) createFromBuffer ptr repoPtr = unsafeUseAsCStringLen (b^.blobContents) $
Data/Git/Commit.hs view
@@ -4,28 +4,176 @@ 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)+import Bindings.Libgit2+import qualified Data.ByteString as BS+import Data.ByteString.Unsafe+import Data.Git.Common+import Data.Git.Internal+import Data.Git.Tree+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.Text.ICU.Convert as U+import Foreign.Marshal.Array+import qualified Prelude default (Text) -data Commit = Commit { _commitInfo :: Base Commit- , _commitWho :: WhoWhen- , _commitLog :: Text- , _commitTree :: Tree- , _commitObj :: ObjPtr C'git_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+ } makeClassy ''Commit instance Show Commit where show x = case x^.commitInfo.gitId of- Left _ -> "Commit"- Right y -> "Commit#" ++ show y+ 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+ update = writeCommit Nothing+ lookupFunction = lookupCommit++newCommitBase :: Commit -> Base Commit+newCommitBase t =+ newBase (t^.commitInfo.gitRepo)+ (Pending (doWriteCommit Nothing >=> return . snd)) Nothing++-- | Create a new, empty commit.+--+-- Since empty commits cannot exist in Git, attempting to write out an empty+-- 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 = "" }++lookupCommit :: Oid -> Repository -> IO (Maybe Commit)+lookupCommit oid repo =+ lookupObject' oid repo c'git_commit_lookup c'git_commit_lookup_prefix $+ \coid obj _ ->+ withForeignPtr obj $ \cobj -> do+ let c = castPtr cobj++ enc <- c'git_commit_message_encoding c+ encs <- if enc == nullPtr+ then return "UTF-8"+ else peekCString enc+ conv <- U.open encs (Just False)++ msg <- c'git_commit_message c >>= BS.packCString+ auth <- c'git_commit_author c >>= packSignature conv+ comm <- c'git_commit_committer c >>= packSignature conv+ toid <- c'git_commit_tree_oid c >>= wrapOidPtr++ pn <- c'git_commit_parentcount c+ poids <- traverse wrapOidPtr =<<+ (sequence $+ zipWith ($) (replicate (fromIntegral (toInteger pn))+ (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 }++withGitCommit :: Updatable b+ => ObjRef Commit -> b -> (Ptr C'git_commit -> IO a) -> IO a+withGitCommit cref obj f = do+ c' <- loadObject cref obj+ case c' of+ Nothing -> error "Cannot find Git commit in repository"+ Just co ->+ case co^.commitInfo.gitObj of+ Nothing -> error "Cannot find Git commit id"+ Just co' -> withForeignPtr co' (f . castPtr)++-- | 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 _ } }) =+ return c+writeCommit ref c = fst <$> doWriteCommit ref c++doWriteCommit :: Maybe Text -> Commit -> IO (Commit, COid)+doWriteCommit ref c = do+ 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 ->+ 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+ parentPtrs <- getCommitParentPtrs c+ flip finally (freeCommits parentPtrs) $ do+ parents <- newArray parentPtrs+ r <- c'git_commit_create coid' repoPtr+ update_ref author committer+ message_encoding message commit_tree+ (fromIntegral (length (c^.commitParents)))+ parents+ when (r < 0) $ throwIO CommitCreateFailed+ return coid++ return (commitInfo.gitId .~ Stored (COid coid) $ c, COid coid)++ where+ repo = fromMaybe (error "Repository invalid")+ (c^.commitInfo.gitRepo.repoObj)++ withRef refName =+ if isJust refName+ then unsafeUseAsCString (E.encodeUtf8 (fromJust refName))+ else flip ($) nullPtr++ withEncStr enc =+ if null enc+ then flip ($) nullPtr+ else withCString enc++ freeCommits = traverse c'git_commit_free++getCommitParents :: Commit -> IO [Commit]+getCommitParents c =+ traverse (\p -> do parent <- loadObject p c+ case parent of+ Nothing -> error "Cannot find Git commit"+ Just p' -> return p')+ (c^.commitParents)++getCommitParentPtrs :: Commit -> IO [Ptr C'git_commit]+getCommitParentPtrs c =+ withForeignPtr (repositoryPtr (objectRepo c)) $ \repoPtr ->+ for (c^.commitParents) $ \p -> do+ Oid (COid oid) <- case p of+ IdRef coid -> return $ Oid coid+ ObjRef x -> objectId x++ withForeignPtr oid $ \commit_id ->+ alloca $ \ptr -> do+ r <- c'git_commit_lookup ptr repoPtr commit_id+ when (r < 0) $ throwIO CommitLookupFailed+ peek ptr -- Commit.hs
Data/Git/Common.hs view
@@ -2,33 +2,80 @@ {-# LANGUAGE TemplateHaskell #-} module Data.Git.Common- ( Author, HasAuthor(..)- , WhoWhen, HasWhoWhen(..)+ ( Signature(..), HasSignature(..)+ , createSignature+ , packSignature+ , withSignature , 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)+import Control.Lens+import qualified Data.ByteString as BS+import Data.Git.Internal+import qualified Data.Text as T+import qualified Data.Text.ICU.Convert as U+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import qualified Prelude default (Text) -data Author = Author { _authorName :: Text- , _authorEmail :: Text }- deriving (Show, Eq)+data Signature = Signature { _signatureName :: Text+ , _signatureEmail :: Text+ , _signatureWhen :: UTCTime }+ deriving (Show, Eq) -makeClassy ''Author+makeClassy ''Signature -data WhoWhen = WhoWhen { _whoAuthor :: Author- , _whoAuthorDate :: UTCTime- , _whoCommitter :: Author- , _whoCommitterDate :: UTCTime }- deriving (Show, Eq)+-- | Convert a time in seconds (from Stripe's servers) to 'UTCTime'. See+-- "Data.Time.Format" for more on working with 'UTCTime'.+fromSeconds :: Integer -> UTCTime+fromSeconds = posixSecondsToUTCTime . fromInteger -makeClassy ''WhoWhen+-- | Convert a 'UTCTime' back to an Integer suitable for use with Stripe's API.+toSeconds :: UTCTime -> Integer+toSeconds = round . utcTimeToPOSIXSeconds++peekGitTime :: Ptr (C'git_time) -> IO UTCTime+peekGitTime time =+ -- jww (2012-09-29): Handle offset here+ return . fromSeconds . toInteger . c'git_time'time =<< peek time++packGitTime :: UTCTime -> C'git_time+packGitTime utcTime =+ C'git_time { c'git_time'time = fromIntegral (toSeconds utcTime)+ , c'git_time'offset = 0 } -- jww (2012-09-29): NYI++createSignature :: Signature+createSignature =+ Signature { _signatureName = T.empty+ , _signatureEmail = T.empty+ , _signatureWhen =+ UTCTime { utctDay =+ ModifiedJulianDay {+ toModifiedJulianDay = 0 }+ , utctDayTime = secondsToDiffTime 0 } }++packSignature :: U.Converter -> Ptr C'git_signature -> IO Signature+packSignature conv sig = do+ name <- peek (p'git_signature'name sig) >>= BS.packCString+ 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 }++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 ->+ alloca $ \ptr -> do+ poke ptr (C'git_signature nameCStr emailCStr+ (packGitTime (sig^.signatureWhen)))+ f ptr -- Common.hs
Data/Git/Errors.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} +-- | Error types which may be thrown during Git operations, using+-- 'Control.Exception.throwIO'. module Data.Git.Errors ( GitException(..) ) where@@ -8,6 +10,8 @@ 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@@ -15,8 +19,16 @@ | TreeBuilderCreateFailed | TreeBuilderInsertFailed | TreeBuilderWriteFailed+ | TreeLookupFailed+ | TreeCannotTraverseBlob+ | CommitCreateFailed+ | CommitLookupFailed+ | ReferenceCreateFailed+ | RefCannotCreateFromPartialOid+ | ReferenceLookupFailed | ObjectLookupFailed | ObjectIdTooLong+ | ObjectRefRequiresFullOid | OidCopyFailed deriving (Show, Typeable)
Data/Git/Internal.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -21,29 +22,36 @@ , lookupObject' - , module F , module X ) where import Bindings.Libgit2 as X import Control.Applicative as X+import Control.Category as X import Control.Exception as X-import Control.Lens as X hiding((<.>))+import Control.Lens as X import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_,- forM, forM_, msum)-import Data.Either as X+ forM, forM_, msum)+import Data.Bool as X+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.Oid as X+import Data.List as X hiding (foldl, foldl', foldl1, foldr1, foldl1',+ foldr, concat, maximum, minimum,+ product, sum, all, and, any, concatMap,+ elem, notElem, or, find, mapAccumL,+ mapAccumR, maximumBy, minimumBy) import Data.Maybe as X import Data.Monoid as X-import Data.Stringable as X-import Data.Text as T hiding (map)+import Data.Stringable as X hiding (length)+import Data.Text as X (Text)+import Data.Tuple as X import Data.Traversable as X-import Filesystem as X+import Filesystem as X hiding (createTree) import qualified Filesystem.Path.CurrentOS as F-import Filesystem.Path.CurrentOS as X hiding (empty, concat,- toText, fromText)+import Filesystem.Path.CurrentOS as X (FilePath) import Foreign.C.String as X import Foreign.C.Types as X import Foreign.ForeignPtr as X@@ -52,7 +60,9 @@ import Foreign.Ptr as X import Foreign.StablePtr as X import Foreign.Storable as X-import Prelude hiding (FilePath, mapM, mapM_, sequence, sequence_)+import Prelude as X (undefined, error, otherwise, IO, Show, show,+ Enum, Eq, Ord, (<), (==), (/=), round,+ Integer, fromIntegral, fromInteger, toInteger) import Unsafe.Coerce as X default (Text)@@ -60,11 +70,33 @@ type ObjPtr a = Maybe (ForeignPtr a) class Updatable a where+ getId :: a -> Ident a+ objectRepo :: a -> Repository+ objectPtr :: a -> ObjPtr C'git_object+ update :: a -> IO a update_ :: a -> IO () update_ = void . update objectId :: a -> IO Oid+ objectId x = case getId x of+ Pending f -> Oid <$> f x+ Stored y -> return $ Oid y++ maybeObjectId :: a -> Maybe Oid+ maybeObjectId x = case getId x of+ Pending _ -> Nothing+ Stored y -> Just (Oid y)++ lookupFunction :: Oid -> Repository -> IO (Maybe a)++ loadObject :: Updatable b => ObjRef a -> b -> IO (Maybe a)+ loadObject (IdRef coid) y = lookupFunction (Oid coid) (objectRepo y)+ loadObject (ObjRef x) _ = return (Just x)++ getObject :: ObjRef a -> Maybe a+ getObject (IdRef _) = Nothing+ getObject (ObjRef x) = Just x data Repository = Repository { _repoPath :: FilePath , _repoObj :: ObjPtr C'git_repository }@@ -82,8 +114,8 @@ instance Show (Base a) where show x = case x^.gitId of- Left _ -> "Base"- Right y -> "Base#" ++ show y+ Pending _ -> "Base"+ Stored y -> "Base#" ++ show y newBase :: Repository -> Ident a -> ObjPtr C'git_object -> Base a newBase repo oid obj = Base { _gitId = oid@@ -126,29 +158,30 @@ where doesNotExist = throwIO . RepositoryNotExist . toString lookupObject'- :: Repository -> Oid+ :: Oid -> Repository -> (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+lookupObject' oid repo 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'+ fptr <- newForeignPtr p'git_object_free ptr'+ Just <$> createFn (COid coidCopy) fptr ptr' -- Internal.hs
Data/Git/Object.hs view
@@ -2,7 +2,7 @@ module Data.Git.Object ( Object(..)- , Ref(..)+ , NamedRef(..) , revParse , lookupObject ) where@@ -20,15 +20,15 @@ | CommitObj Commit | TagObj Tag -data Ref a = FullHash a- | PartialHash a- | BranchName a- | TagName a- | RefName a- | FullRefName a- | Specifier a+data NamedRef a = FullHash a+ | PartialHash a+ | BranchName a+ | TagName a+ | RefName a+ | FullRefName a+ | Specifier a -revParse :: CStringable a => Ref a -> IO (Maybe Oid)+revParse :: CStringable a => NamedRef a -> IO (Maybe Oid) revParse (FullHash r) = stringToOid r revParse (PartialHash r) = stringToOid r revParse (BranchName r) = undefined@@ -37,24 +37,24 @@ revParse (FullRefName r) = undefined revParse (Specifier r) = undefined -lookupObject :: Repository -> Oid -> IO (Maybe Object)-lookupObject repo oid =- lookupObject' repo oid+lookupObject :: Oid -> Repository -> IO (Maybe Object)+lookupObject oid repo =+ lookupObject' oid repo (\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)+ (\coid x y -> c'git_object_type y >>= createObject coid x repo) -createObject :: Repository -> COid -> ForeignPtr C'git_object -> C'git_otype+createObject :: COid -> ForeignPtr C'git_object -> Repository -> C'git_otype -> IO Object-createObject repo coid obj typ+createObject coid obj repo typ | typ == c'GIT_OBJ_BLOB = return $ BlobObj Blob { _blobInfo =- newBase repo (Right coid) (Just obj)+ newBase repo (Stored coid) (Just obj) , _blobContents = B.empty } | typ == c'GIT_OBJ_TREE = return $ TreeObj Tree { _treeInfo =- newBase repo (Right coid) (Just obj)+ newBase repo (Stored coid) (Just obj) , _treeContents = M.empty } | otherwise = return undefined
Data/Git/Oid.hs view
@@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} +-- | The 'Oid' type represents a Git hash value, whether partial or full. In+-- general users do not interact with this type much, as all the top-level+-- functions which expect hash values typically expect strings. module Data.Git.Oid ( Oid(..) , COid(..)- , Ident+ , ObjRef(..)+ , Ident(..)+ , wrapOidPtr , compareCOid , compareCOidLen , equalCOid@@ -16,9 +21,12 @@ import Data.ByteString.Unsafe import Data.Git.Errors import Data.Stringable as S+import Foreign.Ptr import Foreign.ForeignPtr 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) instance Show COid where@@ -26,8 +34,29 @@ toString $ unsafePerformIO $ withForeignPtr x (unsafePackMallocCString <=< c'git_oid_allocfmt) -type Ident a = Either (a -> IO COid) COid+-- | '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+-- object in the repository. This permits deferred loading of objects+-- within potentially very large structures, such as trees and commits.+-- However, it also means that every access to a sub-object must use+-- loadObject from the type class 'Updatable'.+data ObjRef a = IdRef COid+ | ObjRef a +wrapOidPtr :: Ptr C'git_oid -> IO (ObjRef a)+wrapOidPtr = newForeignPtr_ >=> return . IdRef . COid++-- | An 'Ident' abstracts the fact that some objects won't have an identifier+-- until they are written to disk -- even if sufficient information exists+-- to determine that hash value. If construct as a 'Pending' value, it is+-- an 'IO' action that writes the object to disk and retrieves the resulting+-- hash value from Git; if 'Stored', it is a 'COid' that is known to the+-- repository.+data Ident a = Pending (a -> IO COid)+ | Stored COid++-- | 'Oid' represents either a full or partial SHA1 hash code used to identify+-- Git objects. data Oid = Oid COid | PartialOid COid Int @@ -35,6 +64,7 @@ show (Oid x) = show x show (PartialOid x l) = take l $ show x +-- | Compare two 'COid' values for equality. More typical is to use 'compare'. compareCOid :: COid -> COid -> Ordering (COid x) `compareCOid` (COid y) = let c = unsafePerformIO $@@ -43,6 +73,7 @@ c'git_oid_cmp x' y' in c `compare` 0 +-- | Compare two 'COid' values for equality, but only up to a certain length. compareCOidLen :: COid -> COid -> Int -> Ordering compareCOidLen (COid x) (COid y) l = let c = unsafePerformIO $@@ -54,6 +85,7 @@ instance Ord COid where compare = compareCOid +-- | 'True' if two 'COid' values are equal. equalCOid :: Ord a => a -> a -> Bool x `equalCOid` y = (x `compare` y) == EQ @@ -66,6 +98,19 @@ xl == yl && compareCOidLen x y xl == EQ _ == _ = False +-- | Convert a hash string to a 'Maybe' 'Oid' value. If the string is less+-- than 40 hexadecimal digits, the result will be of type 'PartialOid'.+--+-- >>> stringToOid "a143ecf"+-- Just a143ecf+-- >>> stringToOid "a143ecf" >>= (\(Just (PartialOid _ l)) -> return $ l == 7)+-- True+--+-- >>> let hash = "6cfc2ca31732fb6fa6b54bae6e586a57a0611aab"+-- >>> stringToOid hash+-- Just 6cfc2ca31732fb6fa6b54bae6e586a57a0611aab+-- >>> stringToOid hash >>= (\(Just (Oid _)) -> return True)+-- True stringToOid :: CStringable a => a -> IO (Maybe Oid) stringToOid str | len > 40 = throwIO ObjectIdTooLong
+ Data/Git/Reference.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Git.Reference+ ( RefTarget(..)+ , Reference(..), HasReference(..)++ , createRef+ , lookupRef+ , lookupId+ , writeRef )+ where++import Bindings.Libgit2+import Data.Git.Common+import Data.Git.Internal+import Data.Git.Object+import qualified Prelude++default (Text)++data RefTarget = RefTargetId Oid+ | RefTargetSymbolic Text+ deriving (Show, Eq)++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 }++lookupRef :: Text -> Repository -> IO (Maybe Reference)+lookupRef name repo = alloca $ \ptr -> do+ r <- withForeignPtr (repositoryPtr repo) $ \repoPtr ->+ withCStringable name $ \namePtr ->+ c'git_reference_lookup ptr repoPtr namePtr+ if (r < 0)+ then return Nothing+ else do+ ref <- peek ptr+ fptr <- newForeignPtr p'git_reference_free ref+ 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+ RefTargetId (PartialOid {}) ->+ throwIO RefCannotCreateFromPartialOid++ RefTargetId (Oid (COid coid)) ->+ withForeignPtr coid $ \coidPtr ->+ c'git_reference_create_oid ptr repoPtr namePtr+ coidPtr (fromBool True)++ RefTargetSymbolic symName ->+ withCStringable symName $ \symPtr ->+ c'git_reference_create_symbolic ptr repoPtr namePtr+ symPtr (fromBool True)+ when (r < 0) $ throwIO ReferenceCreateFailed++ fptr <- newForeignPtr_ =<< peek ptr+ return $ refObj .~ Just fptr $ ref++ where+ repo = fromMaybe (error "Repository invalid") (ref^.refRepo.repoObj)++-- int git_reference_name_to_oid(git_oid *out, git_repository *repo,+-- const char *name)++lookupId :: Text -> Repository -> IO Oid+lookupId name repos = alloca $ \ptr ->+ withCStringable name $ \namePtr ->+ withForeignPtr repo $ \repoPtr -> do+ r <- c'git_reference_name_to_oid ptr repoPtr namePtr+ when (r < 0) $ throwIO ReferenceLookupFailed+ Oid <$> COid <$> newForeignPtr_ ptr++ where+ repo = fromMaybe (error "Repository invalid") (repos^.repoObj)++-- int git_reference_create_symbolic(git_reference **ref_out,+-- git_repository *repo, const char *name, const char *target, int force)++--createSymbolicRef = c'git_reference_create_symbolic++-- int git_reference_create_oid(git_reference **ref_out, git_repository *repo,+-- const char *name, const git_oid *id, int force)++--createNamedRef = c'git_reference_create_oid++-- const git_oid * git_reference_oid(git_reference *ref)++--refId = c'git_reference_oid++-- const char * git_reference_target(git_reference *ref)++--refTarget = c'git_reference_target++-- git_ref_t git_reference_type(git_reference *ref)++--refType = c'git_reference_type++-- const char * git_reference_name(git_reference *ref)++--refName = c'git_reference_name++-- int git_reference_resolve(git_reference **resolved_ref, git_reference *ref)++--resolveRef = c'git_reference_resolve++-- int git_reference_set_target(git_reference *ref, const char *target)++--setRefTarget = c'git_reference_set_target++-- int git_reference_set_oid(git_reference *ref, const git_oid *id)++--setRefId = c'git_reference_set_oid++-- int git_reference_rename(git_reference *ref, const char *new_name,+-- int force)++--renameRef = c'git_reference_rename++-- int git_reference_delete(git_reference *ref)++--deleteRef = c'git_reference_delete++-- int git_reference_packall(git_repository *repo)++--packallRefs = c'git_reference_packall++-- int git_reference_list(git_strarray *array, git_repository *repo,+-- unsigned int list_flags)++--listRefs = c'git_reference_list++-- int git_reference_foreach(git_repository *repo, unsigned int list_flags,+-- int (*callback)(const char *, void *), void *payload)++--foreachRef = c'git_reference_foreach++-- int git_reference_is_packed(git_reference *ref)++--refIsPacked = c'git_reference_is_packed++-- int git_reference_reload(git_reference *ref)++--reloadRef = c'git_reference_reload++-- void git_reference_free(git_reference *ref)++--freeRef = c'git_reference_free++-- int git_reference_cmp(git_reference *ref1, git_reference *ref2)++--compareRef = c'git_reference_cmp++-- Refs.hs
Data/Git/Repository.hs view
@@ -1,10 +1,12 @@ {-# 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+-- associated with the repository — such as the list of branches — is+-- queried as needed. module Data.Git.Repository- ( Oid- , Ident- , ObjPtr+ ( ObjPtr , Updatable(..)
Data/Git/Tag.hs view
@@ -3,12 +3,11 @@ 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)+import Control.Lens+import Data.Git.Common+import Data.Git.Internal+import qualified Data.Text as T+import qualified Prelude default (Text) @@ -19,7 +18,7 @@ instance Show Tag where show x = case x^.tagInfo.gitId of- Left _ -> "Tag"- Right y -> "Tag#" ++ show y+ Pending _ -> "Tag"+ Stored y -> "Tag#" ++ show y -- Tag.hs
Data/Git/Tree.hs view
@@ -2,27 +2,51 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} module Data.Git.Tree where import Bindings.Libgit2-import Control.Lens-import Data.Either import Data.Git.Blob import Data.Git.Common import Data.Git.Errors import Data.Git.Internal-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, sequence)+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Filesystem.Path.CurrentOS as F+import qualified Prelude default (Text) -data TreeEntry = BlobEntry { blobEntry :: Blob+data TreeEntry = BlobEntry { blobEntry :: ObjRef Blob , blobEntryIsExe :: Bool }- | TreeEntry { treeEntry :: Tree }+ | TreeEntry { treeEntry :: ObjRef Tree } +blobRefWithMode :: Bool -> Blob -> TreeEntry+blobRefWithMode mode b = BlobEntry (ObjRef b) mode++blobRef :: Blob -> TreeEntry+blobRef = blobRefWithMode False++exeBlobRef :: Blob -> TreeEntry+exeBlobRef = blobRefWithMode True++blobIdRef :: Oid -> Bool -> TreeEntry+blobIdRef (Oid coid) = BlobEntry (IdRef coid)+blobIdRef (PartialOid {}) = throw ObjectRefRequiresFullOid++treeRef :: Tree -> TreeEntry+treeRef t = TreeEntry (ObjRef t)++treeIdRef :: Oid -> TreeEntry+treeIdRef (Oid coid) = TreeEntry (IdRef coid)+treeIdRef (PartialOid {}) = throw ObjectRefRequiresFullOid++-- instance Eq TreeEntry where+-- (BlobEntry x x2) == (BlobEntry y y2) = x == y && x2 == y2+-- (TreeEntry x) == (TreeEntry y) = x == y+-- _ == _ = False+ type TreeMap = M.Map Text TreeEntry data Tree = Tree { _treeInfo :: Base Tree@@ -32,38 +56,66 @@ instance Show Tree where show x = case x^.treeInfo.gitId of- Left _ -> "Tree"- Right y -> "Tree#" ++ show y+ Pending _ -> "Tree"+ Stored y -> "Tree#" ++ show y instance Updatable Tree where- update = writeTree- objectId t = case t^.treeInfo.gitId of- Left f -> Oid <$> (f t)- Right x -> return $ Oid x+ getId x = x^.treeInfo.gitId+ objectRepo x = x^.treeInfo.gitRepo+ objectPtr x = x^.treeInfo.gitObj+ update = writeTree+ lookupFunction = lookupTree newTreeBase :: Tree -> Base Tree newTreeBase t =- newBase (t^.treeInfo.gitRepo) (Left (doWriteTree >=> return . snd)) Nothing+ newBase (t^.treeInfo.gitRepo)+ (Pending (doWriteTree >=> return . snd)) Nothing --- | Create a new tree, starting it with the contents at the given path.+-- | Create a new, empty tree. ----- Note that since empty trees cannot exist in Git, no means is provided for--- creating one.-createTree :: Repository -> FilePath -> TreeEntry -> Tree-createTree repo path item = updateTree path item (emptyTree repo)+-- Since empty trees cannot exist in Git, attempting to write out an empty+-- tree is a no-op.+createTree :: Repository -> Tree+createTree repo =+ Tree { _treeInfo =+ newBase repo (Pending (doWriteTree >=> return . snd)) Nothing+ , _treeContents = M.empty } -lookupTree :: Repository -> Oid -> IO (Maybe Tree)-lookupTree repo oid =- lookupObject' repo oid c'git_tree_lookup c'git_tree_lookup_prefix- (\coid obj _ ->+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 =- newBase repo (Right coid) (Just obj)- , _treeContents = M.empty })+ newBase repo (Stored coid) (Just obj)+ , _treeContents = M.empty } +withGitTree :: Updatable b+ => ObjRef Tree -> b -> (Ptr C'git_tree -> IO a) -> IO a+withGitTree tref obj f =+ withForeignPtr (repositoryPtr (objectRepo obj)) $ \repoPtr ->+ case tref of+ IdRef (COid oid) -> withGitTreeOid repoPtr oid++ ObjRef (Tree { _treeInfo = Base { _gitId = Stored (COid oid) } }) ->+ withGitTreeOid repoPtr oid++ ObjRef (Tree { _treeInfo = Base { _gitObj = Just t } }) ->+ withForeignPtr t (f . castPtr)++ ObjRef t -> do t' <- update t+ withGitTree (ObjRef t') obj f++ where withGitTreeOid repoPtr oid =+ withForeignPtr oid $ \tree_id ->+ alloca $ \ptr -> do+ r <- c'git_tree_lookup ptr repoPtr tree_id+ when (r < 0) $ throwIO TreeLookupFailed+ f =<< peek ptr+ -- | 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 = Right _ } }) = return t+writeTree t@(Tree { _treeInfo = Base { _gitId = Stored _ } }) = return t writeTree t = fst <$> doWriteTree t doWriteTree :: Tree -> IO (Tree, COid)@@ -91,7 +143,7 @@ r3 <- c'git_treebuilder_write coid' repoPtr builder when (r3 < 0) $ throwIO TreeBuilderWriteFailed - return (treeInfo.gitId .~ Right (COid coid) $+ return (treeInfo.gitId .~ Stored (COid coid) $ treeContents .~ M.fromList newList $ t, COid coid) where@@ -99,44 +151,117 @@ t^.treeInfo.gitRepo.repoObj insertObject :: (CStringable a, Updatable b)- => Ptr C'git_treebuilder -> a -> b -> CUInt -> IO b+ => Ptr C'git_treebuilder -> a -> ObjRef b -> CUInt+ -> IO (ObjRef b) insertObject builder key obj attrs = do- obj' <- update obj- Oid (COid coid) <- objectId obj'+ coid <- case obj of+ IdRef (COid x) -> return x+ ObjRef x -> do+ oid <- objectId x+ case oid of+ Oid (COid y) -> return y+ _ -> error "Unexpected" withForeignPtr coid $ \coid' -> withCStringable key $ \name -> do r2 <- c'git_treebuilder_insert nullPtr builder name coid' attrs when (r2 < 0) $ throwIO TreeBuilderInsertFailed - return obj'+ return (IdRef (COid coid)) -emptyTree :: Repository -> Tree-emptyTree repo =- Tree { _treeInfo =- newBase repo (Left (doWriteTree >=> return . snd)) Nothing- , _treeContents = M.empty }+doModifyTree+ :: [Text] -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool+ -> Tree -> IO (Either a Tree)+doModifyTree [] _ _ _ = throw TreeLookupFailed+doModifyTree (name:names) f createIfNotExist 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+ Nothing ->+ return $+ if createIfNotExist && not (null names)+ then Just . TreeEntry . ObjRef . createTree+ $ t^.treeInfo.gitRepo+ else Nothing+ Just j -> case j of+ BlobEntry b mode -> do+ bl <- loadObject b t+ for bl $ \x -> return $ BlobEntry (ObjRef x) mode+ TreeEntry t' -> do+ tr <- loadObject t' t+ for tr $ \x -> return $ TreeEntry (ObjRef x) -doUpdateTree :: [Text] -> TreeEntry -> Tree -> Tree-doUpdateTree (x:xs) item t =- treeInfo .~ newTreeBase t $- treeContents .~ update' xs $ t+ if null names+ then do+ -- If there are no further names in the path, call the transformer+ -- function, f. It receives a @Maybe TreeEntry@ to indicate if there+ -- was a previous entry at this path. It should return a 'Left' value+ -- to propagate out a user-defined error, or a @Maybe TreeEntry@ to+ -- indicate whether the entry at this path should be deleted or+ -- replaced with something new.+ --+ -- NOTE: There is no provision for leaving the entry unchanged! It is+ -- assumed to always be changed, as we have no reliable method of+ -- testing object equality that is not O(n).+ let ze = f y+ case ze of+ 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 - where repo = t^.treeInfo.gitRepo- treeMap = t^.treeContents- update' [] = M.insert x item treeMap- update' _ = M.insert x subTree treeMap- subTree = TreeEntry $ doUpdateTree xs item tree'- tree' = case M.lookup x treeMap of- Just (TreeEntry m) -> m- _ -> emptyTree repo-doUpdateTree [] _ _ = undefined+ else+ -- If there are further names in the path, descend them now. If+ -- 'createIfNotExist' was False and there is no 'Tree' under the+ -- current name, or if we encountered a 'Blob' when a 'Tree' was+ -- required, throw an exception to avoid colliding with user-defined+ -- 'Left' values.+ case y of+ Just (BlobEntry {}) -> throw TreeCannotTraverseBlob+ Just (TreeEntry (ObjRef t')) -> do+ st <- doModifyTree names f createIfNotExist t'+ case st of+ 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+ _ -> throw TreeLookupFailed -updateTree :: FilePath -> TreeEntry -> Tree -> Tree+modifyTree+ :: FilePath -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool+ -> Tree -> IO (Either a Tree)+modifyTree = doModifyTree . splitPath++doUpdateTree :: [Text] -> TreeEntry -> Tree -> IO Tree+doUpdateTree xs item t = do+ t' <- doModifyTree xs (const (Right (Just item))) True t+ case t' of+ Right tr -> return tr+ _ -> undefined++updateTree :: FilePath -> TreeEntry -> Tree -> IO Tree updateTree = doUpdateTree . splitPath +removeFromTree :: FilePath -> Tree -> IO Tree+removeFromTree p tr = do+ t' <- modifyTree p (const (Right Nothing)) False tr+ case t' of+ Right tr' -> return tr'+ _ -> undefined+ splitPath :: FilePath -> [Text]-splitPath path = splitOn "/" text+splitPath path = T.splitOn "/" text where text = case F.toText path of Left x -> error $ "Invalid path: " ++ T.unpack x Right y -> y
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 0.2.0+Version: 0.3.0 Synopsis: Higher-level types for working with hlibgit2 Description: Higher-level types for working with hlibgit2 License-file: LICENSE@@ -18,20 +18,32 @@ default-language: Haskell98 type: exitcode-stdio-1.0 main-is: Main.hs- hs-source-dirs: tests+ hs-source-dirs: test build-depends: base >=3 , gitlib- , process- , system-filepath >= 0.4.7- , system-fileio >= 0.3.9- , time >= 1.4- , text >= 0.11.2- , containers >= 0.4.2+ , HUnit >= 1.2.5 , bytestring >= 0.9.2.1- , stringable >= 0.1+ , containers >= 0.4.2 , lens >= 2.8+ , 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.*+ , directory >= 1.0 && < 1.2+ , doctest >= 0.8 && <= 0.10+ , filepath >= 1.3 && < 1.4+ ghc-options: -Wall -Werror+ hs-source-dirs: test+ Library default-language: Haskell98 default-extensions:@@ -39,14 +51,15 @@ build-depends: base >= 3 && < 5 , hlibgit2 >= 0.6- , 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- , stringable >= 0.1+ , containers >= 0.4.2 , lens >= 2.8+ , stringable >= 0.1.1+ , system-fileio >= 0.3.9+ , system-filepath >= 0.4.7+ , text >= 0.11.2+ , text-icu >= 0.6.3+ , time >= 1.4 exposed-modules: Data.Git Data.Git.Blob@@ -58,5 +71,6 @@ Data.Git.Repository Data.Git.Tag Data.Git.Tree+ Data.Git.Reference other-modules: Data.Git.Internal
+ test/Main.hs view
@@ -0,0 +1,209 @@+{-# 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/doctests.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
− tests/Main.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--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 Prelude hiding (FilePath, putStr, putStrLn)--default (Text)--main :: IO ()-main = do- 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"-- 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