diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -1,1215 +1,13 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Interface for working with Git repositories. -module Git - ( RepositoryFacts(..) - , Repository(..) - , RepositoryFactory(..) - , RepositoryOptions(..) - , withBackendDo - , withRepository - , withRepository' - , MonadGit - - , IsOid(..) - , copyOid - , Object(..) - , ObjectOid(..) - , objectOid - , loadObject - , objectToObjOid - , untagObjOid - , SHA(..) - , textToSha - , shaToText - - , Blob(..) - , BlobOid - , BlobContents(..) - , BlobKind(..) - , ByteSource - , blobEntry - , createBlobUtf8 - , catBlob - , catBlobUtf8 - , copyBlob - , blobContentsToByteString - , blobToByteString - - , TreeT - , TreeBuilder(..) - , ModifiedBuilder(..) - , TreeEntry(..) - , TreeOid - , createTree - , withNewTree - , mutateTree - , mutateTreeOid - , currentTree - , withTree - , withTreeOid - , dropEntry - , getEntry - , putBlob - , putBlob' - , putCommit - , putEntry - , putTree - , treeEntry - , getTreeEntryOid - , ModifyTreeResult(..) - , fromModifyTreeResult - , toModifyTreeResult - , emptyTreeId - , treeBlobEntries - , copyTreeEntry - , copyTree - - , Commit(..) - , CommitOid - , CommitName(..) - , Signature(..) - , commitEntry - , commitRefTarget - , getCommitParents - , copyCommitName - , copyCommitOid - , nameOfCommit - , commitNameToOid - , renderCommitName - , commitTreeEntry - , copyCommit - , genericPushCommit - - , PinnedEntry(..) - , commitHistoryFirstParent - , commitEntryHistory - , identifyEntry - - , Tag(..) - , TagOid - - , RefTarget(..) - , Reference(..) - , referenceToOid - , resolveReferenceTree - - , GitException(..) - , ModificationKind(..) - , MergeStatus(..) - , MergeResult(..) - , mergeStatus - , copyConflict - , allMissingObjects - , withNewRepository - , withNewRepository' - ) where - -import Control.Applicative -import qualified Control.Exception.Lifted as Exc -import Control.Failure -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import qualified Data.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 (removeTree, isDirectory) -import Filesystem.Path.CurrentOS hiding (null, concat) -import Prelude hiding (FilePath) -import System.Mem (performGC) - -{- $repositories -} -data RepositoryFacts = RepositoryFacts - { hasSymbolicReferences :: !Bool - } deriving Show - -type MonadGit m = (Failure Git.GitException m, Applicative m, - MonadIO m, MonadBaseControl IO m) - -class (Eq o, Ord o, Show o) => IsOid o where - renderOid :: o -> Text - renderOid = renderObjOid . Tagged - renderObjOid :: Tagged a o -> Text - 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 :: * - data Tree m :: * - data Options m :: * - - facts :: m RepositoryFacts - - parseOid :: Text -> m (Oid m) - parseObjOid :: forall o. Text -> m (Tagged o (Oid m)) - parseObjOid sha = Tagged <$> parseOid sha - - -- References - createReference :: Text -> RefTarget m -> m (Reference m) - createReference_ :: Text -> RefTarget m -> m () - createReference_ = (void .) . createReference - lookupReference :: Text -> m (Maybe (Reference m)) - updateReference :: Text -> RefTarget m -> m (Reference m) - updateReference_ :: Text -> RefTarget m -> m () - updateReference_ = (void .) . updateReference - deleteReference :: Text -> m () - - allReferences :: m [Reference m] - allReferences = catMaybes <$> (mapM lookupReference =<< allReferenceNames) - - allReferenceNames :: m [Text] - allReferenceNames = map referenceName <$> allReferences - - resolveReference :: Text -> m (Maybe (CommitOid m)) - resolveReference name = lookupReference name >>= referenceToOid (Just name) - - -- Lookup - lookupCommit :: CommitOid m -> m (Commit m) - lookupTree :: TreeOid m -> m (Tree m) - lookupBlob :: BlobOid m -> m (Blob m) - lookupTag :: TagOid m -> m (Tag m) - - lookupObject :: Text -> m (Object m) - lookupObjectOid :: Text -> m (ObjectOid m) - lookupObjectOid = fmap objectToObjOid . lookupObject - existsObject :: Oid m -> m Bool - - traverseObjects :: forall a. - (Oid m -> m a) -> Maybe (CommitOid m) -> m [a] - traverseObjects_ :: (Oid m -> m ()) -> Maybe (CommitOid m) -> m () - traverseObjects_ = (void .) . traverseObjects - - pushCommit :: (MonadTrans t, MonadGit m, MonadGit (t m), - Repository m, Repository (t m)) - => CommitOid m -> Maybe Text -> Text -> t m (CommitOid (t m)) - - traverseCommits :: forall a. - (CommitOid m -> m a) -> CommitOid m -> m [a] - traverseCommits_ :: (CommitOid m -> m ()) -> CommitOid m -> m () - traverseCommits_ = (void .) . traverseCommits - - missingObjects :: Maybe (CommitOid m) -- ^ A commit we may already have - -> CommitOid m -- ^ The commit we need - -> m [ObjectOid m] -- ^ All the objects in between - - -- Object creation, not to be called by users directly - newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder 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) - createCommit :: [CommitOid m] -> TreeOid m - -> Signature -> Signature -> Text -> Maybe Text -> m (Commit m) - createTag :: CommitOid m -> Signature -> Text -> Text -> m (Tag m) - - deleteRepository :: m () - - -- Pack files - buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] - -> m FilePath - buildPackFile _ _ = - failure (BackendError "Backend does not support building pack files") - - buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) - buildPackIndex _ _ = - failure (BackendError "Backend does not support building pack indexes") - - writePackFile :: FilePath -> m () - writePackFile _ = - failure (BackendError "Backend does not support writing pack files") - - -- Git remotes - remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () - -{- $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 - | BlobEmptyCreateFailed - | BlobEncodingUnknown Text - | BlobLookupFailed - | PushNotFastForward Text - | TranslationException Text - | TreeCreateFailed Text - | TreeBuilderCreateFailed - | TreeBuilderInsertFailed Text - | TreeBuilderRemoveFailed Text - | TreeBuilderWriteFailed Text - | TreeLookupFailed - | TreeCannotTraverseBlob - | TreeCannotTraverseCommit - | TreeEntryLookupFailed FilePath - | TreeUpdateFailed - | TreeWalkFailed - | CommitCreateFailed - | CommitLookupFailed Text - | ReferenceCreateFailed - | ReferenceDeleteFailed Text - | RefCannotCreateFromPartialOid - | ReferenceListingFailed - | ReferenceLookupFailed Text - | ObjectLookupFailed Text Int - | ObjectRefRequiresFullOid - | OidCopyFailed - | OidParseFailed Text - | QuotaHardLimitExceeded Int Int - deriving (Eq, Show, Typeable) - --- jww (2013-02-11): Create a BackendException data constructor of forall --- e. Exception e => BackendException e, so that each can throw a derived --- exception. -instance Exc.Exception GitException - -{- $oids -} -type BlobOid m = Tagged (Blob m) (Oid m) -type TreeOid m = Tagged (Tree m) (Oid m) -type CommitOid m = Tagged (Commit m) (Oid m) -type TagOid m = Tagged (Tag m) (Oid m) - -{- $references -} -data RefTarget m = RefObj !(CommitOid m) | RefSymbolic !Text - -data Reference m = Reference - { referenceName :: !Text - , referenceTarget :: !(RefTarget m) } - -data CommitName m = CommitObjectId !(CommitOid m) - | CommitReferenceName !Text - | CommitReference !(Reference m) - -instance Repository m => Show (CommitName m) where - show (CommitObjectId coid) = T.unpack (renderObjOid coid) - show (CommitReferenceName name) = show name - show (CommitReference ref) = show (referenceName ref) - -nameOfCommit :: Commit m -> CommitName m -nameOfCommit = CommitObjectId . commitOid - -commitNameToOid :: Repository m => CommitName m -> m (Maybe (CommitOid m)) -commitNameToOid (CommitObjectId coid) = return (Just coid) -commitNameToOid (CommitReferenceName name) = resolveReference name -commitNameToOid (CommitReference ref) = referenceToOid Nothing (Just ref) - -renderCommitName :: Repository m => CommitName m -> Text -renderCommitName (CommitObjectId coid) = renderObjOid coid -renderCommitName (CommitReferenceName name) = name -renderCommitName (CommitReference ref) = referenceName ref - -copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n) -copyOid = parseOid . renderOid - -copyCommitOid :: (Repository m, MonadGit m, Repository n, MonadGit n) - => CommitOid m -> n (CommitOid n) -copyCommitOid coid = do - ncoid <- parseOid (renderObjOid coid) - return (Tagged ncoid) - -copyCommitName :: (Repository m, MonadGit m, Repository n, MonadGit n) - => CommitName m -> n (Maybe (CommitName n)) -copyCommitName (CommitObjectId coid) = - Just . CommitObjectId . Tagged <$> parseOid (renderObjOid coid) -copyCommitName (CommitReferenceName name) = - return (Just (CommitReferenceName name)) -copyCommitName (CommitReference ref) = - fmap CommitReference <$> lookupReference (referenceName ref) - -{- $objects -} -data ObjectOid m = BlobObjOid !(BlobOid m) - | TreeObjOid !(TreeOid m) - | CommitObjOid !(CommitOid m) - | TagObjOid !(TagOid m) - -data Object m = BlobObj !(Blob m) - | TreeObj !(Tree m) - | CommitObj !(Commit m) - | TagObj !(Tag m) - -objectOid :: Repository m => Object m -> Oid m -objectOid (BlobObj obj) = untag (blobOid obj) -objectOid (TreeObj obj) = untag (treeOid obj) -objectOid (CommitObj obj) = untag (commitOid obj) -objectOid (TagObj obj) = untag (tagOid obj) - -loadObject :: Repository m => ObjectOid m -> m (Object m) -loadObject (BlobObjOid oid) = BlobObj <$> lookupBlob oid -loadObject (TreeObjOid oid) = TreeObj <$> lookupTree oid -loadObject (CommitObjOid oid) = CommitObj <$> lookupCommit oid -loadObject (TagObjOid oid) = TagObj <$> lookupTag oid - -objectToObjOid :: Repository m => Object m -> ObjectOid m -objectToObjOid (BlobObj obj) = BlobObjOid (blobOid obj) -objectToObjOid (TreeObj obj) = TreeObjOid (treeOid obj) -objectToObjOid (CommitObj obj) = CommitObjOid (commitOid obj) -objectToObjOid (TagObj obj) = TagObjOid (tagOid obj) - -untagObjOid :: Repository m => ObjectOid m -> Oid m -untagObjOid (BlobObjOid oid) = untag oid -untagObjOid (TreeObjOid oid) = untag oid -untagObjOid (CommitObjOid oid) = untag oid -untagObjOid (TagObjOid oid) = untag oid - -{- $blobs -} -data Blob m = Blob { blobOid :: !(BlobOid m) - , blobContents :: !(BlobContents m) } - -type ByteSource m = Producer m ByteString - -data BlobContents m = BlobString !ByteString - | BlobStream !(ByteSource m) - | BlobSizedStream !(ByteSource m) !Int - -data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob | UnknownBlob - deriving (Show, Eq, Enum) - -instance Eq (BlobContents m) where - BlobString str1 == BlobString str2 = str1 == str2 - _ == _ = False - -{- $trees -} -newtype TreeT m a = TreeT { runTreeT :: StateT (TreeBuilder m) m a } - -instance Functor m => Functor (TreeT m) where - fmap f (TreeT t) = TreeT (fmap f t) - -instance Monad m => Monad (TreeT m) where - return x = TreeT (return x) - TreeT x >>= f = TreeT (x >>= runTreeT . f) - -instance (Functor m, Monad m) => Applicative (TreeT m) where - pure = return - (<*>) = ap - -instance (Functor m, MonadPlus m) => Alternative (TreeT m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlus m) => MonadPlus (TreeT m) where - mzero = TreeT $ mzero - m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n - -instance (MonadFix m) => MonadFix (TreeT m) where - mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) - -instance MonadTrans TreeT where - lift m = TreeT $ lift m - -instance (MonadIO m) => MonadIO (TreeT m) where - liftIO = lift . liftIO - -getBuilder :: Monad m => TreeT m (TreeBuilder m) -getBuilder = TreeT get - -putBuilder :: Monad m => TreeBuilder m -> TreeT m () -putBuilder = TreeT . put - -data BuilderAction = GetEntry | PutEntry | DropEntry - deriving (Eq, Show) - -getEntry :: Repository m => FilePath -> TreeT m (Maybe (TreeEntry m)) -getEntry path = do - tb <- getBuilder - snd <$> lift (queryTreeBuilder tb path GetEntry - (toModifyTreeResult TreeEntryPersistent)) - -putEntry :: Repository m => FilePath -> TreeEntry m -> TreeT m () -putEntry path ent = do - tb <- getBuilder - tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry - (const (TreeEntryMutated ent))) - putBuilder tb' - -dropEntry :: Repository m => FilePath -> TreeT m () -dropEntry path = do - tb <- getBuilder - tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry - (const TreeEntryDeleted)) - putBuilder tb' - -putBlob' :: Repository m => FilePath -> BlobOid m -> BlobKind -> TreeT m () -putBlob' path b kind = putEntry path (BlobEntry b kind) - -putBlob :: Repository m => FilePath -> BlobOid m -> TreeT m () -putBlob path b = putBlob' path b PlainBlob - -putTree :: Repository m => FilePath -> TreeOid m -> TreeT m () -putTree path t = putEntry path (TreeEntry t) - -putCommit :: Repository m => FilePath -> CommitOid m -> TreeT m () -putCommit path c = putEntry path (CommitEntry c) - -doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeOid m) -doWithTree mtr act = - fst <$> (runStateT (runTreeT go) =<< newTreeBuilder mtr) - where - go = liftM2 (,) act currentTreeOid - -withTree :: Repository m => Tree m -> TreeT m a -> m (a, TreeOid m) -withTree tr = doWithTree (Just tr) - -withTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (a, TreeOid m) -withTreeOid oid action = do - tree <- lookupTree oid - doWithTree (Just tree) action - -mutateTree :: Repository m => Tree m -> TreeT m a -> m (TreeOid m) -mutateTree tr action = snd <$> withTree tr action - -mutateTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (TreeOid m) -mutateTreeOid tr action = snd <$> withTreeOid tr action - -currentTreeOid :: Repository m => TreeT m (TreeOid m) -currentTreeOid = do - tb <- getBuilder - (tb', toid) <- lift $ writeTreeBuilder tb - putBuilder tb' - return toid - -currentTree :: Repository m => TreeT m (Tree m) -currentTree = lift . lookupTree =<< currentTreeOid - -withNewTree :: Repository m => TreeT m a -> m (a, TreeOid m) -withNewTree = doWithTree Nothing - -createTree :: Repository m => TreeT m a -> m (TreeOid m) -createTree action = snd <$> withNewTree action - -data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m) - , blobEntryKind :: !BlobKind } - | TreeEntry { treeEntryOid :: !(TreeOid m) } - | CommitEntry { commitEntryOid :: !(CommitOid m) } - -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 => Tree m -> TreeEntry m -treeEntry = TreeEntry . treeOid - -commitEntry :: Repository m => Commit m -> TreeEntry m -commitEntry = CommitEntry . commitOid - -data ModifyTreeResult m = TreeEntryNotFound - | TreeEntryDeleted - | TreeEntryPersistent (TreeEntry m) - | TreeEntryMutated (TreeEntry m) - -fromModifyTreeResult :: ModifyTreeResult m -> Maybe (TreeEntry m) -fromModifyTreeResult TreeEntryNotFound = Nothing -fromModifyTreeResult TreeEntryDeleted = Nothing -fromModifyTreeResult (TreeEntryPersistent x) = Just x -fromModifyTreeResult (TreeEntryMutated x) = Just x - -toModifyTreeResult :: (TreeEntry m -> ModifyTreeResult m) - -> Maybe (TreeEntry m) - -> ModifyTreeResult m -toModifyTreeResult _ Nothing = TreeEntryNotFound -toModifyTreeResult f (Just x) = f x - -{- $commits -} -data Signature = Signature - { signatureName :: !Text - , signatureEmail :: !Text - , signatureWhen :: !ZonedTime - } deriving Show - -instance Default Signature where - def = Signature - { signatureName = T.empty - , signatureEmail = T.empty - , signatureWhen = ZonedTime - { zonedTimeToLocalTime = LocalTime - { localDay = ModifiedJulianDay 0 - , localTimeOfDay = TimeOfDay 0 0 0 - } - , zonedTimeZone = utc - } - } - -data Commit m = Commit - { commitOid :: !(CommitOid m) - , commitParents :: ![CommitOid m] - , commitTree :: !(TreeOid m) - , commitAuthor :: !Signature - , commitCommitter :: !Signature - , commitLog :: !Text - , commitEncoding :: !Text - } - -commitRefTarget :: Commit m -> RefTarget m -commitRefTarget = RefObj . commitOid - -referenceToOid :: Repository m - => Maybe Text -> Maybe (Reference m) - -> m (Maybe (CommitOid m)) -referenceToOid mname mref = - case mref of - Nothing -> return Nothing - Just (Reference { referenceTarget = RefObj x }) -> - return (Just x) - Just ref@(Reference { referenceTarget = RefSymbolic name' }) -> - if fromMaybe name' mname /= name' - then resolveReference name' - else failure (ReferenceLookupFailed (referenceName ref)) - -{- $tags -} - -data Tag m = Tag - { tagOid :: !(TagOid m) - , tagCommit :: !(CommitOid m) - } - -{- $merges -} - -data ModificationKind = Unchanged | Modified | Added | Deleted | TypeChanged - deriving (Eq, Ord, Enum, Show, Read) - -data MergeStatus - = NoConflict - | BothModified - | LeftModifiedRightDeleted - | LeftDeletedRightModified - | BothAdded - | LeftModifiedRightTypeChanged - | LeftTypeChangedRightModified - | LeftDeletedRightTypeChanged - | LeftTypeChangedRightDeleted - | BothTypeChanged - deriving (Eq, Ord, Enum, Show, Read) - -mergeStatus :: ModificationKind -> ModificationKind -> MergeStatus -mergeStatus Unchanged Unchanged = NoConflict -mergeStatus Unchanged Modified = NoConflict -mergeStatus Unchanged Added = undefined -mergeStatus Unchanged Deleted = NoConflict -mergeStatus Unchanged TypeChanged = NoConflict - -mergeStatus Modified Unchanged = NoConflict -mergeStatus Modified Modified = BothModified -mergeStatus Modified Added = undefined -mergeStatus Modified Deleted = LeftModifiedRightDeleted -mergeStatus Modified TypeChanged = LeftModifiedRightTypeChanged - -mergeStatus Added Unchanged = undefined -mergeStatus Added Modified = undefined -mergeStatus Added Added = BothAdded -mergeStatus Added Deleted = undefined -mergeStatus Added TypeChanged = undefined - -mergeStatus Deleted Unchanged = NoConflict -mergeStatus Deleted Modified = LeftDeletedRightModified -mergeStatus Deleted Added = undefined -mergeStatus Deleted Deleted = NoConflict -mergeStatus Deleted TypeChanged = LeftDeletedRightTypeChanged - -mergeStatus TypeChanged Unchanged = NoConflict -mergeStatus TypeChanged Modified = LeftTypeChangedRightModified -mergeStatus TypeChanged Added = undefined -mergeStatus TypeChanged Deleted = LeftTypeChangedRightDeleted -mergeStatus TypeChanged TypeChanged = BothTypeChanged - -data MergeResult m - = MergeSuccess - { mergeCommit :: CommitOid m - } - | MergeConflicted - { mergeCommit :: CommitOid m - , mergeHeadLeft :: CommitOid m - , mergeHeadRight :: CommitOid m - , mergeConflicts :: Map FilePath (ModificationKind, ModificationKind) - } - -instance Repository m => Show (MergeResult m) where - show (MergeSuccess mc) = "MergeSuccess (" ++ show mc ++ ")" - show (MergeConflicted mc hl hr cs) = - "MergeResult" - ++ "\n { mergeCommit = " ++ show mc - ++ "\n , mergeHeadLeft = " ++ show hl - ++ "\n , mergeHeadRight = " ++ show hr - ++ "\n , mergeConflicts = " ++ show cs - ++ "\n }" - -copyConflict :: (Repository m, MonadGit m, Repository n, MonadGit n) - => MergeResult m -> n (MergeResult n) -copyConflict (MergeSuccess mc) = - MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc)) -copyConflict (MergeConflicted hl hr mc cs) = - MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl)) - <*> (Tagged <$> parseOid (renderObjOid hr)) - <*> (Tagged <$> parseOid (renderObjOid mc)) - <*> 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 b -> blobToByteString b - _ -> 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 - { mtbBaseTreeOid :: Maybe (TreeOid m) - , mtbPendingUpdates :: HashMap Text (TreeBuilder m) - , mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m) - , mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid 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 - { mtbBaseTreeOid = 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 - { mtbBaseTreeOid = mtbBaseTreeOid 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 tref)) - doUpdate _ bm name _ = returnTree bm name (f Nothing) - - update bm name [] (Left sbm) = doUpdate kind bm name sbm - update bm name [] (Right y) = returnTree bm name (f y) - - update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound) - update _ _ _ (Right (Just BlobEntry {})) = - failure TreeCannotTraverseBlob - update _ _ _ (Right (Just CommitEntry {})) = - failure TreeCannotTraverseCommit - - update bm name names arg = do - sbm <- case arg of - Left sbm' -> return sbm' - Right (Just (TreeEntry st')) -> do - tree <- lookupTree st' - ModifiedBuilder - <$> mtbNewBuilder (fromBuilderMod bm) (Just tree) - _ -> error "queryTreeBuilder encountered the impossible" - - (sbm', z) <- walk sbm names - let bm' = bm <> postUpdate bm sbm' name - return $ bm' `seq` (bm', z) - - returnTree bm@(fromBuilderMod -> tb) n z = do - bm' <- case z of - TreeEntryNotFound -> return bm - TreeEntryPersistent _ -> return bm - TreeEntryDeleted -> do - bm' <- mtbDropEntry tb tb n - let tb' = fromBuilderMod bm' - upds' = mtbPendingUpdates tb' - return $ case bm' of - ModifiedBuilder _ -> - ModifiedBuilder tb' - { mtbPendingUpdates = HashMap.delete n upds' } - BuilderUnchanged _ -> - if HashMap.member n upds' - then ModifiedBuilder tb' - { mtbPendingUpdates = HashMap.delete n upds' } - else bm' - TreeEntryMutated z' -> mtbPutEntry tb tb n z' - let bm'' = bm <> bm' - return $ bm'' `seq` (bm'', z) - - postUpdate bm (BuilderUnchanged _) _ = bm - postUpdate (fromBuilderMod -> tb) (ModifiedBuilder sbm) name = - ModifiedBuilder $ tb - { mtbPendingUpdates = - HashMap.insert name sbm (mtbPendingUpdates tb) } - --- | Write out a tree to its repository. If it has already been written, --- nothing will happen. -writeTreeBuilder :: Repository m - => TreeBuilder m - -> m (TreeBuilder m, TreeOid m) -writeTreeBuilder builder = do - (bm, mtref) <- go (BuilderUnchanged builder) - tref <- case mtref of - Nothing -> parseObjOid emptyTreeId - Just tref -> return tref - return (fromBuilderMod bm, tref) - where - go bm = do - let upds = mtbPendingUpdates (fromBuilderMod bm) - bm' <- if HashMap.size upds == 0 - then return bm - else do - bm' <- foldM update bm $ HashMap.toList upds - return $ ModifiedBuilder (fromBuilderMod bm') - { mtbPendingUpdates = HashMap.empty } - let tb' = fromBuilderMod bm' - cnt <- mtbEntryCount tb' - if cnt == 0 - then return (bm', Nothing) - else do - (bm'', tref) <- mtbWriteContents tb' tb' - return (bm' <> bm'', Just tref) - - update bm (k,v) = do - let tb = fromBuilderMod bm - -- The intermediate TreeBuilder will be dropped after this fold is - -- completed, by setting mtbPendingUpdates to HashMap.empty, above. - (_,mtref) <- go (BuilderUnchanged v) - bm' <- case mtref of - Nothing -> mtbDropEntry tb tb k - Just tref -> mtbPutEntry tb tb k (TreeEntry tref) - return $ bm <> bm' - -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 =<< lookupTree (commitTree c) - -copyBlob :: (Repository m, Repository (t m), MonadTrans t) - => BlobOid m - -> HashSet Text - -> t m (BlobOid (t m), HashSet Text) -copyBlob blobr needed = do - let oid = untag blobr - sha = renderOid oid - oid2 <- parseOid (renderOid oid) - if HashSet.member sha needed - then do - bs <- lift $ blobToByteString =<< lookupBlob (Tagged oid) - boid <- createBlob (BlobString bs) - - let x = HashSet.delete sha needed - return $ boid `seq` x `seq` (boid, x) - - else return (Tagged oid2, needed) - -copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) - => TreeEntry m - -> HashSet Text - -> t m (TreeEntry (t m), HashSet Text) -copyTreeEntry (BlobEntry oid kind) needed = do - (b,needed') <- copyBlob oid needed - return (BlobEntry b kind, needed') -copyTreeEntry (CommitEntry oid) needed = do - coid <- parseOid (renderObjOid oid) - return (CommitEntry (Tagged coid), needed) -copyTreeEntry (TreeEntry _) _ = error "This should never be called" - -copyTree :: (Repository m, Repository (t m), MonadTrans t) - => TreeOid m - -> HashSet Text - -> t m (TreeOid (t m), HashSet Text) -copyTree tr needed = do - let oid = untag tr - sha = renderOid oid - oid2 <- parseOid (renderOid oid) - if HashSet.member sha needed - then do - tree <- lift $ lookupTree tr - entries <- lift $ 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 (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) - => CommitOid m - -> Maybe Text - -> HashSet Text - -> t m (CommitOid (t m), HashSet Text) -copyCommit cr mref needed = do - let oid = untag cr - sha = renderOid oid - commit <- lift $ lookupCommit cr - oid2 <- parseOid sha - if HashSet.member sha needed - then do - let parents = commitParents commit - (parentRefs,needed') <- foldM copyParent ([],needed) parents - (tr,needed'') <- copyTree (commitTree commit) needed' - - 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' - 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 => [ObjectOid m] -> m [ObjectOid m] -allMissingObjects objs = - fmap concat . forM objs $ \obj -> case obj of - TreeObjOid toid -> do - tr <- lookupTree toid - subobjss <- flip traverseEntries tr $ \_ ent -> - return $ case ent of - BlobEntry oid _ -> [BlobObjOid oid] - TreeEntry oid -> [TreeObjOid 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) - => CommitOid m -> Text -> t m (CommitOid (t m)) -genericPushCommit coid remoteRefName = do - mrref <- lookupReference remoteRefName - commits1 <- lift $ traverseCommits crefToSha coid - 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 (Tagged roid)) - | otherwise -> do - failure (PushNotFastForward $ - "SHA " <> rsha - <> " not found in remote") - Nothing -> return (Just Nothing) - case fastForward of - Nothing -> failure (PushNotFastForward "unexpected") - Just rref -> do - objs <- lift $ allMissingObjects =<< missingObjects rref coid - shas <- mapM (return . renderOid . untagObjOid) objs - (cref,_) <- copyCommit coid Nothing (HashSet.fromList shas) - -- jww (2013-04-18): This is something the user must - -- decide to do - -- updateReference_ remoteRefName (RefObj cref) - return cref - where - referenceSha ref = fmap renderObjOid <$> referenceToOid Nothing (Just ref) - crefToSha cref = return $ renderObjOid cref - -commitHistoryFirstParent :: Repository m => Commit m -> m [Commit m] -commitHistoryFirstParent c = - case commitParents c of - [] -> return [c] - (p:_) -> do ps <- commitHistoryFirstParent =<< lookupCommit 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 =<< lookupCommit 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 lookupCommit . commitParents - -resolveReferenceTree :: Repository m => Text -> m (Maybe (Tree m)) -resolveReferenceTree refName = do - c <- resolveReference refName - case c of - Nothing -> return Nothing - Just c' -> - Just <$> (lookupCommit c' >>= lookupTree . 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 - , repoIsBare :: !Bool - , repoAutoCreate :: !Bool - } - -instance Default RepositoryOptions where - def = RepositoryOptions "" True True - -data RepositoryFactory t m c = RepositoryFactory - { openRepository :: RepositoryOptions -> m c - , runRepository :: forall a. c -> t m a -> m a - , closeRepository :: c -> m () - , getRepository :: t m c - , defaultOptions :: !RepositoryOptions - , startupBackend :: m () - , shutdownBackend :: m () - } - -withBackendDo :: (MonadIO m, MonadBaseControl IO m) - => RepositoryFactory t m a -> m b -> m b -withBackendDo fact f = do - startupBackend fact - Exc.finally f (liftIO performGC >> shutdownBackend fact) - -withRepository' :: (Repository (t m), MonadTrans t, - MonadBaseControl IO m, MonadIO m) - => RepositoryFactory t m c - -> RepositoryOptions - -> t m a - -> m a -withRepository' factory opts action = - Exc.bracket - (openRepository factory opts) - (closeRepository factory) - (flip (runRepository factory) action) - -withRepository :: (Repository (t m), MonadTrans t, - MonadBaseControl IO m, MonadIO m) - => RepositoryFactory t m c - -> FilePath - -> t m a - -> m a -withRepository factory path = - withRepository' factory - (defaultOptions factory) { repoPath = path } - --- Git.hs +-- | Interface for working with Git repositories. +module Git + ( module X + ) where + +import Git.Blob as X +import Git.Commit 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 diff --git a/Git/Blob.hs b/Git/Blob.hs new file mode 100644 --- /dev/null +++ b/Git/Blob.hs @@ -0,0 +1,61 @@ +module Git.Blob where + +import Control.Monad +import Control.Monad.Trans.Class +import Data.ByteString as B +import Data.Conduit +import qualified Data.Conduit.List as CList +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Tagged +import Data.Text as T +import Data.Text.Encoding as T +import Git.Types +import Prelude hiding (FilePath) + +createBlobUtf8 :: Repository m => Text -> m (BlobOid m) +createBlobUtf8 = createBlob . BlobString . T.encodeUtf8 + +catBlob :: Repository m => BlobOid m -> m ByteString +catBlob = lookupBlob >=> blobToByteString + +catBlobUtf8 :: Repository m => BlobOid m -> m Text +catBlobUtf8 = catBlob >=> return . T.decodeUtf8 + +blobContentsToByteString :: Repository m => BlobContents m -> m ByteString +blobContentsToByteString (BlobString bs) = return bs +blobContentsToByteString (BlobStream bs) = 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 + +treeBlobEntries :: Repository m => Tree m -> m [(Text, BlobOid m, BlobKind)] +treeBlobEntries tree = do + entries <- listTreeEntries tree + return $ Prelude.foldr f [] entries + where + f (fp ,BlobEntry oid k) xs = (fp, oid, k):xs + f _ xs = xs + +copyBlob :: (Repository m, Repository (t m), MonadTrans t) + => BlobOid m + -> HashSet Text + -> t m (BlobOid (t m), HashSet Text) +copyBlob blobr needed = do + let oid = untag blobr + sha = renderOid oid + oid2 <- parseOid (renderOid oid) + if HashSet.member sha needed + then do + bs <- lift $ blobToByteString =<< lookupBlob (Tagged oid) + boid <- createBlob (BlobString bs) + + let x = HashSet.delete sha needed + return $ boid `seq` x `seq` (boid, x) + + else return (Tagged oid2, needed) diff --git a/Git/Commit.hs b/Git/Commit.hs new file mode 100644 --- /dev/null +++ b/Git/Commit.hs @@ -0,0 +1,69 @@ +module Git.Commit where + +import Control.Monad +import Control.Monad.Trans.Class +import Data.Function +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.List +import Data.Maybe +import Data.Tagged +import Data.Text (Text) +import Git.Tree +import Git.Types +import Prelude hiding (FilePath) + +commitTreeEntry :: Repository m + => Commit m + -> Text + -> m (Maybe (TreeEntry m)) +commitTreeEntry c path = flip treeEntry path =<< lookupTree (commitTree c) + +copyCommitOid :: (Repository m, Repository n) => CommitOid m -> n (CommitOid n) +copyCommitOid = parseObjOid . renderObjOid + +copyCommit :: (Repository m, Repository (t m), MonadTrans t) + => CommitOid m + -> Maybe Text + -> HashSet Text + -> t m (CommitOid (t m), HashSet Text) +copyCommit cr mref needed = do + let oid = untag cr + sha = renderOid oid + commit <- lift $ lookupCommit cr + oid2 <- parseOid sha + if HashSet.member sha needed + then do + let parents = commitParents commit + (parentRefs,needed') <- foldM copyParent ([],needed) parents + (tr,needed'') <- copyTree (commitTree commit) needed' + + 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' + let x = cref2 `seq` (cref2:prefs) + return $ x `seq` needed'' `seq` (x,needed'') + +listCommits :: Repository m + => Maybe (CommitOid m) -- ^ A commit we may already have + -> CommitOid m -- ^ The commit we need + -> m [CommitOid m] -- ^ All the objects in between +listCommits have need = + mapM (\(CommitObjOid c) -> return c) =<< listObjects have need False + +traverseCommits :: Repository m => (CommitOid m -> m a) -> CommitOid m -> m [a] +traverseCommits f need = mapM f =<< listCommits Nothing need + +traverseCommits_ :: Repository m => (CommitOid m -> m ()) -> CommitOid m -> m () +traverseCommits_ = (void .) . traverseCommits diff --git a/Git/Commit/Push.hs b/Git/Commit/Push.hs new file mode 100644 --- /dev/null +++ b/Git/Commit/Push.hs @@ -0,0 +1,46 @@ +module Git.Commit.Push where + +import Control.Failure +import Control.Monad +import Control.Monad.Trans.Class +import Data.Function +import qualified Data.HashSet as HashSet +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import Git.Commit +import Git.Reference +import Git.Object +import Git.Types +import Prelude hiding (FilePath) + +-- | Fast-forward push a reference between repositories using a recursive +-- copy. This can be extremely slow, but always works no matter which two +-- backends are being used. It should be considered a matter of last +-- resort, or for objects sets that are known to be small. +genericPushCommit :: (Repository m, Repository (t m), MonadTrans t) + => CommitOid m -> Text -> t m (CommitOid (t m)) +genericPushCommit coid remoteRefName = do + mrref <- resolveReference remoteRefName + commits1 <- mapM copyCommitOid =<< lift (listCommits Nothing coid) + fastForward <- case mrref of + Nothing -> return (Just Nothing) + Just rref + | rref `elem` commits1 -> do + roid <- lift $ copyCommitOid rref + return $ Just (Just roid) + | otherwise -> do + failure (PushNotFastForward $ + "SHA " <> renderObjOid rref + <> " not found in remote") + case fastForward of + Nothing -> failure (PushNotFastForward "unexpected") + Just rref -> do + objs <- lift $ listAllObjects rref coid + shas <- mapM (return . renderOid . untagObjOid) objs + (cref,_) <- copyCommit coid Nothing (HashSet.fromList shas) + -- jww (2013-04-18): This is something the user must + -- decide to do + -- updateReference_ remoteRefName (RefObj cref) + return cref diff --git a/Git/Object.hs b/Git/Object.hs new file mode 100644 --- /dev/null +++ b/Git/Object.hs @@ -0,0 +1,36 @@ +module Git.Object where + +import Control.Monad +import Data.Function +import Data.List +import Data.Maybe +import Git.Types +import Prelude hiding (FilePath) + +traverseObjects :: Repository m => (ObjectOid m -> m a) -> CommitOid m -> m [a] +traverseObjects f need = mapM f =<< listObjects Nothing need False + +traverseObjects_ :: Repository m => (ObjectOid m -> m ()) -> CommitOid m -> m () +traverseObjects_ = (void .) . traverseObjects + +-- | Given a list of objects (commit and top-level trees) return by +-- 'listObjects', expand it to include all subtrees and blobs as well. +-- Ordering is preserved. +expandTreeObjects :: Repository m => [ObjectOid m] -> m [ObjectOid m] +expandTreeObjects objs = + fmap concat . forM objs $ \obj -> case obj of + TreeObjOid toid -> do + tr <- lookupTree toid + entries <- listTreeEntries tr + let subobjss = foldr f [] entries + return (obj:subobjss) + _ -> return [obj] + where + f (_, ent) rest = case ent of + BlobEntry oid _ -> BlobObjOid oid : rest + TreeEntry oid -> TreeObjOid oid : rest + _ -> rest + +listAllObjects :: Repository m + => Maybe (CommitOid m) -> CommitOid m -> m [ObjectOid m] +listAllObjects have need = expandTreeObjects =<< listObjects have need True diff --git a/Git/Reference.hs b/Git/Reference.hs new file mode 100644 --- /dev/null +++ b/Git/Reference.hs @@ -0,0 +1,21 @@ +module Git.Reference where + +import Control.Applicative +import Data.Text +import Git.Types + +resolveReference :: Repository m => Text -> m (Maybe (CommitOid m)) +resolveReference name = do + mref <- lookupReference name + maybe (return Nothing) referenceToOid mref + +referenceToOid :: Repository m => RefTarget m -> m (Maybe (CommitOid m)) +referenceToOid (RefObj oid) = return $ Just oid +referenceToOid (RefSymbolic name) = resolveReference name + +resolveReferenceTree :: Repository m => Text -> m (Maybe (Tree m)) +resolveReferenceTree refName = do + c <- resolveReference refName + case c of + Nothing -> return Nothing + Just c' -> Just <$> (lookupCommit c' >>= lookupTree . commitTree) diff --git a/Git/Repository.hs b/Git/Repository.hs new file mode 100644 --- /dev/null +++ b/Git/Repository.hs @@ -0,0 +1,79 @@ +module Git.Repository where + +import qualified Control.Exception.Lifted as Exc +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Conduit +import Data.Function +import Filesystem +import Filesystem.Path.CurrentOS hiding (null, concat) +import Git.Types +import Prelude hiding (FilePath) +import System.Mem + +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 + + +withBackendDo :: (MonadIO m, MonadBaseControl IO m) + => RepositoryFactory t m a -> m b -> m b +withBackendDo fact f = do + startupBackend fact + Exc.finally f (liftIO performGC >> shutdownBackend fact) + +withRepository' :: (Repository (t m), MonadTrans t, + MonadBaseControl IO m, MonadIO m) + => RepositoryFactory t m c + -> RepositoryOptions + -> t m a + -> m a +withRepository' factory opts action = + Exc.bracket + (openRepository factory opts) + (closeRepository factory) + (flip (runRepository factory) action) + +withRepository :: (Repository (t m), MonadTrans t, + MonadBaseControl IO m, MonadIO m) + => RepositoryFactory t m c + -> FilePath + -> t m a + -> m a +withRepository factory path = + withRepository' factory + (defaultOptions factory) { repoPath = path } diff --git a/Git/Tree.hs b/Git/Tree.hs new file mode 100644 --- /dev/null +++ b/Git/Tree.hs @@ -0,0 +1,55 @@ +module Git.Tree where + +import Control.Monad +import Control.Monad.Trans.Class +import Data.Function +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Tagged +import Data.Text (Text) +import Git.Blob +import Git.Tree.Builder +import Git.Types +import Prelude hiding (FilePath) + +copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) + => TreeEntry m + -> HashSet Text + -> t m (TreeEntry (t m), HashSet Text) +copyTreeEntry (BlobEntry oid kind) needed = do + (b,needed') <- copyBlob oid needed + return (BlobEntry b kind, needed') +copyTreeEntry (CommitEntry oid) needed = do + coid <- parseOid (renderObjOid oid) + return (CommitEntry (Tagged coid), needed) +copyTreeEntry (TreeEntry _) _ = error "This should never be called" + +copyTree :: (Repository m, Repository (t m), MonadTrans t) + => TreeOid m + -> HashSet Text + -> t m (TreeOid (t m), HashSet Text) +copyTree tr needed = do + let oid = untag tr + sha = renderOid oid + oid2 <- parseOid (renderOid oid) + if HashSet.member sha needed + then do + tree <- lift $ lookupTree tr + entries <- lift $ listTreeEntries tree + (needed', tref) <- + withNewTree $ foldM doCopyTreeEntry needed entries + + let x = HashSet.delete sha needed' + return $ tref `seq` x `seq` (tref, x) + + else return (Tagged oid2, needed) + where + doCopyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) + => HashSet Text + -> (Text, TreeEntry m) + -> TreeT (t m) (HashSet Text) + doCopyTreeEntry set (_, TreeEntry {}) = return set + doCopyTreeEntry set (fp, ent) = do + (ent2,set') <- lift $ copyTreeEntry ent set + putEntry fp ent2 + return set' diff --git a/Git/Tree/Builder.hs b/Git/Tree/Builder.hs new file mode 100644 --- /dev/null +++ b/Git/Tree/Builder.hs @@ -0,0 +1,293 @@ +module Git.Tree.Builder + ( TreeT + , TreeBuilder(..) + , ModifiedBuilder(..) + , createTree + , withNewTree + , mutateTree + , mutateTreeOid + , currentTree + , withTree + , withTreeOid + , dropEntry + , getEntry + , putBlob + , putBlob' + , putCommit + , putEntry + , putTree + , treeEntry + , ModifyTreeResult(..) + , fromModifyTreeResult + , toModifyTreeResult + , emptyTreeId + ) where + +import Control.Applicative +import Control.Failure +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Data.Function +import qualified Data.HashMap.Strict as HashMap +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Git.Types +import Prelude hiding (FilePath) + +data ModifyTreeResult m = TreeEntryNotFound + | TreeEntryDeleted + | TreeEntryPersistent (TreeEntry m) + | TreeEntryMutated (TreeEntry m) + +fromModifyTreeResult :: ModifyTreeResult m -> Maybe (TreeEntry m) +fromModifyTreeResult TreeEntryNotFound = Nothing +fromModifyTreeResult TreeEntryDeleted = Nothing +fromModifyTreeResult (TreeEntryPersistent x) = Just x +fromModifyTreeResult (TreeEntryMutated x) = Just x + +toModifyTreeResult :: (TreeEntry m -> ModifyTreeResult m) + -> Maybe (TreeEntry m) + -> ModifyTreeResult m +toModifyTreeResult _ Nothing = TreeEntryNotFound +toModifyTreeResult f (Just x) = f x + +newtype TreeT m a = TreeT { runTreeT :: StateT (TreeBuilder m) m a } + +instance Functor m => Functor (TreeT m) where + fmap f (TreeT t) = TreeT (fmap f t) + +instance Monad m => Monad (TreeT m) where + return x = TreeT (return x) + TreeT x >>= f = TreeT (x >>= runTreeT . f) + +instance (Functor m, Monad m) => Applicative (TreeT m) where + pure = return + (<*>) = ap + +instance (Functor m, MonadPlus m) => Alternative (TreeT m) where + empty = mzero + (<|>) = mplus + +instance (MonadPlus m) => MonadPlus (TreeT m) where + mzero = TreeT $ mzero + m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n + +instance (MonadFix m) => MonadFix (TreeT m) where + mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) + +instance MonadTrans TreeT where + lift m = TreeT $ lift m + +instance (MonadIO m) => MonadIO (TreeT m) where + liftIO = lift . liftIO + +getBuilder :: Monad m => TreeT m (TreeBuilder m) +getBuilder = TreeT get + +putBuilder :: Monad m => TreeBuilder m -> TreeT m () +putBuilder = TreeT . put + +data BuilderAction = GetEntry | PutEntry | DropEntry + deriving (Eq, Show) + +emptyTreeId :: Text +emptyTreeId = "4b825dc642cb6eb9a060e54bf8d69288fbee4904" + +-- | Perform a query action on a TreeBuilder using the supplied action kind +-- and user function. +-- +-- This is a complex algorithm which has been rewritten many times, so I +-- will try to guide you through it as best I can. +queryTreeBuilder :: Repository m + => TreeBuilder m + -> Text + -> 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 tref)) + doUpdate _ bm name _ = returnTree bm name (f Nothing) + + update bm name [] (Left sbm) = doUpdate kind bm name sbm + update bm name [] (Right y) = returnTree bm name (f y) + + update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound) + update _ _ _ (Right (Just BlobEntry {})) = + failure TreeCannotTraverseBlob + update _ _ _ (Right (Just CommitEntry {})) = + failure TreeCannotTraverseCommit + + update bm name names arg = do + sbm <- case arg of + Left sbm' -> return sbm' + Right (Just (TreeEntry st')) -> do + tree <- lookupTree st' + ModifiedBuilder + <$> mtbNewBuilder (fromBuilderMod bm) (Just tree) + _ -> error "queryTreeBuilder encountered the impossible" + + (sbm', z) <- walk sbm names + let bm' = bm <> postUpdate bm sbm' name + return $ bm' `seq` (bm', z) + + returnTree bm@(fromBuilderMod -> tb) n z = do + bm' <- case z of + TreeEntryNotFound -> return bm + TreeEntryPersistent _ -> return bm + TreeEntryDeleted -> do + bm' <- mtbDropEntry tb tb n + let tb' = fromBuilderMod bm' + upds' = mtbPendingUpdates tb' + return $ case bm' of + ModifiedBuilder _ -> + ModifiedBuilder tb' + { mtbPendingUpdates = HashMap.delete n upds' } + BuilderUnchanged _ -> + if HashMap.member n upds' + then ModifiedBuilder tb' + { mtbPendingUpdates = HashMap.delete n upds' } + else bm' + TreeEntryMutated z' -> mtbPutEntry tb tb n z' + let bm'' = bm <> bm' + return $ bm'' `seq` (bm'', z) + + postUpdate bm (BuilderUnchanged _) _ = bm + postUpdate (fromBuilderMod -> tb) (ModifiedBuilder sbm) name = + ModifiedBuilder $ tb + { mtbPendingUpdates = + HashMap.insert name sbm (mtbPendingUpdates tb) } + +-- | Write out a tree to its repository. If it has already been written, +-- nothing will happen. +writeTreeBuilder :: Repository m + => TreeBuilder m -> m (TreeBuilder m, TreeOid m) +writeTreeBuilder builder = do + (bm, mtref) <- go (BuilderUnchanged builder) + tref <- case mtref of + Nothing -> parseObjOid emptyTreeId + Just tref -> return tref + return (fromBuilderMod bm, tref) + where + go bm = do + let upds = mtbPendingUpdates (fromBuilderMod bm) + bm' <- if HashMap.size upds == 0 + then return bm + else do + bm' <- foldM update bm $ HashMap.toList upds + return $ ModifiedBuilder (fromBuilderMod bm') + { mtbPendingUpdates = HashMap.empty } + let tb' = fromBuilderMod bm' + cnt <- mtbEntryCount tb' + if cnt == 0 + then return (bm', Nothing) + else do + (bm'', tref) <- mtbWriteContents tb' tb' + return (bm' <> bm'', Just tref) + + update bm (k,v) = do + let tb = fromBuilderMod bm + -- The intermediate TreeBuilder will be dropped after this fold is + -- completed, by setting mtbPendingUpdates to HashMap.empty, above. + (_,mtref) <- go (BuilderUnchanged v) + bm' <- case mtref of + Nothing -> mtbDropEntry tb tb k + Just tref -> mtbPutEntry tb tb k (TreeEntry tref) + return $ bm <> bm' + +getEntry :: Repository m => Text -> TreeT m (Maybe (TreeEntry m)) +getEntry path = do + tb <- getBuilder + snd <$> lift (queryTreeBuilder tb path GetEntry + (toModifyTreeResult TreeEntryPersistent)) + +putEntry :: Repository m => Text -> TreeEntry m -> TreeT m () +putEntry path ent = do + tb <- getBuilder + tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry + (const (TreeEntryMutated ent))) + putBuilder tb' + +dropEntry :: Repository m => Text -> TreeT m () +dropEntry path = do + tb <- getBuilder + tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry + (const TreeEntryDeleted)) + putBuilder tb' + +putBlob' :: Repository m => Text -> BlobOid m -> BlobKind -> TreeT m () +putBlob' path b kind = putEntry path (BlobEntry b kind) + +putBlob :: Repository m => Text -> BlobOid m -> TreeT m () +putBlob path b = putBlob' path b PlainBlob + +putTree :: Repository m => Text -> TreeOid m -> TreeT m () +putTree path t = putEntry path (TreeEntry t) + +putCommit :: Repository m => Text -> CommitOid m -> TreeT m () +putCommit path c = putEntry path (CommitEntry c) + +doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeOid m) +doWithTree mtr act = + fst <$> (runStateT (runTreeT go) =<< newTreeBuilder mtr) + where + go = liftM2 (,) act currentTreeOid + +withTree :: Repository m => Tree m -> TreeT m a -> m (a, TreeOid m) +withTree tr = doWithTree (Just tr) + +withTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (a, TreeOid m) +withTreeOid oid action = do + tree <- lookupTree oid + doWithTree (Just tree) action + +mutateTree :: Repository m => Tree m -> TreeT m a -> m (TreeOid m) +mutateTree tr action = snd <$> withTree tr action + +mutateTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (TreeOid m) +mutateTreeOid tr action = snd <$> withTreeOid tr action + +currentTreeOid :: Repository m => TreeT m (TreeOid m) +currentTreeOid = do + tb <- getBuilder + (tb', toid) <- lift $ writeTreeBuilder tb + putBuilder tb' + return toid + +currentTree :: Repository m => TreeT m (Tree m) +currentTree = lift . lookupTree =<< currentTreeOid + +withNewTree :: Repository m => TreeT m a -> m (a, TreeOid m) +withNewTree = doWithTree Nothing + +createTree :: Repository m => TreeT m a -> m (TreeOid m) +createTree action = snd <$> withNewTree action + +splitPath :: Text -> [Text] +splitPath = T.splitOn "/" diff --git a/Git/Tree/Builder/Pure.hs b/Git/Tree/Builder/Pure.hs new file mode 100644 --- /dev/null +++ b/Git/Tree/Builder/Pure.hs @@ -0,0 +1,70 @@ +module Git.Tree.Builder.Pure + ( EntryHashMap + , newPureTreeBuilder + ) where + +import Control.Applicative +import Data.Monoid +import Data.Text +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Git + +type EntryHashMap m = HashMap Text (TreeEntry m) + +-- | Create a new, empty tree. +-- +-- Since empty trees cannot exist in Git, attempting to write out an empty +-- tree is a no-op. +newPureTreeBuilder :: Repository m + => (Tree m -> m (EntryHashMap m)) + -> (EntryHashMap m -> m (TreeOid m)) + -> Maybe (Tree m) + -> m (TreeBuilder m) +newPureTreeBuilder reader writer mtree = do + entMap <- case mtree of + Nothing -> return HashMap.empty + Just tree -> reader tree + return $ makePureBuilder + (treeOid <$> mtree) + mempty + (newPureTreeBuilder reader writer) + entMap + writer + +makePureBuilder :: Repository m + => Maybe (TreeOid m) + -> HashMap Text (TreeBuilder m) + -> (Maybe (Tree m) -> m (TreeBuilder m)) + -> EntryHashMap m + -> (EntryHashMap m -> m (TreeOid m)) + -> TreeBuilder m +makePureBuilder baseTree upds newBuilder entMap writer = TreeBuilder + { mtbBaseTreeOid = baseTree + , mtbPendingUpdates = upds + , mtbNewBuilder = newBuilder + + , mtbWriteContents = \tb -> (,) <$> pure (BuilderUnchanged tb) + <*> writer entMap + + , mtbLookupEntry = \key -> return $ HashMap.lookup key entMap + , mtbEntryCount = return $ HashMap.size entMap + + , mtbPutEntry = \tb key ent -> + return . ModifiedBuilder $ + makePureBuilder + baseTree + (mtbPendingUpdates tb) + newBuilder + (HashMap.insert key ent entMap) + writer + + , mtbDropEntry = \tb key -> + return . ModifiedBuilder $ + makePureBuilder + baseTree + (mtbPendingUpdates tb) + newBuilder + (HashMap.delete key entMap) + writer + } diff --git a/Git/Types.hs b/Git/Types.hs new file mode 100644 --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,427 @@ +module Git.Types where + +import Control.Applicative +import qualified Control.Exception.Lifted as Exc +import Control.Failure +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +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 Data.Default +import Data.Function +import Data.HashMap.Strict (HashMap) +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.Typeable +import Filesystem.Path.CurrentOS hiding (null, concat) +import Prelude hiding (FilePath) + +data RepositoryFacts = RepositoryFacts + { hasSymbolicReferences :: !Bool + } deriving Show + +type MonadGit m = (Failure GitException m, Applicative m, + MonadIO m, MonadBaseControl IO m) + +-- | 'Repository' is the central point of contact between user code and Git +-- data objects. Every object must belong to some repository. +class (Applicative m, Monad m, Failure GitException m, IsOid (Oid m)) + => Repository m where + type Oid m :: * + data Tree m :: * + data Options m :: * + + facts :: m RepositoryFacts + parseOid :: Text -> m (Oid m) + deleteRepository :: m () + + -- References + createReference :: Text -> RefTarget m -> m () + lookupReference :: Text -> m (Maybe (RefTarget m)) + updateReference :: Text -> RefTarget m -> m () + deleteReference :: Text -> m () + listReferences :: m [Text] + + -- Object lookup + lookupCommit :: CommitOid m -> m (Commit m) + lookupTree :: TreeOid m -> m (Tree m) + lookupBlob :: BlobOid m -> m (Blob m) + lookupTag :: TagOid m -> m (Tag m) + lookupObject :: Oid m -> m (Object m) + existsObject :: Oid m -> m Bool + listObjects :: Maybe (CommitOid m) -- ^ A commit we may already have + -> CommitOid m -- ^ The commit we need + -> Bool -- ^ Include commit trees also? + -> m [ObjectOid m] -- ^ All the objects in between + + -- Working with trees + newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m) + + treeOid :: Tree m -> TreeOid m + treeEntry :: Tree m -> Text -> m (Maybe (TreeEntry m)) + listTreeEntries :: Tree m -> m [(Text, TreeEntry m)] + + -- Creating other objects + hashContents :: BlobContents m -> m (BlobOid m) + createBlob :: BlobContents m -> m (BlobOid m) + createCommit :: [CommitOid m] -> TreeOid m + -> Signature -> Signature -> Text -> Maybe Text -> m (Commit m) + createTag :: CommitOid m -> Signature -> Text -> Text -> m (Tag m) + + -- Pushing and pulling + pushCommit :: (MonadTrans t, MonadGit m, MonadGit (t m), + Repository m, Repository (t m)) + => CommitOid m -> Maybe Text -> Text -> t m (CommitOid (t m)) + + -- Pack files + buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] + -> m FilePath + buildPackFile _ _ = + failure (BackendError "Backend does not support building pack files") + + buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) + buildPackIndex _ _ = + failure (BackendError "Backend does not support building pack indexes") + + writePackFile :: FilePath -> m () + writePackFile _ = + failure (BackendError "Backend does not support writing pack files") + + -- Git remotes + remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () + +data RepositoryOptions = RepositoryOptions + { repoPath :: !FilePath + , repoIsBare :: !Bool + , repoAutoCreate :: !Bool + } + +instance Default RepositoryOptions where + def = RepositoryOptions "" True True + +data RepositoryFactory t m c = RepositoryFactory + { openRepository :: RepositoryOptions -> m c + , runRepository :: forall a. c -> t m a -> m a + , closeRepository :: c -> m () + , getRepository :: t m c + , defaultOptions :: !RepositoryOptions + , startupBackend :: m () + , shutdownBackend :: m () + } + +{- $oids -} +class (Eq o, Ord o, Show o) => IsOid o where + renderOid :: o -> Text + renderOid = renderObjOid . Tagged + renderObjOid :: Tagged a o -> Text + renderObjOid = renderOid . untag + +type BlobOid m = Tagged (Blob m) (Oid m) +type TreeOid m = Tagged (Tree m) (Oid m) +type CommitOid m = Tagged (Commit m) (Oid m) +type TagOid m = Tagged (Tag m) (Oid m) + +data ObjectOid m = BlobObjOid !(BlobOid m) + | TreeObjOid !(TreeOid m) + | CommitObjOid !(CommitOid m) + | TagObjOid !(TagOid m) + +parseObjOid :: Repository m => forall o. Text -> m (Tagged o (Oid m)) +parseObjOid sha = Tagged <$> parseOid sha + +copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n) +copyOid = parseOid . renderOid + +newtype SHA = SHA B.ByteString deriving (Eq, Ord, Read) + +shaToText :: SHA -> Text +shaToText (SHA bs) = T.decodeUtf8 (B16.encode bs) + +textToSha :: Monad m => Text -> m SHA +textToSha t = + case B16.decode $ T.encodeUtf8 t of + (bs, "") -> return (SHA bs) + _ -> fail "Invalid base16 encoding" + +instance IsOid SHA where + renderOid = shaToText + +instance Show SHA where + show = T.unpack . shaToText + +instance Bin.Binary SHA where + put (SHA t) = Bin.put t + get = SHA <$> Bin.get + +instance Hashable SHA where + hashWithSalt salt (SHA bs) = hashWithSalt salt bs + +{- $blobs -} +data Blob m = Blob { blobOid :: !(BlobOid m) + , blobContents :: !(BlobContents m) } + +type ByteSource m = Producer m ByteString + +data BlobContents m = BlobString !ByteString + | BlobStream !(ByteSource m) + | BlobSizedStream !(ByteSource m) !Int + +data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob | UnknownBlob + deriving (Show, Eq, Enum) + +instance Eq (BlobContents m) where + BlobString str1 == BlobString str2 = str1 == str2 + _ == _ = False + +{- $trees -} +data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m) + , blobEntryKind :: !BlobKind } + | TreeEntry { treeEntryOid :: !(TreeOid m) } + | CommitEntry { commitEntryOid :: !(CommitOid m) } + +instance Repository m => Show (TreeEntry m) where + show (BlobEntry oid _) = " TreeEntry m -> Oid m +treeEntryToOid (BlobEntry boid _) = untag boid +treeEntryToOid (TreeEntry toid) = untag toid +treeEntryToOid (CommitEntry coid) = untag coid + +data TreeBuilder m = TreeBuilder + { mtbBaseTreeOid :: Maybe (TreeOid m) + , mtbPendingUpdates :: HashMap Text (TreeBuilder m) + , mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m) + , mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid 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) + } + +data ModifiedBuilder m = ModifiedBuilder (TreeBuilder m) + | BuilderUnchanged (TreeBuilder m) + +instance Monoid (ModifiedBuilder m) where + mempty = BuilderUnchanged (error "ModifiedBuilder is a semigroup") + BuilderUnchanged _ `mappend` BuilderUnchanged b2 = BuilderUnchanged b2 + ModifiedBuilder b1 `mappend` BuilderUnchanged _ = ModifiedBuilder b1 + BuilderUnchanged _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2 + ModifiedBuilder _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2 + +fromBuilderMod :: ModifiedBuilder m -> TreeBuilder m +fromBuilderMod (BuilderUnchanged tb) = tb +fromBuilderMod (ModifiedBuilder tb) = tb + +{- $commits -} +data Commit m = Commit + { commitOid :: !(CommitOid m) + , commitParents :: ![CommitOid m] + , commitTree :: !(TreeOid m) + , commitAuthor :: !Signature + , commitCommitter :: !Signature + , commitLog :: !Text + , commitEncoding :: !Text + } + +lookupCommitParents :: Repository m => Commit m -> m [Commit m] +lookupCommitParents = mapM lookupCommit . commitParents + +data Signature = Signature + { signatureName :: !Text + , signatureEmail :: !Text + , signatureWhen :: !ZonedTime + } deriving Show + +instance Default Signature where + def = Signature + { signatureName = T.empty + , signatureEmail = T.empty + , signatureWhen = ZonedTime + { zonedTimeToLocalTime = LocalTime + { localDay = ModifiedJulianDay 0 + , localTimeOfDay = TimeOfDay 0 0 0 + } + , zonedTimeZone = utc + } + } + +{- $tags -} +data Tag m = Tag + { tagOid :: !(TagOid m) + , tagCommit :: !(CommitOid m) + } + +{- $objects -} +data Object m = BlobObj !(Blob m) + | TreeObj !(Tree m) + | CommitObj !(Commit m) + | TagObj !(Tag m) + +objectOid :: Repository m => Object m -> Oid m +objectOid (BlobObj obj) = untag (blobOid obj) +objectOid (TreeObj obj) = untag (treeOid obj) +objectOid (CommitObj obj) = untag (commitOid obj) +objectOid (TagObj obj) = untag (tagOid obj) + +loadObject :: Repository m => ObjectOid m -> m (Object m) +loadObject (BlobObjOid oid) = BlobObj <$> lookupBlob oid +loadObject (TreeObjOid oid) = TreeObj <$> lookupTree oid +loadObject (CommitObjOid oid) = CommitObj <$> lookupCommit oid +loadObject (TagObjOid oid) = TagObj <$> lookupTag oid + +objectToObjOid :: Repository m => Object m -> ObjectOid m +objectToObjOid (BlobObj obj) = BlobObjOid (blobOid obj) +objectToObjOid (TreeObj obj) = TreeObjOid (treeOid obj) +objectToObjOid (CommitObj obj) = CommitObjOid (commitOid obj) +objectToObjOid (TagObj obj) = TagObjOid (tagOid obj) + +untagObjOid :: Repository m => ObjectOid m -> Oid m +untagObjOid (BlobObjOid oid) = untag oid +untagObjOid (TreeObjOid oid) = untag oid +untagObjOid (CommitObjOid oid) = untag oid +untagObjOid (TagObjOid oid) = untag oid + +{- $references -} +data RefTarget m = RefObj !(CommitOid m) | RefSymbolic !Text + +commitRefTarget :: Commit m -> RefTarget m +commitRefTarget = RefObj . commitOid + +{- $merges -} +data ModificationKind = Unchanged | Modified | Added | Deleted | TypeChanged + deriving (Eq, Ord, Enum, Show, Read) + +data MergeStatus + = NoConflict + | BothModified + | LeftModifiedRightDeleted + | LeftDeletedRightModified + | BothAdded + | LeftModifiedRightTypeChanged + | LeftTypeChangedRightModified + | LeftDeletedRightTypeChanged + | LeftTypeChangedRightDeleted + | BothTypeChanged + deriving (Eq, Ord, Enum, Show, Read) + +mergeStatus :: ModificationKind -> ModificationKind -> MergeStatus +mergeStatus Unchanged Unchanged = NoConflict +mergeStatus Unchanged Modified = NoConflict +mergeStatus Unchanged Added = undefined +mergeStatus Unchanged Deleted = NoConflict +mergeStatus Unchanged TypeChanged = NoConflict + +mergeStatus Modified Unchanged = NoConflict +mergeStatus Modified Modified = BothModified +mergeStatus Modified Added = undefined +mergeStatus Modified Deleted = LeftModifiedRightDeleted +mergeStatus Modified TypeChanged = LeftModifiedRightTypeChanged + +mergeStatus Added Unchanged = undefined +mergeStatus Added Modified = undefined +mergeStatus Added Added = BothAdded +mergeStatus Added Deleted = undefined +mergeStatus Added TypeChanged = undefined + +mergeStatus Deleted Unchanged = NoConflict +mergeStatus Deleted Modified = LeftDeletedRightModified +mergeStatus Deleted Added = undefined +mergeStatus Deleted Deleted = NoConflict +mergeStatus Deleted TypeChanged = LeftDeletedRightTypeChanged + +mergeStatus TypeChanged Unchanged = NoConflict +mergeStatus TypeChanged Modified = LeftTypeChangedRightModified +mergeStatus TypeChanged Added = undefined +mergeStatus TypeChanged Deleted = LeftTypeChangedRightDeleted +mergeStatus TypeChanged TypeChanged = BothTypeChanged + +data MergeResult m + = MergeSuccess + { mergeCommit :: CommitOid m + } + | MergeConflicted + { mergeCommit :: CommitOid m + , mergeHeadLeft :: CommitOid m + , mergeHeadRight :: CommitOid m + , mergeConflicts :: Map Text (ModificationKind, ModificationKind) + } + +copyMergeResult :: (Repository m, MonadGit m, Repository n, MonadGit n) + => MergeResult m -> n (MergeResult n) +copyMergeResult (MergeSuccess mc) = + MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc)) +copyMergeResult (MergeConflicted hl hr mc cs) = + MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl)) + <*> (Tagged <$> parseOid (renderObjOid hr)) + <*> (Tagged <$> parseOid (renderObjOid mc)) + <*> pure cs + +instance Repository m => Show (MergeResult m) where + show (MergeSuccess mc) = "MergeSuccess (" ++ show mc ++ ")" + show (MergeConflicted mc hl hr cs) = + "MergeResult" + ++ "\n { mergeCommit = " ++ show mc + ++ "\n , mergeHeadLeft = " ++ show hl + ++ "\n , mergeHeadRight = " ++ show hr + ++ "\n , mergeConflicts = " ++ show cs + ++ "\n }" + +{- $exceptions -} +-- | There is a separate 'GitException' for each possible failure when +-- interacting with the Git repository. +data GitException = BackendError Text + | GitError Text + | RepositoryNotExist + | RepositoryInvalid + | RepositoryCannotAccess Text + | BlobCreateFailed + | BlobEmptyCreateFailed + | BlobEncodingUnknown Text + | BlobLookupFailed + | PushNotFastForward Text + | TranslationException Text + | TreeCreateFailed Text + | TreeBuilderCreateFailed + | TreeBuilderInsertFailed Text + | TreeBuilderRemoveFailed Text + | TreeBuilderWriteFailed Text + | TreeLookupFailed + | TreeCannotTraverseBlob + | TreeCannotTraverseCommit + | TreeEntryLookupFailed Text + | TreeUpdateFailed + | TreeWalkFailed + | TreeEmptyCreateFailed + | CommitCreateFailed + | CommitLookupFailed Text + | ReferenceCreateFailed + | ReferenceDeleteFailed Text + | RefCannotCreateFromPartialOid + | ReferenceListingFailed + | ReferenceLookupFailed Text + | ObjectLookupFailed Text Int + | ObjectRefRequiresFullOid + | OidCopyFailed + | OidParseFailed Text + | QuotaHardLimitExceeded Int Int + deriving (Eq, Show, Typeable) + +-- jww (2013-02-11): Create a BackendException data constructor of forall +-- e. Exception e => BackendException e, so that each can throw a derived +-- exception. +instance Exc.Exception GitException diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -1,5 +1,5 @@ Name: gitlib -Version: 1.4.0 +Version: 2.0.0.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT @@ -23,17 +23,17 @@ type: git location: git://github.com/fpco/gitlib.git -Test-suite doctests - Default-language: Haskell98 - Type: exitcode-stdio-1.0 - Main-is: Doctest.hs - Hs-source-dirs: test - Build-depends: - base - , directory >= 1.0 - , doctest >= 0.8 - , doctest-prop >= 0.1 - , filepath >= 1.3 +-- 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 @@ -58,4 +58,22 @@ , unordered-containers >= 0.2.3.0 exposed-modules: Git + Git.Types + Git.Blob + Git.Tree + Git.Tree.Builder + Git.Tree.Builder.Pure + Git.Commit + Git.Commit.Push + Git.Object + Git.Reference + Git.Repository Git.Tutorial + default-extensions: + ConstraintKinds + DeriveDataTypeable + FlexibleContexts + OverloadedStrings + RankNTypes + TypeFamilies + ViewPatterns diff --git a/test/Doctest.hs b/test/Doctest.hs deleted file mode 100644 --- a/test/Doctest.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main where - -import Test.DocTest -import System.Directory -import System.FilePath -import Control.Applicative -import Control.Monad -import Data.List - -main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : sources - -getSources :: IO [FilePath] -getSources = - filter (\n -> ".hs" `isSuffixOf` n && n /= "./Setup.hs") <$> go "." - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go (filter (not . (== "./test")) dirs) - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) - <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c