diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -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 diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -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