gitlib 1.2.1 → 1.3.1

raw patch · 2 files changed

+659/−146 lines, 2 filesdep +base16-bytestringdep +binarydep +hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: base16-bytestring, binary, hashable, system-fileio, unordered-containers

API changes (from Hackage documentation)

Files

• Git.hs +652/−144
• gitlib.cabal +7/−2

@@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  -- | Interface for working with Git repositories. module Git@@ -24,6 +25,9 @@        , Object(..)        , ObjRef(..)        , objectOid+       , SHA(..)+       , textToSha+       , shaToText         , Blob(..)        , BlobOid@@ -34,29 +38,29 @@        , blobEntry        , blobRefOid        , resolveBlobRef+       , createBlobUtf8+       , catBlob+       , catBlobUtf8+       , copyBlob+       , blobContentsToByteString+       , blobToByteString         , TreeT-       , RepositoryTree-       , RepositoryTreeT-       , MutableTree-       , MutableTreeT-       , PersistentTree-       , PersistentTreeT+       , TreeBuilder(..)+       , ModifiedBuilder(..)        , TreeEntry(..)        , TreeOid        , TreeRef        , createTree        , withNewTree        , mutateTree+       , mutateTreeRef+       , currentTree+       , currentTreeRef        , withTree-       , unsafeMutateTree-       , unsafeMutateTree_-       , unsafeWithTree-       , unsafeGetTree-       , unsafePutTree+       , withTreeRef        , dropEntry        , getEntry-       , getTreeEntry        , putBlob        , putBlob'        , putCommit@@ -64,12 +68,16 @@        , putTree        , resolveTreeRef        , treeEntry-       , treeEntryOid+       , getTreeEntryOid        , treeRef        , treeRefOid        , ModifyTreeResult(..)        , fromModifyTreeResult        , toModifyTreeResult+       , emptyTreeId+       , treeBlobEntries+       , copyTreeEntry+       , copyTree         , Commit(..)        , CommitOid@@ -81,12 +89,21 @@        , commitRef        , commitRefOid        , commitRefTarget+       , getCommitParents        , copyCommitName        , copyCommitOid        , nameOfCommit        , renderCommitName        , resolveCommitRef+       , commitTreeEntry+       , copyCommit+       , genericPushCommit +       , PinnedEntry(..)+       , commitHistoryFirstParent+       , commitEntryHistory+       , identifyEntry+        , Tag(..)        , TagOid        , TagRef@@ -95,6 +112,7 @@        , RefTarget(..)        , Reference(..)        , referenceToRef+       , resolveReferenceTree         , GitException(..)        , ModificationKind(..)@@ -102,6 +120,9 @@        , MergeResult(..)        , mergeStatus        , copyConflict+       , allMissingObjects+       , withNewRepository+       , withNewRepository'        ) where  import           Control.Applicative@@ -112,17 +133,32 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Class import           Control.Monad.Trans.State+import qualified Data.Binary as Bin import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16 import           Data.Conduit+import qualified Data.Conduit.List as CList import           Data.Default+import           Data.Function+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import           Data.Hashable+import           Data.List import           Data.Map (Map) import           Data.Maybe+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.Traversable hiding (mapM, forM, sequence) import           Data.Typeable-import           Filesystem.Path.CurrentOS+import           Filesystem (removeTree, isDirectory)+import           Filesystem.Path.CurrentOS hiding (null, concat) import           Prelude hiding (FilePath) import           System.Mem (performGC) @@ -138,17 +174,15 @@     renderOid :: o -> Text     renderOid = renderObjOid . Tagged     renderObjOid :: Tagged a o -> Text-    renderObjOid = renderOid . unTagged+    renderObjOid = renderOid . untag  -- | '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 :: *-    type TreeKind m :: *-    type Tree m :: * -> *--    data Options m+    type Oid m     :: *+    data Tree m    :: *+    data Options m :: *      facts :: m RepositoryFacts @@ -157,27 +191,29 @@     parseObjOid sha = Tagged <$> parseOid sha      -- References-    createRef  :: Text -> RefTarget m (Commit m) -> m (Reference m (Commit m))-    createRef_ :: Text -> RefTarget m (Commit m) -> m ()-    createRef_ = (void .) . createRef-    lookupRef  :: Text -> m (Maybe (Reference m (Commit m)))-    updateRef  :: Text -> RefTarget m (Commit m) -> m (Reference m (Commit m))-    updateRef_ :: Text -> RefTarget m (Commit m) -> m ()-    updateRef_ = (void .) . updateRef-    deleteRef  :: Text -> m ()+    createReference  :: Text -> RefTarget m (Commit m)+                     -> m (Reference m (Commit m))+    createReference_ :: Text -> RefTarget m (Commit m) -> m ()+    createReference_ = (void .) . createReference+    lookupReference  :: Text -> m (Maybe (Reference m (Commit m)))+    updateReference  :: Text -> RefTarget m (Commit m)+                     -> m (Reference m (Commit m))+    updateReference_ :: Text -> RefTarget m (Commit m) -> m ()+    updateReference_ = (void .) . updateReference+    deleteReference  :: Text -> m () -    allRefs :: m [Reference m (Commit m)]-    allRefs = catMaybes <$> (mapM lookupRef =<< allRefNames)+    allReferences :: m [Reference m (Commit m)]+    allReferences = catMaybes <$> (mapM lookupReference =<< allReferenceNames) -    allRefNames :: m [Text]-    allRefNames = map refName <$> allRefs+    allReferenceNames :: m [Text]+    allReferenceNames = map referenceName <$> allReferences -    resolveRef :: Text -> m (Maybe (CommitRef m))-    resolveRef name = lookupRef name >>= referenceToRef (Just name)+    resolveReference :: Text -> m (Maybe (CommitRef m))+    resolveReference name = lookupReference name >>= referenceToRef (Just name)      -- Lookup     lookupCommit :: CommitOid m -> m (Commit m)-    lookupTree   :: TreeOid m -> m (RepositoryTree m)+    lookupTree   :: TreeOid m -> m (Tree m)     lookupBlob   :: BlobOid m -> m (Blob m)     lookupTag    :: TagOid m -> m (Tag m) @@ -204,19 +240,13 @@                    -> m [Object m]         -- ^ All the objects in between      -- Object creation-    newTree :: m (RepositoryTree m)-    cloneTree :: RepositoryTree m -> m (RepositoryTree m)-    traverseEntries :: (FilePath -> TreeEntry m -> m a) -> RepositoryTree m -> m [a]-    traverseEntries_ :: (FilePath -> TreeEntry m -> m a) -> RepositoryTree m -> m ()-    traverseEntries_ = (void .) . traverseEntries-    writeTree :: RepositoryTree m -> m (TreeOid m)+    newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m) -    unsafeUpdateTree-        :: RepositoryTree m-        -> FilePath    -- path within the tree-        -> Bool        -- create subtree's leading up to path?-        -> (Maybe (TreeEntry m) -> ModifyTreeResult m)-        -> m (RepositoryTree m, Maybe (TreeEntry m))+    treeOid :: Tree m -> TreeOid m+    getTreeEntry :: Tree m -> FilePath -> m (Maybe (TreeEntry m))+    traverseEntries :: (FilePath -> TreeEntry m -> m a) -> Tree m -> m [a]+    traverseEntries_ :: (FilePath -> TreeEntry m -> m a) -> Tree m -> m ()+    traverseEntries_ = (void .) . traverseEntries      hashContents :: BlobContents m -> m (BlobOid m)     createBlob   :: BlobContents m -> m (BlobOid m)@@ -289,7 +319,7 @@  {- $oids -} type BlobOid m   = Tagged (Blob m) (Oid m)-type TreeOid m   = Tagged (RepositoryTree 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) @@ -297,8 +327,8 @@ data RefTarget m a = RefObj !(ObjRef m a) | RefSymbolic !Text  data Reference m a = Reference-    { refName   :: !Text-    , refTarget :: !(RefTarget m a) }+    { referenceName   :: !Text+    , referenceTarget :: !(RefTarget m a) }  data CommitName m = CommitObjectId !(CommitOid m)                   | CommitRefName !Text@@ -307,23 +337,22 @@ instance Repository m => Show (CommitName m) where     show (CommitObjectId coid) = T.unpack (renderObjOid coid)     show (CommitRefName name)  = show name-    show (CommitReference ref) = show (refName ref)+    show (CommitReference ref) = show (referenceName ref)  nameOfCommit :: Commit m -> CommitName m nameOfCommit = CommitObjectId . commitOid  commitNameToRef :: Repository m => CommitName m -> m (Maybe (CommitRef m)) commitNameToRef (CommitObjectId coid) = return (Just (ByOid coid))-commitNameToRef (CommitRefName name)  = resolveRef name+commitNameToRef (CommitRefName name)  = resolveReference name commitNameToRef (CommitReference ref) = referenceToRef Nothing (Just ref)  renderCommitName :: Repository m => CommitName m -> Text renderCommitName (CommitObjectId coid) = renderObjOid coid renderCommitName (CommitRefName name)  = name-renderCommitName (CommitReference ref) = refName ref+renderCommitName (CommitReference ref) = referenceName ref -copyOid :: (Repository m, MonadGit m, Repository n, MonadGit n)-        => Oid m -> n (Oid n)+copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n) copyOid = parseOid . renderOid  copyCommitOid :: (Repository m, MonadGit m, Repository n, MonadGit n)@@ -338,13 +367,13 @@     Just . CommitObjectId . Tagged <$> parseOid (renderObjOid coid) copyCommitName (CommitRefName name) = return (Just (CommitRefName name)) copyCommitName (CommitReference ref) =-    fmap CommitReference <$> lookupRef (refName ref)+    fmap CommitReference <$> lookupReference (referenceName ref)  {- $objects -} data ObjRef m a = ByOid !(Tagged a (Oid m)) | Known !a  type BlobRef m   = ObjRef m (Blob m)-type TreeRef m   = ObjRef m (RepositoryTree m)+type TreeRef m   = ObjRef m (Tree m) type CommitRef m = ObjRef m (Commit m) type TagRef m    = ObjRef m (Tag m) @@ -354,10 +383,10 @@               | TagObj       !(TagRef m)  objectOid :: Repository m => Object m -> m (Oid m)-objectOid (BlobObj ref)   = return . unTagged $ blobRefOid ref-objectOid (TreeObj ref)   = unTagged <$> treeRefOid ref-objectOid (CommitObj ref) = return . unTagged $ commitRefOid ref-objectOid (TagObj ref)    = return . unTagged $ tagRefOid ref+objectOid (BlobObj ref)   = return . untag $ blobRefOid ref+objectOid (TreeObj ref)   = return . untag $ treeRefOid ref+objectOid (CommitObj ref) = return . untag $ commitRefOid ref+objectOid (TagObj ref)    = return . untag $ tagRefOid ref  {- $blobs -} data Blob m = Blob { blobOid      :: !(BlobOid m)@@ -385,133 +414,128 @@   _ == _ = False  {- $trees -}-newtype TreeT t m a = TreeT { runTreeT :: StateT t m a }--data MutableTree-type MutableTreeT m a = TreeT (Tree m MutableTree) m a--data PersistentTree-type PersistentTreeT m a = TreeT (Tree m PersistentTree) m a--type RepositoryTree m = Tree m (TreeKind m)-type RepositoryTreeT m a = TreeT (RepositoryTree m) m a+newtype TreeT m a = TreeT { runTreeT :: StateT (TreeBuilder m) m a } -instance Functor m => Functor (TreeT t m) where+instance Functor m => Functor (TreeT m) where     fmap f (TreeT t) = TreeT (fmap f t) -instance Monad m => Monad (TreeT t m) where+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 t m) where+instance (Functor m, Monad m) => Applicative (TreeT m) where     pure = return     (<*>) = ap -instance (Functor m, MonadPlus m) => Alternative (TreeT t m) where+instance (Functor m, MonadPlus m) => Alternative (TreeT m) where     empty = mzero     (<|>) = mplus -instance (MonadPlus m) => MonadPlus (TreeT t m) where+instance (MonadPlus m) => MonadPlus (TreeT m) where     mzero       = TreeT $ mzero     m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n -instance (MonadFix m) => MonadFix (TreeT t m) where+instance (MonadFix m) => MonadFix (TreeT m) where     mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) -instance MonadTrans (TreeT t) where+instance MonadTrans TreeT where     lift m = TreeT $ lift m -instance (MonadIO m) => MonadIO (TreeT t m) where+instance (MonadIO m) => MonadIO (TreeT m) where     liftIO = lift . liftIO -unsafeGetTree :: Monad m => RepositoryTreeT m (RepositoryTree m)-unsafeGetTree = TreeT get+getBuilder :: Monad m => TreeT m (TreeBuilder m)+getBuilder = TreeT get -unsafePutTree :: Monad m => RepositoryTree m -> RepositoryTreeT m ()-unsafePutTree = TreeT . put+putBuilder :: Monad m => TreeBuilder m -> TreeT m ()+putBuilder = TreeT . put -getEntry :: Repository m => FilePath -> RepositoryTreeT m (Maybe (TreeEntry m))+data BuilderAction = GetEntry | PutEntry | DropEntry+                   deriving (Eq, Show)++getEntry :: Repository m => FilePath -> TreeT m (Maybe (TreeEntry m)) getEntry path = do-    tr <- unsafeGetTree-    snd <$> lift (unsafeUpdateTree tr path False+    tb <- getBuilder+    snd <$> lift (queryTreeBuilder tb path GetEntry                   (toModifyTreeResult TreeEntryPersistent)) -getTreeEntry :: Repository m => RepositoryTree m -> FilePath -> m (Maybe (TreeEntry m))-getTreeEntry tree path =-    fst <$> (flip runStateT tree $ runTreeT (getEntry path))--putEntry :: Repository m => FilePath -> TreeEntry m -> RepositoryTreeT m ()+putEntry :: Repository m => FilePath -> TreeEntry m -> TreeT m () putEntry path ent = do-    tr <- unsafeGetTree-    tr' <- fst <$> lift (unsafeUpdateTree tr path True+    tb  <- getBuilder+    tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry                          (const (TreeEntryMutated ent)))-    unsafePutTree tr'+    putBuilder tb' -dropEntry :: Repository m => FilePath -> RepositoryTreeT m ()+dropEntry :: Repository m => FilePath -> TreeT m () dropEntry path = do-    tr <- unsafeGetTree-    tr' <- fst <$> lift (unsafeUpdateTree tr path False+    tb  <- getBuilder+    tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry                          (const TreeEntryDeleted))-    unsafePutTree tr'+    putBuilder tb' -putBlob' :: Repository m => FilePath -> BlobOid m -> BlobKind -> RepositoryTreeT m ()+putBlob' :: Repository m => FilePath -> BlobOid m -> BlobKind -> TreeT m () putBlob' path b kind = putEntry path (BlobEntry b kind) -putBlob :: Repository m => FilePath -> BlobOid m -> RepositoryTreeT m ()+putBlob :: Repository m => FilePath -> BlobOid m -> TreeT m () putBlob path b = putBlob' path b PlainBlob -putTree :: Repository m => FilePath -> TreeRef m -> RepositoryTreeT m ()-putTree path ent = putEntry path (TreeEntry ent)+putTree :: Repository m => FilePath -> TreeOid m -> TreeT m ()+putTree path t = putEntry path (TreeEntry t) -putCommit :: Repository m => FilePath -> CommitOid m -> RepositoryTreeT m ()+putCommit :: Repository m => FilePath -> CommitOid m -> TreeT m () putCommit path c = putEntry path (CommitEntry c) -withNewTree :: Repository m => RepositoryTreeT m a -> m (a, RepositoryTree m)-withNewTree (TreeT action) = runStateT action =<< newTree+doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeRef m)+doWithTree mtr act =+    fst <$> (runStateT (runTreeT go) =<< newTreeBuilder mtr)+  where+    go = liftM2 (,) act currentTreeRef -createTree :: Repository m => RepositoryTreeT m a -> m (RepositoryTree m)-createTree (TreeT action) = execStateT action =<< newTree+withTree :: Repository m => Tree m -> TreeT m a -> m (a, TreeRef m)+withTree tr = doWithTree (Just tr) -withTree :: Repository m-         => RepositoryTree m-         -> RepositoryTreeT m a-         -> m (a, RepositoryTree m)-withTree tr (TreeT action) = runStateT action =<< cloneTree tr+withTreeRef :: Repository m => TreeRef m -> TreeT m a -> m (a, TreeRef m)+withTreeRef ref action = do+    tree <- resolveTreeRef ref+    doWithTree (Just tree) action -unsafeWithTree :: Repository m-               => Tree m MutableTree -> MutableTreeT m a-               -> m (a, Tree m MutableTree)-unsafeWithTree tr (TreeT action) = runStateT action tr+mutateTree :: Repository m => Tree m -> TreeT m a -> m (TreeRef m)+mutateTree tr action = snd <$> withTree tr action -mutateTree :: Repository m-           => RepositoryTree m -> RepositoryTreeT m a-           -> m (RepositoryTree m)-mutateTree tr (TreeT action) = execStateT action =<< cloneTree tr+mutateTreeRef :: Repository m => TreeRef m -> TreeT m a -> m (TreeRef m)+mutateTreeRef tr action = snd <$> withTreeRef tr action -unsafeMutateTree :: Repository m-                 => Tree m MutableTree -> MutableTreeT m a-                 -> m (Tree m MutableTree)-unsafeMutateTree tr (TreeT action) = execStateT action tr+currentTreeRef :: Repository m => TreeT m (TreeRef m)+currentTreeRef = do+    tb <- getBuilder+    (tb', tref) <- lift $ writeTreeBuilder tb+    putBuilder tb'+    return tref -unsafeMutateTree_ :: Repository m-                  => Tree m MutableTree -> MutableTreeT m a -> m ()-unsafeMutateTree_ = (void .) . unsafeMutateTree+currentTree :: Repository m => TreeT m (Tree m)+currentTree = lift . resolveTreeRef =<< currentTreeRef +withNewTree :: Repository m => TreeT m a -> m (a, TreeRef m)+withNewTree = doWithTree Nothing++createTree :: Repository m => TreeT m a -> m (TreeRef m)+createTree action = snd <$> withNewTree action+ data TreeEntry m = BlobEntry   { blobEntryOid   :: !(BlobOid m)                                , blobEntryKind  :: !BlobKind }-                 | TreeEntry   { treeEntryRef   :: !(TreeRef m) }-                 | CommitEntry { commitEntryRef :: !(CommitOid m) }+                 | TreeEntry   { treeEntryOid   :: !(TreeOid m) }+                 | CommitEntry { commitEntryOid :: !(CommitOid m) } -treeEntryOid :: Repository m => TreeEntry m -> m (Oid m)-treeEntryOid (BlobEntry boid _) = return $ unTagged boid-treeEntryOid (TreeEntry tref)   = unTagged <$> treeRefOid tref-treeEntryOid (CommitEntry coid) = return $ unTagged coid+getTreeEntryOid :: Repository m => TreeEntry m -> Oid m+getTreeEntryOid (BlobEntry boid _) = untag boid+getTreeEntryOid (TreeEntry toid)   = untag toid+getTreeEntryOid (CommitEntry coid) = untag coid  blobEntry :: Repository m => BlobOid m -> BlobKind -> TreeEntry m blobEntry = BlobEntry -treeEntry :: Repository m => RepositoryTree m -> TreeEntry m-treeEntry = TreeEntry . treeRef+treeEntry :: Repository m => Tree m -> TreeEntry m+treeEntry = TreeEntry . treeOid  commitEntry :: Repository m => Commit m -> TreeEntry m commitEntry = CommitEntry . commitOid@@ -534,14 +558,14 @@ toModifyTreeResult f (Just x) = f x  -- | A 'Tree' is anything that is "treeish".-treeRef :: RepositoryTree m -> TreeRef m+treeRef :: Tree m -> TreeRef m treeRef = Known -treeRefOid :: Repository m => TreeRef m -> m (TreeOid m)-treeRefOid (ByOid x) = return x-treeRefOid (Known x) = writeTree x+treeRefOid :: Repository m => TreeRef m -> TreeOid m+treeRefOid (ByOid x) = x+treeRefOid (Known x) = treeOid x -resolveTreeRef :: Repository m => TreeRef m -> m (RepositoryTree m)+resolveTreeRef :: Repository m => TreeRef m -> m (Tree m) resolveTreeRef (ByOid oid) = lookupTree oid resolveTreeRef (Known obj) = return obj @@ -595,12 +619,12 @@ referenceToRef mname mref =     case mref of         Nothing -> return Nothing-        Just (Reference { refTarget = RefObj x }) ->+        Just (Reference { referenceTarget = RefObj x }) ->             return (Just x)-        Just ref@(Reference { refTarget = RefSymbolic name' }) ->+        Just ref@(Reference { referenceTarget = RefSymbolic name' }) ->             if fromMaybe name' mname /= name'-            then resolveRef name'-            else failure (ReferenceLookupFailed (refName ref))+            then resolveReference name'+            else failure (ReferenceLookupFailed (referenceName ref))  {- $tags -} @@ -694,6 +718,490 @@                     <*> pure cs  {- $miscellaneous -}++newtype SHA = SHA B.ByteString deriving (Eq, Ord, Read)++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++instance IsOid SHA where+    renderOid = shaToText++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"++createBlobUtf8 :: Repository m => Text -> m (BlobOid m)+createBlobUtf8 = createBlob . BlobString . T.encodeUtf8++catBlob :: Repository m => Text -> m ByteString+catBlob str =+    if len == 40+    then do+        oid <- parseOid str+        lookupBlob (Tagged oid) >>= blobToByteString++    else do+        obj <- lookupObject str+        case obj of+            BlobObj (ByOid oid) -> lookupBlob oid >>= blobToByteString+            BlobObj (Known x)   -> blobToByteString x+            _ -> failure (ObjectLookupFailed str len)+  where+    len = T.length str++catBlobUtf8 :: Repository m => Text -> m Text+catBlobUtf8 = catBlob >=> return . T.decodeUtf8++blobContentsToByteString :: Repository m => BlobContents m -> m ByteString+blobContentsToByteString (BlobString bs) = return bs+blobContentsToByteString (BlobStream bs) = do+    strs <- bs $$ CList.consume+    return (B.concat strs)+blobContentsToByteString (BlobSizedStream bs _) = do+    strs <- bs $$ CList.consume+    return (B.concat strs)++blobToByteString :: Repository m => Blob m -> m ByteString+blobToByteString (Blob _ contents) = blobContentsToByteString contents++splitPath :: FilePath -> [Text]+splitPath path = T.splitOn "/" text+  where text = case toText path of+                 Left x  -> error $ "Invalid path: " ++ T.unpack x+                 Right y -> y++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++data TreeBuilder m = TreeBuilder+    { mtbBaseTreeRef    :: Maybe (TreeRef m)+    , mtbPendingUpdates :: HashMap Text (TreeBuilder m)+    , mtbNewBuilder     :: Maybe (Tree m) -> m (TreeBuilder m)+    , mtbWriteContents  :: TreeBuilder m -> m (ModifiedBuilder m, TreeRef m)+    , mtbLookupEntry    :: Text -> m (Maybe (TreeEntry m))+    , mtbEntryCount     :: m Int+    , mtbPutEntry       :: TreeBuilder m -> Text -> TreeEntry m+                        -> m (ModifiedBuilder m)+    , mtbDropEntry      :: TreeBuilder m -> Text -> m (ModifiedBuilder m)+    }++instance Monad m => Monoid (TreeBuilder m) where+    mempty = TreeBuilder+        { mtbBaseTreeRef    = Nothing+        , mtbPendingUpdates = HashMap.empty+        , mtbNewBuilder     = error "Implement TreeBuilder.mtbNewBuilder"+        , mtbWriteContents  = error "Implement TreeBuilder.mtbWriteContents"+        , mtbLookupEntry    = \_ -> return Nothing+        , mtbEntryCount     = return 0+        , mtbPutEntry       = \tb _ _ -> return (BuilderUnchanged tb)+        , mtbDropEntry      = \tb _ -> return (BuilderUnchanged tb)+        }+    tb1 `mappend` tb2 = tb2+        { mtbBaseTreeRef    = mtbBaseTreeRef tb1+        , mtbPendingUpdates = mtbPendingUpdates tb1+        }++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+                  -> FilePath+                  -> BuilderAction+                  -> (Maybe (TreeEntry m) -> ModifyTreeResult m)+                  -> m (TreeBuilder m, Maybe (TreeEntry m))+queryTreeBuilder builder path kind f = do+    (mtb, mtresult) <- walk (BuilderUnchanged builder) (splitPath 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 (treeRefOid 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 $+                    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) }++-- | Write out a tree to its repository.  If it has already been written,+--   nothing will happen.+writeTreeBuilder :: Repository m+                 => TreeBuilder m+                 -> m (TreeBuilder m, TreeRef m)+writeTreeBuilder builder = do+    (bm, mtref) <- go (BuilderUnchanged builder)+    tref <- case mtref of+        Nothing -> do+            emptyTreeOid <- parseObjOid emptyTreeId+            return $ ByOid emptyTreeOid+        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 (treeRefOid tref))+        return $ bm <> bm'++treeBlobEntries :: Repository m => Tree m -> m [(FilePath,TreeEntry m)]+treeBlobEntries tree =+    mconcat <$> traverseEntries go tree+  where+    go fp e@(BlobEntry _ PlainBlob)      = return [(fp,e)]+    go fp e@(BlobEntry _ ExecutableBlob) = return [(fp,e)]+    go _ _ = return []++commitTreeEntry :: Repository m+                => Commit m+                -> FilePath+                -> m (Maybe (TreeEntry m))+commitTreeEntry c path =+    flip getTreeEntry path =<< resolveTreeRef (commitTree c)++copyBlob :: (Repository m, Repository (t m), MonadTrans t)+         => BlobRef m+         -> HashSet Text+         -> t m (BlobOid (t m), HashSet Text)+copyBlob blobr needed = do+    let oid = untag (blobRefOid blobr)+        sha = renderOid oid+    oid2 <- parseOid (renderOid oid)+    if HashSet.member sha needed+        then do+        bs <- lift $ blobToByteString+              =<< resolveBlobRef (ByOid (Tagged oid))+        boid <- createBlob (BlobString bs)++        let x = HashSet.delete sha needed+        return $ boid `seq` x `seq` (boid, x)++        else return (Tagged oid2, needed)++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 (ByOid oid) needed+    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)+         => TreeRef m+         -> HashSet Text+         -> t m (TreeRef (t m), HashSet Text)+copyTree tr needed = do+    let oid = untag (treeRefOid tr)+        sha = renderOid oid+    oid2 <- parseOid (renderOid oid)+    if HashSet.member sha needed+        then do+        tree            <- lift $ resolveTreeRef tr+        entries         <- lift $ traverseEntries (curry return) tree+        (needed', tref) <- withNewTree $ foldM doCopyTreeEntry needed entries++        let x = HashSet.delete sha needed'+        return $ tref `seq` x `seq` (tref, x)++        else return (ByOid (Tagged oid2), needed)+  where+    doCopyTreeEntry :: (Repository m, Repository (t m), MonadTrans t)+                    => HashSet Text -> (FilePath, TreeEntry m)+                    -> TreeT (t m) (HashSet Text)+    doCopyTreeEntry needed' (_,TreeEntry {}) = return needed'+    doCopyTreeEntry needed' (fp,ent) = do+        (ent2,needed'') <- lift $ copyTreeEntry ent needed'+        putEntry fp ent2+        return needed''++copyCommit :: (Repository m, Repository (t m), MonadTrans t)+           => CommitRef m+           -> Maybe Text+           -> HashSet Text+           -> t m (CommitRef (t m), HashSet Text)+copyCommit cr mref needed = do+    let oid = untag (commitRefOid cr)+        sha = renderOid oid+    commit <- lift $ resolveCommitRef 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'++        commit' <- createCommit (reverse parentRefs) tr+            (commitAuthor commit)+            (commitCommitter commit)+            (commitLog commit)+            mref++        let cref = commitRef $! commit'+            x    = HashSet.delete sha needed''+        return $ cref `seq` x `seq` (cref, x)++        else return (ByOid (Tagged oid2), needed)+  where+    copyParent (prefs,needed') cref = do+        (cref2,needed'') <- copyCommit cref Nothing needed'+        let x = cref2 `seq` (cref2:prefs)+        return $ x `seq` needed'' `seq` (x,needed'')++-- | Given a list of objects (commit and top-level trees) return by+--   'missingObjects', expand it to include all subtrees and blobs as well.+--   Ordering is preserved.+allMissingObjects :: Repository m => [Object m] -> m [Object m]+allMissingObjects objs =+    fmap concat . forM objs $ \obj -> case obj of+        TreeObj ref -> do+            tr       <- resolveTreeRef ref+            subobjss <- flip traverseEntries tr $ \_ ent ->+                return $ case ent of+                    BlobEntry oid _ -> [BlobObj (ByOid oid)]+                    TreeEntry oid   -> [TreeObj (ByOid oid)]+                    _ -> []+            return (obj:concat subobjss)+        _ -> return [obj]++-- | Fast-forward push a reference between repositories using a recursive+--   copy.  This can be extremely slow, but always works.+genericPushCommit :: (Repository m, Repository (t m), MonadTrans t)+                  => CommitName m -> Text -> t m (CommitRef (t m))+genericPushCommit cname remoteRefName = do+    mrref    <- lookupReference remoteRefName+    commits1 <- lift $ traverseCommits crefToSha cname+    fastForward <- case mrref of+        Just rref -> do+            mrsha <- referenceSha rref+            case mrsha of+                Nothing -> failure (PushNotFastForward $+                                    "Could not find SHA for " <> remoteRefName)+                Just rsha+                    | rsha `elem` commits1 -> do+                        roid <- lift $ parseOid rsha+                        return $ Just (Just (CommitObjectId (Tagged roid)))+                    | otherwise -> do+                        failure (PushNotFastForward $+                                 "SHA " <> rsha+                                        <> " not found in remote")+        Nothing -> return (Just Nothing)+    case fastForward of+        Nothing -> failure (PushNotFastForward "unexpected")+        Just liftedMrref -> do+            objs <- lift $ allMissingObjects+                        =<< missingObjects liftedMrref cname+            shas <- mapM (\obj -> renderOid <$> lift (objectOid obj)) objs+            mref <- lift $ commitNameToRef cname+            case mref of+                Nothing -> failure (ReferenceLookupFailed (T.pack (show cname)))+                Just ref -> do+                    (cref,_) <- copyCommit ref Nothing (HashSet.fromList shas)+                    -- jww (2013-04-18): This is something the user must+                    -- decide to do+                    -- updateRef_ remoteRefName (RefObj cref)+                    return cref+  where+    referenceSha ref = do+        r <- referenceToRef Nothing (Just ref)+        return $ renderObjOid . commitRefOid <$> r++    crefToSha cref  = return (renderObjOid (commitRefOid cref))++commitHistoryFirstParent :: Repository m => Commit m -> m [Commit m]+commitHistoryFirstParent c =+    case commitParents c of+        []    -> return [c]+        (p:_) -> do ps <- commitHistoryFirstParent =<< resolveCommitRef p+                    return (c:ps)++data PinnedEntry m = PinnedEntry+    { pinnedOid    :: Oid m+    , pinnedCommit :: Commit m+    , pinnedEntry  :: TreeEntry m+    }++identifyEntry :: Repository m => Commit m -> TreeEntry m -> m (PinnedEntry m)+identifyEntry co x = do+    let oid = case x of+            BlobEntry oid' _ -> untag oid'+            TreeEntry oid'   -> untag oid'+            CommitEntry oid' -> untag oid'+    return (PinnedEntry oid co x)++commitEntryHistory :: Repository m => Commit m -> FilePath -> m [PinnedEntry m]+commitEntryHistory c path =+    map head . filter (not . null) . groupBy ((==) `on` pinnedOid) <$> go c+  where+    go co = do+        entry <- getCommitTreeEntry co+        rest  <- case commitParents co of+            []    -> return []+            (p:_) -> go =<< resolveCommitRef p+        return $ maybe rest (:rest) entry++    getCommitTreeEntry co = do+        ce <- commitTreeEntry co path+        case ce of+            Nothing  -> return Nothing+            Just ce' -> Just <$> identifyEntry co ce'++getCommitParents :: Repository m => Commit m -> m [Commit m]+getCommitParents = traverse resolveCommitRef . commitParents++resolveReferenceTree :: Repository m => Text -> m (Maybe (Tree m))+resolveReferenceTree refName = do+    c <- resolveReference refName+    case c of+        Nothing -> return Nothing+        Just c' ->+            Just <$> (resolveCommitRef c' >>= resolveTreeRef . commitTree)++withNewRepository :: (Repository (t m), MonadGit (t m),+                      MonadBaseControl IO m, MonadIO m, MonadTrans t)+                  => RepositoryFactory t m c+                  -> FilePath -> t m a -> m a+withNewRepository factory path action = do+    liftIO $ do+        exists <- isDirectory path+        when exists $ removeTree path++    -- we want exceptions to leave the repo behind+    a <- withRepository' factory (defaultOptions factory)+        { repoPath       = path+        , repoIsBare     = True+        , repoAutoCreate = True+        } action++    liftIO $ do+        exists <- isDirectory path+        when exists $ removeTree path++    return a++withNewRepository' :: (Repository (t m), MonadGit (t m),+                       MonadBaseControl IO m, MonadIO m, MonadTrans t)+                   => RepositoryFactory t m c -> FilePath -> t m 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 <- isDirectory path+        when exists $ removeTree path+  data RepositoryOptions = RepositoryOptions     { repoPath       :: !FilePath

@@ -1,5 +1,5 @@ Name:                gitlib-Version:             1.2.1+Version:             1.3.1 Synopsis:            API library for working with Git repositories License-file:        LICENSE License:             MIT@@ -40,17 +40,22 @@     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         , failure              >= 0.2.0.1+        , hashable             >= 1.1.2.5         , lifted-base          >= 0.2+        , system-fileio        >= 0.3.11         , system-filepath      >= 0.4.7         , tagged               >= 0.2.3.1-        , transformers         >= 0.3.0.0         , text                 >= 0.11.2         , time                 >= 1.4+        , transformers         >= 0.3.0.0+        , unordered-containers >= 0.2.3.0     exposed-modules:         Git         Git.Tutorial