gitlib-2.2.0.0/0000755000000000000000000000000012246007504011311 5ustar0000000000000000gitlib-2.2.0.0/Git.hs0000644000000000000000000000047312246007504012374 0ustar0000000000000000-- | Interface for working with Git repositories. module Git ( module X ) where import Git.Blob as X import Git.Commit as X import Git.Commit.Push as X import Git.Object as X import Git.Reference as X import Git.Repository as X import Git.Tree as X import Git.Tree.Builder as X import Git.Types as X gitlib-2.2.0.0/gitlib.cabal0000644000000000000000000000473112246007504013554 0ustar0000000000000000Name: gitlib Version: 2.2.0.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT Author: John Wiegley Maintainer: johnw@fpcomplete.com Build-Type: Simple Cabal-Version: >=1.10 Category: FFI Description: @gitlib@ is a high-level, lazy and conduit-aware set of abstractions for programming with Git types. Several different backends are available, including one for the libgit2 C library () (see @gitlib-libgit2@). The aim is both type-safety and convenience of use for Haskell users, combined with high performance and minimal memory footprint by taking advantage of Haskell's laziness and the conduit library's deterministic resource cleanup. . For further information, as well as typical use cases, see "Git.Tutorial". Source-repository head type: git location: git://github.com/fpco/gitlib.git -- Test-suite doctests -- Default-language: Haskell98 -- Type: exitcode-stdio-1.0 -- Main-is: Doctest.hs -- Hs-source-dirs: test -- Build-depends: -- base -- , directory >= 1.0 -- , doctest >= 0.8 -- , doctest-prop >= 0.1 -- , filepath >= 1.3 Library default-language: Haskell98 ghc-options: -Wall build-depends: base >= 3 && < 5 , base16-bytestring >= 0.1.1.5 , binary >= 0.5.1.0 , bytestring >= 0.9.2.1 , conduit >= 1.0.0 , containers >= 0.4.2.1 , data-default >= 0.5.0 , directory >= 1.1.0.2 , failure >= 0.2.0.1 , hashable >= 1.1.2.5 , lifted-base >= 0.2 , tagged >= 0.2.3.1 , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0 , unordered-containers >= 0.2.3.0 exposed-modules: Git Git.Types Git.Blob Git.Tree Git.Tree.Builder Git.Tree.Builder.Pure Git.Commit Git.Commit.Push Git.Object Git.Reference Git.Repository Git.Tutorial default-extensions: ConstraintKinds DeriveDataTypeable FlexibleContexts OverloadedStrings RankNTypes TypeFamilies ViewPatterns gitlib-2.2.0.0/LICENSE0000644000000000000000000000203712246007504012320 0ustar0000000000000000opyright (c) 2012 John Wiegley Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. gitlib-2.2.0.0/Setup.hs0000644000000000000000000000005512246007504012745 0ustar0000000000000000import Distribution.Simple main = defaultMaingitlib-2.2.0.0/Git/0000755000000000000000000000000012246007504012034 5ustar0000000000000000gitlib-2.2.0.0/Git/Blob.hs0000644000000000000000000000376212246007504013256 0ustar0000000000000000module Git.Blob where import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Data.ByteString as B import Data.Conduit import qualified Data.Conduit.List as CList import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Tagged import Data.Text as T import Data.Text.Encoding as T import Git.Types createBlobUtf8 :: Repository m => Text -> m (BlobOid m) createBlobUtf8 = createBlob . BlobString . T.encodeUtf8 catBlob :: Repository m => BlobOid m -> m ByteString catBlob = lookupBlob >=> blobToByteString catBlobUtf8 :: Repository m => BlobOid m -> m Text catBlobUtf8 = catBlob >=> return . T.decodeUtf8 blobContentsToByteString :: Repository m => BlobContents m -> m ByteString blobContentsToByteString (BlobString bs) = return bs blobContentsToByteString (BlobStream bs) = B.concat <$> (bs $$ CList.consume) blobContentsToByteString (BlobSizedStream bs _) = B.concat <$> (bs $$ CList.consume) blobToByteString :: Repository m => Blob m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents treeBlobEntries :: Repository m => Tree m -> m [(TreeFilePath, BlobOid m, BlobKind)] treeBlobEntries tree = do entries <- listTreeEntries tree return $ Prelude.foldr f [] entries where f (fp ,BlobEntry oid k) xs = (fp, oid, k):xs f _ xs = xs copyBlob :: (Repository m, Repository (t m), MonadTrans t) => BlobOid m -> HashSet Text -> t m (BlobOid (t m), HashSet Text) copyBlob blobr needed = do let oid = untag blobr sha = renderOid oid oid2 <- parseOid (renderOid oid) if HashSet.member sha needed then do bs <- lift $ blobToByteString =<< lookupBlob (Tagged oid) boid <- createBlob (BlobString bs) let x = HashSet.delete sha needed return $ boid `seq` x `seq` (boid, x) else return (Tagged oid2, needed) gitlib-2.2.0.0/Git/Commit.hs0000644000000000000000000000575612246007504013635 0ustar0000000000000000module Git.Commit where import Control.Failure import Control.Monad import Control.Monad.Trans.Class import Data.Conduit import qualified Data.Conduit.List as CL import Data.Function import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List import Data.Maybe import Data.Monoid import Data.Tagged import Data.Text (Text) import Git.Tree import Git.Types import Prelude hiding (FilePath) commitTreeEntry :: Repository m => Commit m -> TreeFilePath -> m (Maybe (TreeEntry m)) commitTreeEntry c path = flip treeEntry path =<< lookupTree (commitTree c) copyCommitOid :: (Repository m, Repository n) => CommitOid m -> n (CommitOid n) copyCommitOid = parseObjOid . renderObjOid copyCommit :: (Repository m, Repository (t m), MonadTrans t) => CommitOid m -> Maybe RefName -> HashSet Text -> t m (CommitOid (t m), HashSet Text) copyCommit cr mref needed = do let oid = untag cr sha = renderOid oid commit <- lift $ lookupCommit cr oid2 <- parseOid sha if HashSet.member sha needed then do let parents = commitParents commit (parentRefs,needed') <- foldM copyParent ([],needed) parents (tr,needed'') <- copyTree (commitTree commit) needed' unless (renderObjOid (commitTree commit) == renderObjOid tr) $ failure $ BackendError $ "Error copying tree: " <> renderObjOid (commitTree commit) <> " /= " <> renderObjOid tr commit' <- createCommit (reverse parentRefs) tr (commitAuthor commit) (commitCommitter commit) (commitLog commit) mref let coid = commitOid commit' x = HashSet.delete sha needed'' return $ coid `seq` x `seq` (coid, x) else return (Tagged oid2, needed) where copyParent (prefs,needed') cref = do (cref2,needed'') <- copyCommit cref Nothing needed' unless (renderObjOid cref == renderObjOid cref2) $ failure $ BackendError $ "Error copying commit: " <> renderObjOid cref <> " /= " <> renderObjOid cref2 let x = cref2 `seq` (cref2:prefs) return $ x `seq` needed'' `seq` (x,needed'') listCommits :: Repository m => Maybe (CommitOid m) -- ^ A commit we may already have -> CommitOid m -- ^ The commit we need -> m [CommitOid m] -- ^ All the objects in between listCommits mhave need = sourceObjects mhave need False $= CL.mapM (\(CommitObjOid c) -> return c) $$ CL.consume traverseCommits :: Repository m => (CommitOid m -> m a) -> CommitOid m -> m [a] traverseCommits f need = mapM f =<< listCommits Nothing need traverseCommits_ :: Repository m => (CommitOid m -> m ()) -> CommitOid m -> m () traverseCommits_ = (void .) . traverseCommits gitlib-2.2.0.0/Git/Object.hs0000644000000000000000000000363112246007504013601 0ustar0000000000000000module Git.Object where import Control.Monad import Control.Monad.Trans.Class import Data.Conduit import qualified Data.Conduit.List as CL import Data.Function import Data.Maybe import Git.Types import Prelude hiding (FilePath) listObjects :: Repository m => Maybe (CommitOid m) -- ^ A commit we may already have -> CommitOid m -- ^ The commit we need -> Bool -- ^ Include commit trees also? -> m [ObjectOid m] -- ^ All the objects in between listObjects mhave need alsoTrees = sourceObjects mhave need alsoTrees $$ CL.consume traverseObjects :: Repository m => (ObjectOid m -> m a) -> CommitOid m -> m [a] traverseObjects f need = mapM f =<< listObjects Nothing need False traverseObjects_ :: Repository m => (ObjectOid m -> m ()) -> CommitOid m -> m () traverseObjects_ = (void .) . traverseObjects -- | Given a list of objects (commit and top-level trees) return by -- 'listObjects', expand it to include all subtrees and blobs as well. -- Ordering is preserved. expandTreeObjects :: Repository m => Conduit (ObjectOid m) m (ObjectOid m) expandTreeObjects = whileJust_ await $ \obj -> case obj of TreeObjOid toid -> do yield $ TreeObjOid toid tr <- lift $ lookupTree toid ents <- lift $ listTreeEntries tr forM_ ents $ \ent -> case ent of (_, BlobEntry oid _) -> yield $ BlobObjOid oid (_, TreeEntry oid) -> yield $ TreeObjOid oid _ -> return () _ -> yield obj where whileJust_ p f = do x <- p case x of Nothing -> return () Just x' -> f x' >> whileJust_ p f listAllObjects :: Repository m => Maybe (CommitOid m) -> CommitOid m -> m [ObjectOid m] listAllObjects mhave need = sourceObjects mhave need True $= expandTreeObjects $$ CL.consume gitlib-2.2.0.0/Git/Reference.hs0000644000000000000000000000061612246007504014271 0ustar0000000000000000module Git.Reference where import Git.Types resolveReference :: Repository m => RefName -> m (Maybe (Oid m)) resolveReference name = do mref <- lookupReference name maybe (return Nothing) referenceToOid mref referenceToOid :: Repository m => RefTarget m -> m (Maybe (Oid m)) referenceToOid (RefObj oid) = return $ Just oid referenceToOid (RefSymbolic name) = resolveReference name gitlib-2.2.0.0/Git/Repository.hs0000644000000000000000000000462112246007504014552 0ustar0000000000000000module Git.Repository where import qualified Control.Exception.Lifted as Exc import Control.Monad import Control.Monad.IO.Class import Data.Conduit import Git.Types import System.Directory import System.Mem withNewRepository :: (Repository t, MonadGit t, MonadBaseControl IO m, MonadIO m) => RepositoryFactory t m c -> FilePath -> t a -> m a withNewRepository factory path action = do liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path -- we want exceptions to leave the repo behind a <- withRepository' factory (defaultOptions factory) { repoPath = path , repoIsBare = True , repoAutoCreate = True } action liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path return a withNewRepository' :: (Repository t, MonadGit t, MonadBaseControl IO m, MonadIO m) => RepositoryFactory t m c -> FilePath -> t a -> m a withNewRepository' factory path action = Exc.bracket_ recover recover $ withRepository' factory (defaultOptions factory) { repoPath = path , repoIsBare = True , repoAutoCreate = True } action where recover = liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path withBackendDo :: (MonadIO m, MonadBaseControl IO m) => RepositoryFactory t m a -> m b -> m b withBackendDo fact f = do startupBackend fact Exc.finally f (liftIO performGC >> shutdownBackend fact) withRepository' :: (Repository t, MonadBaseControl IO m, MonadIO m) => RepositoryFactory t m c -> RepositoryOptions -> t a -> m a withRepository' factory opts action = Exc.bracket (openRepository factory opts) (closeRepository factory) (flip (runRepository factory) action) withRepository :: (Repository t, MonadBaseControl IO m, MonadIO m) => RepositoryFactory t m c -> FilePath -> t a -> m a withRepository factory path = withRepository' factory (defaultOptions factory) { repoPath = path } gitlib-2.2.0.0/Git/Tree.hs0000644000000000000000000000404712246007504013274 0ustar0000000000000000module Git.Tree where import Control.Failure import Control.Monad import Control.Monad.Trans.Class import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Monoid import Data.Tagged import Data.Text (Text) import Git.Blob import Git.Tree.Builder import Git.Types copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) => TreeEntry m -> HashSet Text -> t m (TreeEntry (t m), HashSet Text) copyTreeEntry (BlobEntry oid kind) needed = do (b,needed') <- copyBlob oid needed unless (renderObjOid oid == renderObjOid b) $ failure $ BackendError $ "Error copying blob: " <> renderObjOid oid <> " /= " <> renderObjOid b return (BlobEntry b kind, needed') copyTreeEntry (CommitEntry oid) needed = do coid <- parseOid (renderObjOid oid) return (CommitEntry (Tagged coid), needed) copyTreeEntry (TreeEntry _) _ = error "This should never be called" copyTree :: (Repository m, Repository (t m), MonadTrans t) => TreeOid m -> HashSet Text -> t m (TreeOid (t m), HashSet Text) copyTree tr needed = do let oid = untag tr sha = renderOid oid oid2 <- parseOid (renderOid oid) if HashSet.member sha needed then do tree <- lift $ lookupTree tr entries <- lift $ listTreeEntries tree (needed', tref) <- withNewTree $ foldM doCopyTreeEntry needed entries let x = HashSet.delete sha needed' return $ tref `seq` x `seq` (tref, x) else return (Tagged oid2, needed) where doCopyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) => HashSet Text -> (TreeFilePath, TreeEntry m) -> TreeT (t m) (HashSet Text) doCopyTreeEntry set (_, TreeEntry {}) = return set doCopyTreeEntry set (fp, ent) = do (ent2,set') <- lift $ copyTreeEntry ent set putEntry fp ent2 return set' gitlib-2.2.0.0/Git/Tutorial.hs0000644000000000000000000000572212246007504014201 0ustar0000000000000000{-| This module provides a brief introductory tutorial in the \"Introduction\" section followed by a lengthy discussion of the library's design and idioms. -} module Git.Tutorial ( -- * Introduction -- $intro -- * Repositories -- $repositories -- * References -- $references -- * Commits -- $commits ) where {- $intro The @gitlib@ library provides high-level types for working with the @libgit2@ C library (). The intention is to make @libgit2@ easier and more type-safe, while using laziness to avoid unnecessary work. -} {- $repositories Every use of @gitlib@ must begin with a 'Git.Libgit2.Repository' object. At the moment each 'Repository' must be associated with a local directory, even if the Git objects are kept elsewhere via a custom backend (see ). If no 'Repository' exists yet, use 'Git.Libgit2.Repository.createRepository'; if one does exist, use 'Git.Libgit2.Repository.openRepository'; or, you can use 'Git.Libgit2.Repository.openOrCreateRepository'. For example: > repo <- openOrCreateRepository path False -- False here means "not bare" > ... make use of the repository ... Note that the 'path' variable here is of type 'Filesystem.Path.FilePath', since @gitlib@ almost never uses the 'String' type. -} {- $references If you are working with an existing repository, probably the first thing you'll want to do is resolve a reference so that you can lookup a commit: > repo <- openOrCreateRepository path False > ref <- resolveRef repo "HEAD" > commit <- maybe (return Nothing) (lookupCommit repo) ref 'resolveRef' works for both symbolic and specific refs. Further, this pattern is rather common, so there is a shortcut called 'Git.Libgit2.Commit.lookupRefCommit'. Or, if you have a SHA string, you can use 'Git.Libgit2.Commit.lookupCommit' with 'Git.Libgit2.Oid.parseOid'. > repo <- openOrCreateRepository path False > commitFromRef <- lookupRefCommit repo "HEAD" :: Maybe Commit > commitFromSHA <- lookupCommit repo (parseOid "f7acdbed") :: Maybe Commit -} {- $commits If you don't have a commit object, the recommend way to create one is by creating a 'Git.Libgit2.Common.Signature' and using it to modify the return value from 'Git.Libgit2.Commit.create'. This requires a 'Repository' object: > now <- getCurrentTime > let sig = Signature { > signatureName = "John Smith" > , signatureEmail = "johnsmith@nowhere.org" > , signatureWhen = now } > c = (createCommit repo) { > , commitAuthor = sig > , commitCommitter = sig } > Load a 'Git.Libgit2.Commit.Commit', and thereafter its history through its parents, or load a 'Git.Libgit2.Tree.Tree' or 'Git.Libgit2.Blob.Blob' from its contents. 3. Construct a new commit -}gitlib-2.2.0.0/Git/Types.hs0000644000000000000000000003635612246007504013511 0ustar0000000000000000module Git.Types where import Control.Applicative import qualified Control.Exception.Lifted as Exc import Control.Failure import Control.Monad.IO.Class import qualified Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import Data.Conduit import Data.Default import Data.HashMap.Strict (HashMap) import Data.Hashable import Data.Map (Map) import Data.Monoid import Data.Tagged import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable --import System.Posix.ByteString.FilePath type RawFilePath = ByteString data RepositoryFacts = RepositoryFacts { hasSymbolicReferences :: !Bool } deriving Show type MonadGit m = (Failure GitException m, Applicative m, MonadIO m, MonadBaseControl IO m) type RefName = Text type CommitAuthor = Text type CommitEmail = Text type CommitMessage = Text type TreeFilePath = RawFilePath -- | 'Repository' is the central point of contact between user code and Git -- data objects. Every object must belong to some repository. class (Applicative m, Monad m, Failure GitException m, IsOid (Oid m)) => Repository m where type Oid m :: * data Tree m :: * data Options m :: * facts :: m RepositoryFacts parseOid :: Text -> m (Oid m) deleteRepository :: m () -- References createReference :: RefName -> RefTarget m -> m () lookupReference :: RefName -> m (Maybe (RefTarget m)) updateReference :: RefName -> RefTarget m -> m () deleteReference :: RefName -> m () listReferences :: m [RefName] -- Object lookup lookupCommit :: CommitOid m -> m (Commit m) lookupTree :: TreeOid m -> m (Tree m) lookupBlob :: BlobOid m -> m (Blob m) lookupTag :: TagOid m -> m (Tag m) lookupObject :: Oid m -> m (Object m) existsObject :: Oid m -> m Bool sourceObjects :: Maybe (CommitOid m) -- ^ A commit we may already have -> CommitOid m -- ^ The commit we need -> Bool -- ^ Include commit trees also? -> Producer m (ObjectOid m) -- ^ All the objects in between -- Working with trees newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m) treeOid :: Tree m -> TreeOid m treeEntry :: Tree m -> TreeFilePath -> m (Maybe (TreeEntry m)) listTreeEntries :: Tree m -> m [(TreeFilePath, TreeEntry m)] diffContentsWithTree :: Source m (Either TreeFilePath ByteString) -> Tree m -> Producer m ByteString -- Creating other objects hashContents :: BlobContents m -> m (BlobOid m) createBlob :: BlobContents m -> m (BlobOid m) createCommit :: [CommitOid m] -> TreeOid m -> Signature -> Signature -> CommitMessage -> Maybe RefName -> m (Commit m) createTag :: CommitOid m -> Signature -> CommitMessage -> Text -> m (Tag m) -- -- Pack files -- buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] -- -> m FilePath -- buildPackFile _ _ = -- failure (BackendError "Backend does not support building pack files") -- buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) -- buildPackIndex _ _ = -- failure (BackendError "Backend does not support building pack indexes") -- writePackFile :: FilePath -> m () -- writePackFile _ = -- failure (BackendError "Backend does not support writing pack files") -- -- Git remotes -- remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () data RepositoryOptions = RepositoryOptions { repoPath :: !FilePath , repoIsBare :: !Bool , repoAutoCreate :: !Bool } instance Default RepositoryOptions where def = RepositoryOptions "" True True data RepositoryFactory t m c = RepositoryFactory { openRepository :: RepositoryOptions -> m c , runRepository :: forall a. c -> t a -> m a , closeRepository :: c -> m () , getRepository :: t c , defaultOptions :: !RepositoryOptions , startupBackend :: m () , shutdownBackend :: m () } {- $oids -} class (Eq o, Ord o, Show o) => IsOid o where renderOid :: o -> Text renderOid = renderObjOid . Tagged renderObjOid :: Tagged a o -> Text renderObjOid = renderOid . untag type BlobOid m = Tagged (Blob m) (Oid m) type TreeOid m = Tagged (Tree m) (Oid m) type CommitOid m = Tagged (Commit m) (Oid m) type TagOid m = Tagged (Tag m) (Oid m) data ObjectOid m = BlobObjOid !(BlobOid m) | TreeObjOid !(TreeOid m) | CommitObjOid !(CommitOid m) | TagObjOid !(TagOid m) parseObjOid :: Repository m => forall o. Text -> m (Tagged o (Oid m)) parseObjOid sha = Tagged <$> parseOid sha copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n) copyOid = parseOid . renderOid newtype SHA = SHA { getSHA :: ByteString } deriving (Eq, Ord, Read) shaToText :: SHA -> Text shaToText (SHA bs) = T.decodeUtf8 (B16.encode bs) textToSha :: Monad m => Text -> m SHA textToSha t = case B16.decode $ T.encodeUtf8 t of (bs, "") -> return (SHA bs) _ -> fail "Invalid base16 encoding" instance IsOid SHA where renderOid = shaToText instance Show SHA where show = T.unpack . shaToText instance Bin.Binary SHA where put (SHA t) = Bin.put t get = SHA <$> Bin.get instance Hashable SHA where hashWithSalt salt (SHA bs) = hashWithSalt salt bs {- $blobs -} data Blob m = Blob { blobOid :: !(BlobOid m) , blobContents :: !(BlobContents m) } type ByteSource m = Producer m ByteString data BlobContents m = BlobString !ByteString | BlobStream !(ByteSource m) | BlobSizedStream !(ByteSource m) !Int data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob | UnknownBlob deriving (Show, Eq, Enum) instance Eq (BlobContents m) where BlobString str1 == BlobString str2 = str1 == str2 _ == _ = False {- $trees -} data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m) , blobEntryKind :: !BlobKind } | TreeEntry { treeEntryOid :: !(TreeOid m) } | CommitEntry { commitEntryOid :: !(CommitOid m) } instance Repository m => Show (TreeEntry m) where show (BlobEntry oid _) = " TreeEntry m -> Oid m treeEntryToOid (BlobEntry boid _) = untag boid treeEntryToOid (TreeEntry toid) = untag toid treeEntryToOid (CommitEntry coid) = untag coid data TreeBuilder m = TreeBuilder { mtbBaseTreeOid :: Maybe (TreeOid m) , mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder m) , mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m) , mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid m) , mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry m)) , mtbEntryCount :: m Int , mtbPutEntry :: TreeBuilder m -> TreeFilePath -> TreeEntry m -> m (ModifiedBuilder m) , mtbDropEntry :: TreeBuilder m -> TreeFilePath -> m (ModifiedBuilder m) } data ModifiedBuilder m = ModifiedBuilder (TreeBuilder m) | BuilderUnchanged (TreeBuilder m) instance Monoid (ModifiedBuilder m) where mempty = BuilderUnchanged (error "ModifiedBuilder is a semigroup") BuilderUnchanged _ `mappend` BuilderUnchanged b2 = BuilderUnchanged b2 ModifiedBuilder b1 `mappend` BuilderUnchanged _ = ModifiedBuilder b1 BuilderUnchanged _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2 ModifiedBuilder _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2 fromBuilderMod :: ModifiedBuilder m -> TreeBuilder m fromBuilderMod (BuilderUnchanged tb) = tb fromBuilderMod (ModifiedBuilder tb) = tb {- $commits -} data Commit m = Commit { commitOid :: !(CommitOid m) , commitParents :: ![CommitOid m] , commitTree :: !(TreeOid m) , commitAuthor :: !Signature , commitCommitter :: !Signature , commitLog :: !CommitMessage , commitEncoding :: !Text } lookupCommitParents :: Repository m => Commit m -> m [Commit m] lookupCommitParents = mapM lookupCommit . commitParents data Signature = Signature { signatureName :: !CommitAuthor , signatureEmail :: !CommitEmail , signatureWhen :: !ZonedTime } deriving Show instance Default Signature where def = Signature { signatureName = T.empty , signatureEmail = T.empty , signatureWhen = ZonedTime { zonedTimeToLocalTime = LocalTime { localDay = ModifiedJulianDay 0 , localTimeOfDay = TimeOfDay 0 0 0 } , zonedTimeZone = utc } } {- $tags -} data Tag m = Tag { tagOid :: !(TagOid m) , tagCommit :: !(CommitOid m) } {- $objects -} data Object m = BlobObj !(Blob m) | TreeObj !(Tree m) | CommitObj !(Commit m) | TagObj !(Tag m) objectOid :: Repository m => Object m -> Oid m objectOid (BlobObj obj) = untag (blobOid obj) objectOid (TreeObj obj) = untag (treeOid obj) objectOid (CommitObj obj) = untag (commitOid obj) objectOid (TagObj obj) = untag (tagOid obj) loadObject :: Repository m => ObjectOid m -> m (Object m) loadObject (BlobObjOid oid) = BlobObj <$> lookupBlob oid loadObject (TreeObjOid oid) = TreeObj <$> lookupTree oid loadObject (CommitObjOid oid) = CommitObj <$> lookupCommit oid loadObject (TagObjOid oid) = TagObj <$> lookupTag oid objectToObjOid :: Repository m => Object m -> ObjectOid m objectToObjOid (BlobObj obj) = BlobObjOid (blobOid obj) objectToObjOid (TreeObj obj) = TreeObjOid (treeOid obj) objectToObjOid (CommitObj obj) = CommitObjOid (commitOid obj) objectToObjOid (TagObj obj) = TagObjOid (tagOid obj) untagObjOid :: Repository m => ObjectOid m -> Oid m untagObjOid (BlobObjOid oid) = untag oid untagObjOid (TreeObjOid oid) = untag oid untagObjOid (CommitObjOid oid) = untag oid untagObjOid (TagObjOid oid) = untag oid {- $references -} data RefTarget m = RefObj !(Oid m) | RefSymbolic !RefName instance Repository m => Show (RefTarget m) where show (RefObj oid) = "RefObj#" ++ T.unpack (renderOid oid) show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name commitRefTarget :: Commit m -> RefTarget m commitRefTarget = RefObj . untag . commitOid {- $merges -} data ModificationKind = Unchanged | Modified | Added | Deleted | TypeChanged deriving (Eq, Ord, Enum, Show, Read) data MergeStatus = NoConflict | BothModified | LeftModifiedRightDeleted | LeftDeletedRightModified | BothAdded | LeftModifiedRightTypeChanged | LeftTypeChangedRightModified | LeftDeletedRightTypeChanged | LeftTypeChangedRightDeleted | BothTypeChanged deriving (Eq, Ord, Enum, Show, Read) mergeStatus :: ModificationKind -> ModificationKind -> MergeStatus mergeStatus Unchanged Unchanged = NoConflict mergeStatus Unchanged Modified = NoConflict mergeStatus Unchanged Added = undefined mergeStatus Unchanged Deleted = NoConflict mergeStatus Unchanged TypeChanged = NoConflict mergeStatus Modified Unchanged = NoConflict mergeStatus Modified Modified = BothModified mergeStatus Modified Added = undefined mergeStatus Modified Deleted = LeftModifiedRightDeleted mergeStatus Modified TypeChanged = LeftModifiedRightTypeChanged mergeStatus Added Unchanged = undefined mergeStatus Added Modified = undefined mergeStatus Added Added = BothAdded mergeStatus Added Deleted = undefined mergeStatus Added TypeChanged = undefined mergeStatus Deleted Unchanged = NoConflict mergeStatus Deleted Modified = LeftDeletedRightModified mergeStatus Deleted Added = undefined mergeStatus Deleted Deleted = NoConflict mergeStatus Deleted TypeChanged = LeftDeletedRightTypeChanged mergeStatus TypeChanged Unchanged = NoConflict mergeStatus TypeChanged Modified = LeftTypeChangedRightModified mergeStatus TypeChanged Added = undefined mergeStatus TypeChanged Deleted = LeftTypeChangedRightDeleted mergeStatus TypeChanged TypeChanged = BothTypeChanged data MergeResult m = MergeSuccess { mergeCommit :: CommitOid m } | MergeConflicted { mergeCommit :: CommitOid m , mergeHeadLeft :: CommitOid m , mergeHeadRight :: CommitOid m , mergeConflicts :: Map TreeFilePath (ModificationKind, ModificationKind) } copyMergeResult :: (Repository m, MonadGit m, Repository n, MonadGit n) => MergeResult m -> n (MergeResult n) copyMergeResult (MergeSuccess mc) = MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc)) copyMergeResult (MergeConflicted hl hr mc cs) = MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl)) <*> (Tagged <$> parseOid (renderObjOid hr)) <*> (Tagged <$> parseOid (renderObjOid mc)) <*> pure cs instance Repository m => Show (MergeResult m) where show (MergeSuccess mc) = "MergeSuccess (" ++ show mc ++ ")" show (MergeConflicted mc hl hr cs) = "MergeResult" ++ "\n { mergeCommit = " ++ show mc ++ "\n , mergeHeadLeft = " ++ show hl ++ "\n , mergeHeadRight = " ++ show hr ++ "\n , mergeConflicts = " ++ show cs ++ "\n }" {- $exceptions -} -- | There is a separate 'GitException' for each possible failure when -- interacting with the Git repository. data GitException = BackendError Text | GitError Text | RepositoryNotExist | RepositoryInvalid | RepositoryCannotAccess Text | BlobCreateFailed Text | BlobEmptyCreateFailed | BlobEncodingUnknown Text | BlobLookupFailed | DiffBlobFailed Text | DiffPrintToPatchFailed Text | DiffTreeToIndexFailed Text | IndexAddFailed TreeFilePath Text | IndexCreateFailed Text | PushNotFastForward Text | TranslationException Text | TreeCreateFailed Text | TreeBuilderCreateFailed | TreeBuilderInsertFailed TreeFilePath | TreeBuilderRemoveFailed TreeFilePath | TreeBuilderWriteFailed Text | TreeLookupFailed | TreeCannotTraverseBlob | TreeCannotTraverseCommit | TreeEntryLookupFailed TreeFilePath | TreeUpdateFailed | TreeWalkFailed | TreeEmptyCreateFailed | CommitCreateFailed | CommitLookupFailed Text | ReferenceCreateFailed RefName | ReferenceDeleteFailed RefName | RefCannotCreateFromPartialOid | ReferenceListingFailed | ReferenceLookupFailed RefName | ObjectLookupFailed Text Int | ObjectRefRequiresFullOid | OidCopyFailed | OidParseFailed Text | QuotaHardLimitExceeded Int Int deriving (Eq, Show, Typeable) -- jww (2013-02-11): Create a BackendException data constructor of forall -- e. Exception e => BackendException e, so that each can throw a derived -- exception. instance Exc.Exception GitException gitlib-2.2.0.0/Git/Commit/0000755000000000000000000000000012246007504013264 5ustar0000000000000000gitlib-2.2.0.0/Git/Commit/Push.hs0000644000000000000000000000347012246007504014543 0ustar0000000000000000module Git.Commit.Push where import Control.Failure import Control.Monad import Control.Monad.Trans.Class import Data.Function import qualified Data.HashSet as HashSet import Data.List import Data.Maybe import Data.Monoid import Data.Tagged import Data.Text (Text) import Data.Traversable (for) import Git.Commit import Git.Object import Git.Reference import Git.Types import Prelude hiding (FilePath) -- | Fast-forward push a reference between repositories using a recursive -- copy. This can be extremely slow, but always works no matter which two -- backends are being used. It should be considered a matter of last -- resort, or for objects sets that are known to be small. pushCommit :: (Repository m, Repository (t m), MonadTrans t) => CommitOid m -> Text -> t m (CommitOid (t m)) pushCommit coid remoteRefName = do commits <- mapM copyCommitOid =<< lift (listCommits Nothing coid) mrref <- fmap Tagged `liftM` resolveReference remoteRefName mrref' <- for mrref $ \rref -> if rref `elem` commits then lift $ copyCommitOid rref else failure $ PushNotFastForward $ "SHA " <> renderObjOid rref <> " not found in remote" objs <- lift $ listAllObjects mrref' coid let shas = HashSet.fromList $ map (renderOid . untagObjOid) objs (cref,_) <- copyCommit coid Nothing shas unless (renderObjOid coid == renderObjOid cref) $ failure $ BackendError $ "Error copying commit: " <> renderObjOid coid <> " /= " <> renderObjOid cref -- jww (2013-04-18): This is something the user must decide to do -- updateReference_ remoteRefName (RefObj cref) return cref gitlib-2.2.0.0/Git/Tree/0000755000000000000000000000000012246007504012733 5ustar0000000000000000gitlib-2.2.0.0/Git/Tree/Builder.hs0000644000000000000000000002516012246007504014661 0ustar0000000000000000module Git.Tree.Builder ( TreeT , TreeBuilder(..) , ModifiedBuilder(..) , createTree , withNewTree , mutateTree , mutateTreeOid , currentTree , currentTreeOid , withTree , withTreeOid , dropEntry , getEntry , putBlob , putBlob' , putCommit , putEntry , putTree , treeEntry , ModifyTreeResult(..) , fromModifyTreeResult , toModifyTreeResult , emptyTreeId ) where import Control.Applicative import Control.Failure import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Data.ByteString as B import Data.Char import qualified Data.HashMap.Strict as HashMap import Data.Monoid import Data.Text (Text) import Data.Word import Git.Types data ModifyTreeResult m = TreeEntryNotFound | TreeEntryDeleted | TreeEntryPersistent (TreeEntry m) | TreeEntryMutated (TreeEntry m) fromModifyTreeResult :: ModifyTreeResult m -> Maybe (TreeEntry m) fromModifyTreeResult TreeEntryNotFound = Nothing fromModifyTreeResult TreeEntryDeleted = Nothing fromModifyTreeResult (TreeEntryPersistent x) = Just x fromModifyTreeResult (TreeEntryMutated x) = Just x toModifyTreeResult :: (TreeEntry m -> ModifyTreeResult m) -> Maybe (TreeEntry m) -> ModifyTreeResult m toModifyTreeResult _ Nothing = TreeEntryNotFound toModifyTreeResult f (Just x) = f x newtype TreeT m a = TreeT { runTreeT :: StateT (TreeBuilder m) m a } instance Functor m => Functor (TreeT m) where fmap f (TreeT t) = TreeT (fmap f t) instance Monad m => Monad (TreeT m) where return x = TreeT (return x) TreeT x >>= f = TreeT (x >>= runTreeT . f) instance (Functor m, Monad m) => Applicative (TreeT m) where pure = return (<*>) = ap instance (Functor m, MonadPlus m) => Alternative (TreeT m) where empty = mzero (<|>) = mplus instance (MonadPlus m) => MonadPlus (TreeT m) where mzero = TreeT mzero m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n instance (MonadFix m) => MonadFix (TreeT m) where mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) instance MonadTrans TreeT where lift m = TreeT $ lift m instance (MonadIO m) => MonadIO (TreeT m) where liftIO = lift . liftIO getBuilder :: Monad m => TreeT m (TreeBuilder m) getBuilder = TreeT get putBuilder :: Monad m => TreeBuilder m -> TreeT m () putBuilder = TreeT . put data BuilderAction = GetEntry | PutEntry | DropEntry deriving (Eq, Show) emptyTreeId :: Text emptyTreeId = "4b825dc642cb6eb9a060e54bf8d69288fbee4904" -- | Perform a query action on a TreeBuilder using the supplied action kind -- and user function. -- -- This is a complex algorithm which has been rewritten many times, so I -- will try to guide you through it as best I can. queryTreeBuilder :: Repository m => TreeBuilder m -> TreeFilePath -> BuilderAction -> (Maybe (TreeEntry m) -> ModifyTreeResult m) -> m (TreeBuilder m, Maybe (TreeEntry m)) queryTreeBuilder builder path kind f = do (mtb, mtresult) <- walk (BuilderUnchanged builder) (splitDirectories path) return (fromBuilderMod mtb, fromModifyTreeResult mtresult) where walk _ [] = error "queryTreeBuilder called without a path" walk bm (name:names) = do let tb = fromBuilderMod bm y <- case HashMap.lookup name (mtbPendingUpdates tb) of Just x -> return $ Left (BuilderUnchanged x) Nothing -> do mentry <- mtbLookupEntry tb name case mentry of Nothing | kind == PutEntry && not (null names) -> Left . ModifiedBuilder <$> mtbNewBuilder tb Nothing | otherwise -> return $ Right Nothing Just x -> return $ Right (Just x) update bm name names y doUpdate GetEntry bm name sbm = do (_, tref) <- writeTreeBuilder (fromBuilderMod sbm) returnTree bm name $ f (Just (TreeEntry tref)) doUpdate _ bm name _ = returnTree bm name (f Nothing) update bm name [] (Left sbm) = doUpdate kind bm name sbm update bm name [] (Right y) = returnTree bm name (f y) update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound) update _ _ _ (Right (Just BlobEntry {})) = failure TreeCannotTraverseBlob update _ _ _ (Right (Just CommitEntry {})) = failure TreeCannotTraverseCommit update bm name names arg = do sbm <- case arg of Left sbm' -> return sbm' Right (Just (TreeEntry st')) -> do tree <- lookupTree st' ModifiedBuilder <$> mtbNewBuilder (fromBuilderMod bm) (Just tree) _ -> error "queryTreeBuilder encountered the impossible" (sbm', z) <- walk sbm names let bm' = bm <> postUpdate bm sbm' name return $ bm' `seq` (bm', z) returnTree bm@(fromBuilderMod -> tb) n z = do bm' <- case z of TreeEntryNotFound -> return bm TreeEntryPersistent _ -> return bm TreeEntryDeleted -> do bm' <- mtbDropEntry tb tb n let tb' = fromBuilderMod bm' upds' = mtbPendingUpdates tb' return $ case bm' of ModifiedBuilder _ -> ModifiedBuilder tb' { mtbPendingUpdates = HashMap.delete n upds' } BuilderUnchanged _ -> if HashMap.member n upds' then ModifiedBuilder tb' { mtbPendingUpdates = HashMap.delete n upds' } else bm' TreeEntryMutated z' -> mtbPutEntry tb tb n z' let bm'' = bm <> bm' return $ bm'' `seq` (bm'', z) postUpdate bm (BuilderUnchanged _) _ = bm postUpdate (fromBuilderMod -> tb) (ModifiedBuilder sbm) name = ModifiedBuilder $ tb { mtbPendingUpdates = HashMap.insert name sbm (mtbPendingUpdates tb) } pathSeparator :: Word8 pathSeparator = fromIntegral $ ord '/' isPathSeparator :: Word8 -> Bool isPathSeparator = (== pathSeparator) splitDirectories :: RawFilePath -> [RawFilePath] splitDirectories x | B.null x = [] | isPathSeparator (B.head x) = let (root,rest) = B.splitAt 1 x in root : splitter rest | otherwise = splitter x where splitter = filter (not . B.null) . B.split pathSeparator -- | Write out a tree to its repository. If it has already been written, -- nothing will happen. writeTreeBuilder :: Repository m => TreeBuilder m -> m (TreeBuilder m, TreeOid m) writeTreeBuilder builder = do (bm, mtref) <- go (BuilderUnchanged builder) tref <- case mtref of Nothing -> parseObjOid emptyTreeId Just tref -> return tref return (fromBuilderMod bm, tref) where go bm = do let upds = mtbPendingUpdates (fromBuilderMod bm) bm' <- if HashMap.size upds == 0 then return bm else do bm' <- foldM update bm $ HashMap.toList upds return $ ModifiedBuilder (fromBuilderMod bm') { mtbPendingUpdates = HashMap.empty } let tb' = fromBuilderMod bm' cnt <- mtbEntryCount tb' if cnt == 0 then return (bm', Nothing) else do (bm'', tref) <- mtbWriteContents tb' tb' return (bm' <> bm'', Just tref) update bm (k,v) = do let tb = fromBuilderMod bm -- The intermediate TreeBuilder will be dropped after this fold is -- completed, by setting mtbPendingUpdates to HashMap.empty, above. (_,mtref) <- go (BuilderUnchanged v) bm' <- case mtref of Nothing -> mtbDropEntry tb tb k Just tref -> mtbPutEntry tb tb k (TreeEntry tref) return $ bm <> bm' getEntry :: Repository m => TreeFilePath -> TreeT m (Maybe (TreeEntry m)) getEntry path = do tb <- getBuilder snd <$> lift (queryTreeBuilder tb path GetEntry (toModifyTreeResult TreeEntryPersistent)) putEntry :: Repository m => TreeFilePath -> TreeEntry m -> TreeT m () putEntry path ent = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry (const (TreeEntryMutated ent))) putBuilder tb' dropEntry :: Repository m => TreeFilePath -> TreeT m () dropEntry path = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry (const TreeEntryDeleted)) putBuilder tb' putBlob' :: Repository m => TreeFilePath -> BlobOid m -> BlobKind -> TreeT m () putBlob' path b kind = putEntry path (BlobEntry b kind) putBlob :: Repository m => TreeFilePath -> BlobOid m -> TreeT m () putBlob path b = putBlob' path b PlainBlob putTree :: Repository m => TreeFilePath -> TreeOid m -> TreeT m () putTree path t = putEntry path (TreeEntry t) putCommit :: Repository m => TreeFilePath -> CommitOid m -> TreeT m () putCommit path c = putEntry path (CommitEntry c) doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeOid m) doWithTree mtr act = fst <$> (runStateT (runTreeT go) =<< newTreeBuilder mtr) where go = liftM2 (,) act currentTreeOid withTree :: Repository m => Tree m -> TreeT m a -> m (a, TreeOid m) withTree tr = doWithTree (Just tr) withTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (a, TreeOid m) withTreeOid oid action = do tree <- lookupTree oid doWithTree (Just tree) action mutateTree :: Repository m => Tree m -> TreeT m a -> m (TreeOid m) mutateTree tr action = snd <$> withTree tr action mutateTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (TreeOid m) mutateTreeOid tr action = snd <$> withTreeOid tr action currentTreeOid :: Repository m => TreeT m (TreeOid m) currentTreeOid = do tb <- getBuilder (tb', toid) <- lift $ writeTreeBuilder tb putBuilder tb' return toid currentTree :: Repository m => TreeT m (Tree m) currentTree = lift . lookupTree =<< currentTreeOid withNewTree :: Repository m => TreeT m a -> m (a, TreeOid m) withNewTree = doWithTree Nothing createTree :: Repository m => TreeT m a -> m (TreeOid m) createTree action = snd <$> withNewTree action gitlib-2.2.0.0/Git/Tree/Builder/0000755000000000000000000000000012246007504014321 5ustar0000000000000000gitlib-2.2.0.0/Git/Tree/Builder/Pure.hs0000644000000000000000000000425412246007504015575 0ustar0000000000000000module Git.Tree.Builder.Pure ( EntryHashMap , newPureTreeBuilder ) where import Control.Applicative import Data.Monoid import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Git type EntryHashMap m = HashMap TreeFilePath (TreeEntry m) -- | Create a new, empty tree. -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op. newPureTreeBuilder :: Repository m => (Tree m -> m (EntryHashMap m)) -> (EntryHashMap m -> m (TreeOid m)) -> Maybe (Tree m) -> m (TreeBuilder m) newPureTreeBuilder reader writer mtree = do entMap <- case mtree of Nothing -> return HashMap.empty Just tree -> reader tree return $ makePureBuilder (treeOid <$> mtree) mempty (newPureTreeBuilder reader writer) entMap writer makePureBuilder :: Repository m => Maybe (TreeOid m) -> HashMap TreeFilePath (TreeBuilder m) -> (Maybe (Tree m) -> m (TreeBuilder m)) -> EntryHashMap m -> (EntryHashMap m -> m (TreeOid m)) -> TreeBuilder m makePureBuilder baseTree upds newBuilder entMap writer = TreeBuilder { mtbBaseTreeOid = baseTree , mtbPendingUpdates = upds , mtbNewBuilder = newBuilder , mtbWriteContents = \tb -> (,) <$> pure (BuilderUnchanged tb) <*> writer entMap , mtbLookupEntry = \key -> return $ HashMap.lookup key entMap , mtbEntryCount = return $ HashMap.size entMap , mtbPutEntry = \tb key ent -> return . ModifiedBuilder $ makePureBuilder baseTree (mtbPendingUpdates tb) newBuilder (HashMap.insert key ent entMap) writer , mtbDropEntry = \tb key -> return . ModifiedBuilder $ makePureBuilder baseTree (mtbPendingUpdates tb) newBuilder (HashMap.delete key entMap) writer }