gitlib-3.1.2/0000755000000000000000000000000013303656006011157 5ustar0000000000000000gitlib-3.1.2/Setup.hs0000644000000000000000000000005513303656006012613 0ustar0000000000000000import Distribution.Simple main = defaultMaingitlib-3.1.2/LICENSE0000644000000000000000000000203713303656006012166 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-3.1.2/gitlib.cabal0000644000000000000000000000556713303656006013432 0ustar0000000000000000Name: gitlib Version: 3.1.2 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT Author: John Wiegley Maintainer: johnw@newartisans.com Build-Type: Simple Cabal-Version: >=1.10 Category: FFI Homepage: https://github.com/jwiegley/gitlib 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/jwiegley/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 , bytestring >= 0.9.2.1 , conduit >= 1.2.8 , conduit-combinators >= 1 , containers >= 0.4.2.1 , directory >= 1.1.0.2 , exceptions >= 0.5 , filepath >= 1.3 , hashable >= 1.1.2.5 , mtl >= 2.1.2 , resourcet >= 1.1.0 , semigroups >= 0.11 , tagged >= 0.2.3.1 , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0 , unordered-containers >= 0.2.3.0 , unliftio-core >= 0.1.1 , unliftio if !os(mingw32) build-depends: unix >= 2.5.1.1 else build-depends: unix-compat >= 0.4 exposed-modules: Git Git.Blob Git.Commit Git.Commit.Push Git.Object Git.Reference Git.Repository Git.Tree Git.Tree.Builder Git.Tree.Builder.Pure Git.Tree.Working Git.Tutorial Git.Types Git.Utils Git.Working default-extensions: BangPatterns ConstraintKinds DeriveDataTypeable FlexibleContexts FunctionalDependencies MultiParamTypeClasses OverloadedStrings RankNTypes TypeFamilies ViewPatterns gitlib-3.1.2/Git.hs0000644000000000000000000000047313303656006012242 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-3.1.2/Git/0000755000000000000000000000000013303656006011702 5ustar0000000000000000gitlib-3.1.2/Git/Reference.hs0000644000000000000000000000100713303656006014132 0ustar0000000000000000module Git.Reference where import Conduit import Git.Types listReferences :: MonadGit r m => m [RefName] listReferences = runConduit $ sourceReferences .| sinkList resolveReference :: MonadGit r m => RefName -> m (Maybe (Oid r)) resolveReference name = do mref <- lookupReference name maybe (return Nothing) referenceToOid mref referenceToOid :: MonadGit r m => RefTarget r -> m (Maybe (Oid r)) referenceToOid (RefObj oid) = return $ Just oid referenceToOid (RefSymbolic name) = resolveReference name gitlib-3.1.2/Git/Utils.hs0000644000000000000000000000002713303656006013335 0ustar0000000000000000module Git.Utils where gitlib-3.1.2/Git/Working.hs0000644000000000000000000000410513303656006013656 0ustar0000000000000000{-# LANGUAGE CPP #-} module Git.Working where import Conduit import Control.Applicative import Control.Monad.Catch import Data.Semigroup import Data.Text as T import Git.Blob import Git.Types import System.Directory import System.FilePath #if !mingw32_HOST_OS import System.Posix.Files #endif checkoutFiles :: (MonadGit r m, MonadResource m) => FilePath -> Tree r -> (TreeFilePath -> Either String FilePath) -> Bool -> m () checkoutFiles destPath tree decode cloneSubmodules = runConduit $ sourceTreeEntries tree .| (mapM_C $ \(path, entry) -> case (destPath ) <$> decode path of Left e -> decodeError path e Right fullPath -> do liftIO $ createDirectoryIfMissing True (takeDirectory fullPath) case entry of TreeEntry {} -> return () BlobEntry oid kind -> checkoutBlob oid kind fullPath CommitEntry oid -- jww (2013-12-26): Recursively clone submodules? | cloneSubmodules -> cloneSubmodule oid fullPath | otherwise -> liftIO $ createDirectory fullPath) where decodeError path e = throwM $ PathEncodingError $ "Could not decode path " <> T.pack (show path) <> ":" <> T.pack e checkoutBlob oid kind fullPath = do Blob _ contents <- lookupBlob oid case kind of #if !mingw32_HOST_OS SymlinkBlob -> do target <- blobContentsToByteString contents case decode target of Left e -> decodeError target e Right targetPath -> liftIO $ createSymbolicLink targetPath fullPath #endif _ -> do -- PlainBlob | ExecutableBlob -- jww (2013-12-26): There is no way to know what a tree's -- path has been encoded as. writeBlob fullPath contents cloneSubmodule = error "jww (2013-12-29): Cloning submodule is not yet implemented" gitlib-3.1.2/Git/Blob.hs0000644000000000000000000000641013303656006013115 0ustar0000000000000000module Git.Blob where import Conduit import Control.Applicative import Control.Monad import Data.ByteString as B import qualified Data.ByteString.Lazy as BL 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 :: MonadGit r m => Text -> m (BlobOid r) createBlobUtf8 = createBlob . BlobString . T.encodeUtf8 catBlob :: MonadGit r m => BlobOid r -> m ByteString catBlob = lookupBlob >=> blobToByteString catBlobLazy :: MonadGit r m => BlobOid r -> m BL.ByteString catBlobLazy = lookupBlob >=> blobToLazyByteString catBlobUtf8 :: MonadGit r m => BlobOid r -> m Text catBlobUtf8 = catBlob >=> return . T.decodeUtf8 blobContentsToByteString :: MonadGit r m => BlobContents m -> m ByteString blobContentsToByteString (BlobString bs) = return bs blobContentsToByteString (BlobStringLazy bs) = return $ B.concat (BL.toChunks bs) blobContentsToByteString (BlobStream bs) = B.concat . BL.toChunks <$> (runConduit $ bs .| sinkLazy) blobContentsToByteString (BlobSizedStream bs _) = runConduit $ B.concat . BL.toChunks <$> (bs .| sinkLazy) blobToByteString :: MonadGit r m => Blob r m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents blobContentsToLazyByteString :: MonadGit r m => BlobContents m -> m BL.ByteString blobContentsToLazyByteString (BlobString bs) = return $ BL.fromChunks [bs] blobContentsToLazyByteString (BlobStringLazy bs) = return bs blobContentsToLazyByteString (BlobStream bs) = runConduit $ bs .| sinkLazy blobContentsToLazyByteString (BlobSizedStream bs _) = runConduit $ bs .| sinkLazy blobToLazyByteString :: MonadGit r m => Blob r m -> m BL.ByteString blobToLazyByteString (Blob _ contents) = blobContentsToLazyByteString contents writeBlob :: (MonadGit r m, MonadIO m, MonadResource m) => FilePath -> BlobContents m -> m () writeBlob path (BlobString bs) = liftIO $ B.writeFile path bs writeBlob path (BlobStringLazy bs) = runConduit $ sourceLazy bs .| sinkFile path writeBlob path (BlobStream str) = runConduit $ str .| sinkFile path writeBlob path (BlobSizedStream str _) = runConduit $ str .| sinkFile path treeBlobEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, BlobOid r, BlobKind)] treeBlobEntries tree = runConduit $ sourceTreeBlobEntries tree .| sinkList sourceTreeBlobEntries :: MonadGit r m => Tree r -> ConduitT i (TreeFilePath, BlobOid r, BlobKind) m () sourceTreeBlobEntries tree = sourceTreeEntries tree .| awaitForever go where go (fp ,BlobEntry oid k) = yield (fp, oid, k) go _ = return () copyBlob :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => BlobOid r -> HashSet Text -> t m (BlobOid s, 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-3.1.2/Git/Repository.hs0000644000000000000000000000365213303656006014423 0ustar0000000000000000module Git.Repository where import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Git.Types import System.Directory import UnliftIO.Exception withNewRepository :: (MonadGit r n, MonadUnliftIO n, MonadUnliftIO m) => RepositoryFactory n m r -> FilePath -> n 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 RepositoryOptions { repoPath = path , repoWorkingDir = Nothing , repoIsBare = True , repoAutoCreate = True } action liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path return a withNewRepository' :: (MonadGit r n, MonadUnliftIO n, MonadUnliftIO m) => RepositoryFactory n m r -> FilePath -> n a -> m a withNewRepository' factory path action = bracket_ recover recover $ withRepository' factory RepositoryOptions { repoPath = path , repoWorkingDir = Nothing , repoIsBare = True , repoAutoCreate = True } action where recover = liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path withRepository' :: (MonadGit r n, MonadUnliftIO n, MonadUnliftIO m) => RepositoryFactory n m r -> RepositoryOptions -> n a -> m a withRepository' factory opts action = do repo <- openRepository factory opts runRepository factory repo $ action `finally` closeRepository withRepository :: (MonadGit r n, MonadUnliftIO n, MonadUnliftIO m) => RepositoryFactory n m r -> FilePath -> n a -> m a withRepository factory path = withRepository' factory defaultRepositoryOptions { repoPath = path } gitlib-3.1.2/Git/Object.hs0000644000000000000000000000322213303656006013443 0ustar0000000000000000module Git.Object where import Conduit import Control.Monad import Data.Function import Data.Maybe import Git.Types import Prelude hiding (FilePath) listObjects :: MonadGit r m => Maybe (CommitOid r) -- ^ A commit we may already have -> CommitOid r -- ^ The commit we need -> Bool -- ^ Include commit trees also? -> m [ObjectOid r] -- ^ All the objects in between listObjects mhave need alsoTrees = runConduit $ sourceObjects mhave need alsoTrees .| sinkList traverseObjects :: MonadGit r m => (ObjectOid r -> m a) -> CommitOid r -> m [a] traverseObjects f need = mapM f =<< listObjects Nothing need False traverseObjects_ :: MonadGit r m => (ObjectOid r -> m ()) -> CommitOid r -> 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 :: MonadGit r m => ConduitT (ObjectOid r) (ObjectOid r) m () expandTreeObjects = awaitForever $ \obj -> case obj of TreeObjOid toid -> do yield $ TreeObjOid toid tr <- lift $ lookupTree toid sourceTreeEntries tr .| awaitForever (\ent -> case ent of (_, BlobEntry oid _) -> yield $ BlobObjOid oid (_, TreeEntry oid) -> yield $ TreeObjOid oid _ -> return ()) _ -> yield obj listAllObjects :: MonadGit r m => Maybe (CommitOid r) -> CommitOid r -> m [ObjectOid r] listAllObjects mhave need = runConduit $ sourceObjects mhave need True .| expandTreeObjects .| sinkList gitlib-3.1.2/Git/Tutorial.hs0000644000000000000000000000551613303656006014050 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 ... -} {- $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-3.1.2/Git/Tree.hs0000644000000000000000000000412413303656006013136 0ustar0000000000000000module Git.Tree where import Conduit import Control.Monad 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 listTreeEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, TreeEntry r)] listTreeEntries tree = runConduit $ sourceTreeEntries tree .| sinkList copyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry (BlobEntry oid kind) needed = do (b,needed') <- copyBlob oid needed unless (renderObjOid oid == renderObjOid b) $ throwM $ 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 :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeOid r -> HashSet Text -> t m (TreeOid s, 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 :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (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-3.1.2/Git/Types.hs0000644000000000000000000003570113303656006013350 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ > 707 {-# LANGUAGE AllowAmbiguousTypes #-} #endif module Git.Types where import Conduit import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans.State import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL import Data.HashMap.Strict (HashMap) import Data.Hashable import Data.Map (Map) import Data.Semigroup 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 type RawFilePath = ByteString data RepositoryFacts = RepositoryFacts { hasSymbolicReferences :: !Bool } deriving Show 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, MonadThrow m, IsOid (Oid r), Show (Oid r), Eq (Oid r), Ord (Oid r)) => MonadGit r m | m -> r where type Oid r :: * data Tree r :: * data Options r :: * facts :: m RepositoryFacts parseOid :: Text -> m (Oid r) getRepository :: m r closeRepository :: m () deleteRepository :: m () -- References createReference :: RefName -> RefTarget r -> m () lookupReference :: RefName -> m (Maybe (RefTarget r)) updateReference :: RefName -> RefTarget r -> m () deleteReference :: RefName -> m () sourceReferences :: ConduitT i RefName m () -- Object lookup lookupObject :: Oid r -> m (Object r m) existsObject :: Oid r -> m Bool sourceObjects :: Maybe (CommitOid r) -- ^ A commit we may already have -> CommitOid r -- ^ The commit we need -> Bool -- ^ Include commit trees also? -> ConduitT i (ObjectOid r) m () -- ^ All the objects in between lookupCommit :: CommitOid r -> m (Commit r) lookupTree :: TreeOid r -> m (Tree r) lookupBlob :: BlobOid r -> m (Blob r m) lookupTag :: TagOid r -> m (Tag r) readIndex :: TreeT r m () writeIndex :: TreeT r m () -- Working with trees newTreeBuilder :: Maybe (Tree r) -> m (TreeBuilder r m) treeOid :: Tree r -> m (TreeOid r) treeEntry :: Tree r -> TreeFilePath -> m (Maybe (TreeEntry r)) sourceTreeEntries :: Tree r -> ConduitT i (TreeFilePath, TreeEntry r) m () diffContentsWithTree :: ConduitT () (Either TreeFilePath ByteString) m () -> Tree r -> ConduitT i ByteString m () -- Creating other objects hashContents :: BlobContents m -> m (BlobOid r) createBlob :: BlobContents m -> m (BlobOid r) createCommit :: [CommitOid r] -> TreeOid r -> Signature -> Signature -> CommitMessage -> Maybe RefName -> m (Commit r) createTag :: CommitOid r -> Signature -> CommitMessage -> Text -> m (Tag r) data RepositoryOptions = RepositoryOptions { repoPath :: !FilePath , repoWorkingDir :: !(Maybe FilePath) , repoIsBare :: !Bool , repoAutoCreate :: !Bool } defaultRepositoryOptions :: RepositoryOptions defaultRepositoryOptions = RepositoryOptions "" Nothing False False data RepositoryFactory n m r = RepositoryFactory { openRepository :: RepositoryOptions -> m r , runRepository :: forall a. r -> n a -> m a } {- $oids -} class IsOid o where renderOid :: o -> Text renderOid = renderObjOid . Tagged renderObjOid :: Tagged a o -> Text renderObjOid = renderOid . untag type BlobOid r = Tagged r (Oid r) type TreeOid r = Tagged (Tree r) (Oid r) type CommitOid r = Tagged (Commit r) (Oid r) type TagOid r = Tagged (Tag r) (Oid r) data ObjectOid r = BlobObjOid !(BlobOid r) | TreeObjOid !(TreeOid r) | CommitObjOid !(CommitOid r) | TagObjOid !(TagOid r) parseObjOid :: MonadGit r m => forall o. Text -> m (Tagged o (Oid r)) parseObjOid sha = Tagged <$> parseOid sha copyOid :: (MonadGit r m, MonadGit s n) => Oid r -> n (Oid s) 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 Hashable SHA where hashWithSalt salt (SHA bs) = hashWithSalt salt bs {- $blobs -} data Blob r m = Blob { blobOid :: !(BlobOid r) , blobContents :: !(BlobContents m) } type ByteSource m = ConduitT () ByteString m () data BlobContents m = BlobString !ByteString | BlobStringLazy !BL.ByteString | BlobStream !(ByteSource m) | BlobSizedStream !(ByteSource m) !Int data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob deriving (Show, Eq, Enum) instance Eq (BlobContents m) where BlobString str1 == BlobString str2 = str1 == str2 _ == _ = False {- $trees -} newtype TreeT r m a = TreeT { runTreeT :: StateT (TreeBuilder r m) m a } data TreeEntry r = BlobEntry { blobEntryOid :: !(BlobOid r) , blobEntryKind :: !BlobKind } | TreeEntry { treeEntryOid :: !(TreeOid r) } | CommitEntry { commitEntryOid :: !(CommitOid r) } -- instance Show (TreeEntry r) where -- show (BlobEntry oid _) = "" -- show (TreeEntry oid) = "" -- show (CommitEntry oid) = "" treeEntryToOid :: TreeEntry r -> Oid r treeEntryToOid (BlobEntry boid _) = untag boid treeEntryToOid (TreeEntry toid) = untag toid treeEntryToOid (CommitEntry coid) = untag coid data TreeBuilder r m = TreeBuilder { mtbBaseTreeOid :: Maybe (TreeOid r) , mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder r m) , mtbNewBuilder :: Maybe (Tree r) -> m (TreeBuilder r m) , mtbWriteContents :: TreeBuilder r m -> m (ModifiedBuilder r m, TreeOid r) , mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry r)) , mtbEntryCount :: m Int , mtbPutEntry :: TreeBuilder r m -> TreeFilePath -> TreeEntry r -> m (ModifiedBuilder r m) , mtbDropEntry :: TreeBuilder r m -> TreeFilePath -> m (ModifiedBuilder r m) } data ModifiedBuilder r m = ModifiedBuilder (TreeBuilder r m) | BuilderUnchanged (TreeBuilder r m) instance Semigroup (ModifiedBuilder r m) where BuilderUnchanged _ <> BuilderUnchanged b2 = BuilderUnchanged b2 ModifiedBuilder b1 <> BuilderUnchanged _ = ModifiedBuilder b1 BuilderUnchanged _ <> ModifiedBuilder b2 = ModifiedBuilder b2 ModifiedBuilder _ <> ModifiedBuilder b2 = ModifiedBuilder b2 instance Monoid (ModifiedBuilder r m) where mempty = BuilderUnchanged (error "ModifiedBuilder is a semigroup") x `mappend` y = x <> y fromBuilderMod :: ModifiedBuilder r m -> TreeBuilder r m fromBuilderMod (BuilderUnchanged tb) = tb fromBuilderMod (ModifiedBuilder tb) = tb {- $commits -} data Commit r = Commit { commitOid :: !(CommitOid r) , commitParents :: ![CommitOid r] , commitTree :: !(TreeOid r) , commitAuthor :: !Signature , commitCommitter :: !Signature , commitLog :: !CommitMessage , commitEncoding :: !Text } sourceCommitParents :: MonadGit r m => Commit r -> ConduitT i (Commit r) m () sourceCommitParents commit = forM_ (commitParents commit) $ yield <=< lift . lookupCommit lookupCommitParents :: MonadGit r m => Commit r -> m [Commit r] lookupCommitParents commit = runConduit $ sourceCommitParents commit .| sinkList data Signature = Signature { signatureName :: !CommitAuthor , signatureEmail :: !CommitEmail , signatureWhen :: !ZonedTime } deriving Show defaultSignature :: Signature defaultSignature = Signature { signatureName = T.empty , signatureEmail = T.empty , signatureWhen = ZonedTime { zonedTimeToLocalTime = LocalTime { localDay = ModifiedJulianDay 0 , localTimeOfDay = TimeOfDay 0 0 0 } , zonedTimeZone = utc } } {- $tags -} data Tag r = Tag { tagOid :: !(TagOid r) , tagCommit :: !(CommitOid r) } {- $objects -} data Object r m = BlobObj !(Blob r m) | TreeObj !(Tree r) | CommitObj !(Commit r) | TagObj !(Tag r) objectOid :: MonadGit r m => Object r m -> m (Oid r) objectOid (BlobObj obj) = return $ untag (blobOid obj) objectOid (TreeObj obj) = untag <$> treeOid obj objectOid (CommitObj obj) = return $ untag (commitOid obj) objectOid (TagObj obj) = return $ untag (tagOid obj) loadObject :: MonadGit r m => ObjectOid r -> m (Object r 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 :: MonadGit r m => Object r m -> m (ObjectOid r) objectToObjOid (BlobObj obj) = return $ BlobObjOid (blobOid obj) objectToObjOid (TreeObj obj) = TreeObjOid <$> treeOid obj objectToObjOid (CommitObj obj) = return $ CommitObjOid (commitOid obj) objectToObjOid (TagObj obj) = return $ TagObjOid (tagOid obj) untagObjOid :: ObjectOid r -> Oid r untagObjOid (BlobObjOid oid) = untag oid untagObjOid (TreeObjOid oid) = untag oid untagObjOid (CommitObjOid oid) = untag oid untagObjOid (TagObjOid oid) = untag oid {- $references -} data RefTarget (r :: *) = RefObj !(Oid r) | RefSymbolic !RefName -- instance Show (RefTarget r) where -- show (RefObj oid) = "RefObj#" ++ T.unpack (renderOid oid) -- show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name commitRefTarget :: Commit r -> RefTarget r 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 r = MergeSuccess { mergeCommit :: CommitOid r } | MergeConflicted { mergeCommit :: CommitOid r , mergeHeadLeft :: CommitOid r , mergeHeadRight :: CommitOid r , mergeConflicts :: Map TreeFilePath (ModificationKind, ModificationKind) } copyMergeResult :: (MonadGit r m, IsOid (Oid s)) => MergeResult s -> m (MergeResult r) copyMergeResult (MergeSuccess mc) = MergeSuccess <$> parseObjOid (renderObjOid mc) copyMergeResult (MergeConflicted hl hr mc cs) = MergeConflicted <$> parseObjOid (renderObjOid hl) <*> parseObjOid (renderObjOid hr) <*> parseObjOid (renderObjOid mc) <*> pure cs -- instance Show (MergeResult r) where -- show (MergeSuccess mc) = -- "MergeSuccess (" ++ T.unpack (renderObjOid mc) ++ ")" -- show (MergeConflicted mc hl hr cs) = -- "MergeResult" -- ++ "\n { mergeCommit = " ++ T.unpack (renderObjOid mc) -- ++ "\n , mergeHeadLeft = " ++ T.unpack (renderObjOid hl) -- ++ "\n , mergeHeadRight = " ++ T.unpack (renderObjOid 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 | PathEncodingError Text | PushNotFastForward Text | TagLookupFailed Text | TranslationException Text | TreeCreateFailed Text | TreeBuilderCreateFailed | TreeBuilderInsertFailed TreeFilePath | TreeBuilderRemoveFailed TreeFilePath | TreeBuilderWriteFailed Text | TreeLookupFailed | TreeCannotTraverseBlob | TreeCannotTraverseCommit | TreeEntryLookupFailed TreeFilePath | TreeUpdateFailed | TreeWalkFailed Text | TreeEmptyCreateFailed | CommitCreateFailed | CommitLookupFailed Text | ReferenceCreateFailed RefName | ReferenceDeleteFailed RefName | RefCannotCreateFromPartialOid | ReferenceListingFailed Text | 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 Exception GitException gitlib-3.1.2/Git/Commit.hs0000644000000000000000000000554613303656006013500 0ustar0000000000000000module Git.Commit where import Conduit import Control.Monad 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 :: MonadGit r m => Commit r -> TreeFilePath -> m (Maybe (TreeEntry r)) commitTreeEntry c path = flip treeEntry path =<< lookupTree (commitTree c) copyCommitOid :: (IsOid (Oid r), MonadGit s n) => CommitOid r -> n (CommitOid s) copyCommitOid = parseObjOid . renderObjOid copyCommit :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => CommitOid r -> Maybe RefName -> HashSet Text -> t m (CommitOid s, 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) $ throwM $ 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) $ throwM $ BackendError $ "Error copying commit: " <> renderObjOid cref <> " /= " <> renderObjOid cref2 let x = cref2 `seq` (cref2:prefs) return $ x `seq` needed'' `seq` (x,needed'') listCommits :: MonadGit r m => Maybe (CommitOid r) -- ^ A commit we may already have -> CommitOid r -- ^ The commit we need -> m [CommitOid r] -- ^ All the objects in between listCommits mhave need = runConduit $ sourceObjects mhave need False .| mapMC (\(CommitObjOid c) -> return c) .| sinkList traverseCommits :: MonadGit r m => (CommitOid r -> m a) -> CommitOid r -> m [a] traverseCommits f need = mapM f =<< listCommits Nothing need traverseCommits_ :: MonadGit r m => (CommitOid r -> m ()) -> CommitOid r -> m () traverseCommits_ = (void .) . traverseCommits gitlib-3.1.2/Git/Commit/0000755000000000000000000000000013303656006013132 5ustar0000000000000000gitlib-3.1.2/Git/Commit/Push.hs0000644000000000000000000000672613303656006014420 0ustar0000000000000000module Git.Commit.Push where import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.IO.Unlift 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.Repository import Git.Types import Prelude -- | 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 :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => CommitOid r -> Text -> t m (CommitOid s) 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 throwM $ 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) $ throwM $ 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 copyRepository :: (MonadGit r m, MonadUnliftIO m, MonadGit s (t m), MonadTrans t, MonadUnliftIO (t m)) => RepositoryFactory (t m) m s -> Maybe (CommitOid r) -> Text -> FilePath -> Bool -> m () copyRepository factory mname refName gitDir isBare = withRepository' factory RepositoryOptions { repoPath = gitDir , repoWorkingDir = Nothing , repoIsBare = isBare , repoAutoCreate = True } (maybe (return ()) go mname) where go coid = do -- jww (2013-04-24): We don't need do download every object back to -- the first commit, but only the commits (and their objects) back to -- and including the common ancestor. The question is, how do we -- determine the common ancestor before we've fetched all the contents -- of at least one side? cref <- pushCommit coid refName -- This will always be a fast-forward, since temp.git is empty. The -- resulting HEAD will have the refname as the ref we want to push to -- or pull from, and no others. updateReference refName (RefObj (untag cref)) updateReference "HEAD" (RefSymbolic refName) mref <- fmap renderOid <$> resolveReference refName unless (maybe False (renderObjOid coid ==) mref) $ throwM (BackendError $ "Could not resolve destination reference '" <> refName <> "'in project") gitlib-3.1.2/Git/Tree/0000755000000000000000000000000013303656006012601 5ustar0000000000000000gitlib-3.1.2/Git/Tree/Working.hs0000644000000000000000000000572613303656006014567 0ustar0000000000000000{-# LANGUAGE CPP #-} module Git.Tree.Working where import Control.Applicative -- import Control.Concurrent.Async.Lifted import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Unlift -- import Control.Monad.Trans.Control import qualified Data.ByteString as B (readFile) import qualified Data.ByteString.Char8 as B8 import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Tagged import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Git hiding (Options) import Prelude hiding (log) import UnliftIO.Async import System.FilePath.Posix #ifndef mingw32_HOST_OS import System.Posix.Files #else import System.PosixCompat.Files #endif data FileEntry m = FileEntry { fileModTime :: UTCTime , fileBlobOid :: BlobOid m , fileBlobKind :: BlobKind , fileChecksum :: BlobOid m } type FileTree m = HashMap TreeFilePath (FileEntry m) readFileTree :: (MonadGit r m, MonadUnliftIO m) => RefName -> FilePath -> Bool -> m (FileTree r) readFileTree ref wdir getHash = do h <- resolveReference ref case h of Nothing -> pure Map.empty Just h' -> do tr <- lookupTree . commitTree =<< lookupCommit (Tagged h') readFileTree' tr wdir getHash readFileTree' :: (MonadGit r m, MonadUnliftIO m) => Tree r -> FilePath -> Bool -> m (FileTree r) readFileTree' tr wdir getHash = do blobs <- treeBlobEntries tr stats <- mapConcurrently go blobs return $ foldl' (\m (!fp,!fent) -> maybe m (flip (Map.insert fp) m) fent) Map.empty stats where go (!fp,!oid,!kind) = do fent <- readModTime wdir getHash (B8.unpack fp) oid kind fent `seq` return (fp,fent) readModTime :: (MonadIO m, MonadGit r m) => FilePath -> Bool -> FilePath -> BlobOid r -> BlobKind -> m (Maybe (FileEntry r)) readModTime wdir getHash fp oid kind = do let path = wdir fp -- debug' $ pack $ "Checking file: " ++ path estatus <- liftIO $ try $ getSymbolicLinkStatus path case (estatus :: Either SomeException FileStatus) of Right status | isRegularFile status -> Just <$> (FileEntry <$> pure (posixSecondsToUTCTime (realToFrac (modificationTime status))) <*> pure oid <*> pure kind <*> if getHash then hashContents . BlobString =<< liftIO (B.readFile path) else return oid) _ -> return Nothing gitlib-3.1.2/Git/Tree/Builder.hs0000644000000000000000000002523613303656006014533 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module 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.Monad import Control.Monad.Catch 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 r = TreeEntryNotFound | TreeEntryDeleted | TreeEntryPersistent (TreeEntry r) | TreeEntryMutated (TreeEntry r) fromModifyTreeResult :: ModifyTreeResult r -> Maybe (TreeEntry r) fromModifyTreeResult TreeEntryNotFound = Nothing fromModifyTreeResult TreeEntryDeleted = Nothing fromModifyTreeResult (TreeEntryPersistent x) = Just x fromModifyTreeResult (TreeEntryMutated x) = Just x toModifyTreeResult :: (TreeEntry r -> ModifyTreeResult r) -> Maybe (TreeEntry r) -> ModifyTreeResult r toModifyTreeResult _ Nothing = TreeEntryNotFound toModifyTreeResult f (Just x) = f x instance Functor m => Functor (TreeT r m) where fmap f (TreeT t) = TreeT (fmap f t) instance Monad m => Monad (TreeT r m) where return x = TreeT (return x) TreeT x >>= f = TreeT (x >>= runTreeT . f) instance (Functor m, Monad m) => Applicative (TreeT r m) where pure = return (<*>) = ap instance (Functor m, MonadPlus m) => Alternative (TreeT r m) where empty = mzero (<|>) = mplus instance (MonadPlus m) => MonadPlus (TreeT r m) where mzero = TreeT mzero m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n instance (MonadFix m) => MonadFix (TreeT r m) where mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) instance MonadTrans (TreeT r) where lift m = TreeT $ lift m instance (MonadIO m) => MonadIO (TreeT r m) where liftIO = lift . liftIO getBuilder :: Monad m => TreeT r m (TreeBuilder r m) getBuilder = TreeT get putBuilder :: Monad m => TreeBuilder r m -> TreeT r 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 :: MonadGit r m => TreeBuilder r m -> TreeFilePath -> BuilderAction -> (Maybe (TreeEntry r) -> ModifyTreeResult r) -> m (TreeBuilder r m, Maybe (TreeEntry r)) 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 {})) = throwM TreeCannotTraverseBlob update _ _ _ (Right (Just CommitEntry {})) = throwM 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 :: MonadGit r m => TreeBuilder r m -> m (TreeBuilder r m, TreeOid r) 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 :: MonadGit r m => TreeFilePath -> TreeT r m (Maybe (TreeEntry r)) getEntry path = do tb <- getBuilder snd <$> lift (queryTreeBuilder tb path GetEntry (toModifyTreeResult TreeEntryPersistent)) putEntry :: MonadGit r m => TreeFilePath -> TreeEntry r -> TreeT r m () putEntry path ent = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry (const (TreeEntryMutated ent))) putBuilder tb' dropEntry :: MonadGit r m => TreeFilePath -> TreeT r m () dropEntry path = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry (const TreeEntryDeleted)) putBuilder tb' putBlob' :: MonadGit r m => TreeFilePath -> BlobOid r -> BlobKind -> TreeT r m () putBlob' path b kind = putEntry path (BlobEntry b kind) putBlob :: MonadGit r m => TreeFilePath -> BlobOid r -> TreeT r m () putBlob path b = putBlob' path b PlainBlob putTree :: MonadGit r m => TreeFilePath -> TreeOid r -> TreeT r m () putTree path t = putEntry path (TreeEntry t) putCommit :: MonadGit r m => TreeFilePath -> CommitOid r -> TreeT r m () putCommit path c = putEntry path (CommitEntry c) doWithTree :: MonadGit r m => Maybe (Tree r) -> TreeT r m a -> m (a, TreeOid r) doWithTree rtr act = fst <$> (runStateT (runTreeT go) =<< newTreeBuilder rtr) where go = liftM2 (,) act currentTreeOid withTree :: MonadGit r m => Tree r -> TreeT r m a -> m (a, TreeOid r) withTree tr = doWithTree (Just tr) withTreeOid :: MonadGit r m => TreeOid r -> TreeT r m a -> m (a, TreeOid r) withTreeOid oid action = do tree <- lookupTree oid doWithTree (Just tree) action mutateTree :: MonadGit r m => Tree r -> TreeT r m a -> m (TreeOid r) mutateTree tr action = snd <$> withTree tr action mutateTreeOid :: MonadGit r m => TreeOid r -> TreeT r m a -> m (TreeOid r) mutateTreeOid tr action = snd <$> withTreeOid tr action currentTreeOid :: MonadGit r m => TreeT r m (TreeOid r) currentTreeOid = do tb <- getBuilder (tb', toid) <- lift $ writeTreeBuilder tb putBuilder tb' return toid currentTree :: MonadGit r m => TreeT r m (Tree r) currentTree = lift . lookupTree =<< currentTreeOid withNewTree :: MonadGit r m => TreeT r m a -> m (a, TreeOid r) withNewTree = doWithTree Nothing createTree :: MonadGit r m => TreeT r m a -> m (TreeOid r) createTree action = snd <$> withNewTree action gitlib-3.1.2/Git/Tree/Builder/0000755000000000000000000000000013303656006014167 5ustar0000000000000000gitlib-3.1.2/Git/Tree/Builder/Pure.hs0000644000000000000000000000441513303656006015442 0ustar0000000000000000module Git.Tree.Builder.Pure ( EntryHashMap , newPureTreeBuilder ) where import Control.Applicative import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Monoid import Data.Traversable import Git import Prelude hiding (mapM) type EntryHashMap r = HashMap TreeFilePath (TreeEntry r) -- | Create a new, empty tree. -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op. newPureTreeBuilder :: MonadGit r m => (Tree r -> m (EntryHashMap r)) -> (EntryHashMap r -> m (TreeOid r)) -> Maybe (Tree r) -> m (TreeBuilder r m) newPureTreeBuilder reader writer mtree = do entMap <- case mtree of Nothing -> return HashMap.empty Just tree -> reader tree toid <- mapM treeOid mtree return $ makePureBuilder toid mempty (newPureTreeBuilder reader writer) entMap writer makePureBuilder :: MonadGit r m => Maybe (TreeOid r) -> HashMap TreeFilePath (TreeBuilder r m) -> (Maybe (Tree r) -> m (TreeBuilder r m)) -> EntryHashMap r -> (EntryHashMap r -> m (TreeOid r)) -> TreeBuilder r 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 }