diff --git a/Git/Blob.hs b/Git/Blob.hs --- a/Git/Blob.hs +++ b/Git/Blob.hs @@ -12,7 +12,6 @@ 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 @@ -33,7 +32,8 @@ blobToByteString :: Repository m => Blob m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents -treeBlobEntries :: Repository m => Tree m -> m [(Text, BlobOid m, BlobKind)] +treeBlobEntries :: Repository m + => Tree m -> m [(TreeFilePath, BlobOid m, BlobKind)] treeBlobEntries tree = do entries <- listTreeEntries tree return $ Prelude.foldr f [] entries diff --git a/Git/Commit.hs b/Git/Commit.hs --- a/Git/Commit.hs +++ b/Git/Commit.hs @@ -1,5 +1,6 @@ module Git.Commit where +import Control.Failure import Control.Monad import Control.Monad.Trans.Class import Data.Conduit @@ -9,6 +10,7 @@ import qualified Data.HashSet as HashSet import Data.List import Data.Maybe +import Data.Monoid import Data.Tagged import Data.Text (Text) import Git.Tree @@ -17,7 +19,7 @@ commitTreeEntry :: Repository m => Commit m - -> Text + -> TreeFilePath -> m (Maybe (TreeEntry m)) commitTreeEntry c path = flip treeEntry path =<< lookupTree (commitTree c) @@ -26,7 +28,7 @@ copyCommit :: (Repository m, Repository (t m), MonadTrans t) => CommitOid m - -> Maybe Text + -> Maybe RefName -> HashSet Text -> t m (CommitOid (t m), HashSet Text) copyCommit cr mref needed = do @@ -39,6 +41,10 @@ let parents = commitParents commit (parentRefs,needed') <- foldM copyParent ([],needed) parents (tr,needed'') <- copyTree (commitTree commit) needed' + unless (renderObjOid (commitTree commit) == renderObjOid tr) $ + failure $ BackendError $ "Error copying tree: " + <> renderObjOid (commitTree commit) + <> " /= " <> renderObjOid tr commit' <- createCommit (reverse parentRefs) tr (commitAuthor commit) @@ -54,6 +60,9 @@ where copyParent (prefs,needed') cref = do (cref2,needed'') <- copyCommit cref Nothing needed' + unless (renderObjOid cref == renderObjOid cref2) $ + failure $ BackendError $ "Error copying commit: " + <> renderObjOid cref <> " /= " <> renderObjOid cref2 let x = cref2 `seq` (cref2:prefs) return $ x `seq` needed'' `seq` (x,needed'') diff --git a/Git/Commit/Push.hs b/Git/Commit/Push.hs --- a/Git/Commit/Push.hs +++ b/Git/Commit/Push.hs @@ -9,9 +9,10 @@ import Data.Maybe import Data.Monoid import Data.Text (Text) +import Data.Traversable (for) import Git.Commit -import Git.Reference import Git.Object +import Git.Reference import Git.Types import Prelude hiding (FilePath) @@ -22,25 +23,20 @@ pushCommit :: (Repository m, Repository (t m), MonadTrans t) => CommitOid m -> Text -> t m (CommitOid (t m)) pushCommit 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 + commits <- mapM copyCommitOid =<< lift (listCommits Nothing coid) + mrref <- resolveReference remoteRefName + mrref' <- for mrref $ \rref -> + if rref `elem` commits + then lift $ copyCommitOid rref + else failure $ PushNotFastForward + $ "SHA " <> renderObjOid rref + <> " not found in remote" + objs <- lift $ listAllObjects mrref' coid + let shas = HashSet.fromList $ map (renderOid . untagObjOid) objs + (cref,_) <- copyCommit coid Nothing shas + unless (renderObjOid coid == renderObjOid cref) $ + failure $ BackendError $ "Error copying commit: " + <> renderObjOid coid <> " /= " <> renderObjOid cref + -- jww (2013-04-18): This is something the user must decide to do + -- updateReference_ remoteRefName (RefObj cref) + return cref diff --git a/Git/Reference.hs b/Git/Reference.hs --- a/Git/Reference.hs +++ b/Git/Reference.hs @@ -1,10 +1,9 @@ module Git.Reference where import Control.Applicative -import Data.Text import Git.Types -resolveReference :: Repository m => Text -> m (Maybe (CommitOid m)) +resolveReference :: Repository m => RefName -> m (Maybe (CommitOid m)) resolveReference name = do mref <- lookupReference name maybe (return Nothing) referenceToOid mref @@ -13,7 +12,7 @@ referenceToOid (RefObj oid) = return $ Just oid referenceToOid (RefSymbolic name) = resolveReference name -resolveReferenceTree :: Repository m => Text -> m (Maybe (Tree m)) +resolveReferenceTree :: Repository m => RefName -> m (Maybe (Tree m)) resolveReferenceTree refName = do c <- resolveReference refName case c of diff --git a/Git/Repository.hs b/Git/Repository.hs --- a/Git/Repository.hs +++ b/Git/Repository.hs @@ -5,11 +5,8 @@ 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.Directory import System.Mem withNewRepository :: (Repository (t m), MonadGit (t m), @@ -18,8 +15,8 @@ -> FilePath -> t m a -> m a withNewRepository factory path action = do liftIO $ do - exists <- isDirectory path - when exists $ removeTree path + exists <- doesDirectoryExist path + when exists $ removeDirectoryRecursive path -- we want exceptions to leave the repo behind a <- withRepository' factory (defaultOptions factory) @@ -29,8 +26,8 @@ } action liftIO $ do - exists <- isDirectory path - when exists $ removeTree path + exists <- doesDirectoryExist path + when exists $ removeDirectoryRecursive path return a @@ -46,9 +43,8 @@ } action where recover = liftIO $ do - exists <- isDirectory path - when exists $ removeTree path - + exists <- doesDirectoryExist path + when exists $ removeDirectoryRecursive path withBackendDo :: (MonadIO m, MonadBaseControl IO m) => RepositoryFactory t m a -> m b -> m b diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -1,16 +1,16 @@ module Git.Tree where +import Control.Failure import Control.Monad import Control.Monad.Trans.Class -import Data.Function import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet +import Data.Monoid import Data.Tagged import Data.Text (Text) import Git.Blob import Git.Tree.Builder import Git.Types -import Prelude hiding (FilePath) copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) => TreeEntry m @@ -18,6 +18,9 @@ -> t m (TreeEntry (t m), HashSet Text) copyTreeEntry (BlobEntry oid kind) needed = do (b,needed') <- copyBlob oid needed + unless (renderObjOid oid == renderObjOid b) $ + failure $ BackendError $ "Error copying blob: " + <> renderObjOid oid <> " /= " <> renderObjOid b return (BlobEntry b kind, needed') copyTreeEntry (CommitEntry oid) needed = do coid <- parseOid (renderObjOid oid) @@ -46,7 +49,7 @@ where doCopyTreeEntry :: (Repository m, Repository (t m), MonadTrans t) => HashSet Text - -> (Text, TreeEntry m) + -> (TreeFilePath, TreeEntry m) -> TreeT (t m) (HashSet Text) doCopyTreeEntry set (_, TreeEntry {}) = return set doCopyTreeEntry set (fp, ent) = do diff --git a/Git/Tree/Builder.hs b/Git/Tree/Builder.hs --- a/Git/Tree/Builder.hs +++ b/Git/Tree/Builder.hs @@ -31,15 +31,14 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State -import Data.Function +import qualified Data.ByteString as B +import Data.Char 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 Data.Word import Git.Types -import Prelude hiding (FilePath) +import System.Posix.ByteString.FilePath data ModifyTreeResult m = TreeEntryNotFound | TreeEntryDeleted @@ -76,7 +75,7 @@ (<|>) = mplus instance (MonadPlus m) => MonadPlus (TreeT m) where - mzero = TreeT $ mzero + mzero = TreeT mzero m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n instance (MonadFix m) => MonadFix (TreeT m) where @@ -95,7 +94,7 @@ putBuilder = TreeT . put data BuilderAction = GetEntry | PutEntry | DropEntry - deriving (Eq, Show) + deriving (Eq, Show) emptyTreeId :: Text emptyTreeId = "4b825dc642cb6eb9a060e54bf8d69288fbee4904" @@ -106,13 +105,13 @@ -- 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)) + => TreeBuilder m + -> TreeFilePath + -> BuilderAction + -> (Maybe (TreeEntry m) -> ModifyTreeResult m) + -> m (TreeBuilder m, Maybe (TreeEntry m)) queryTreeBuilder builder path kind f = do - (mtb, mtresult) <- walk (BuilderUnchanged builder) (splitPath path) + (mtb, mtresult) <- walk (BuilderUnchanged builder) (splitDirectories path) return (fromBuilderMod mtb, fromModifyTreeResult mtresult) where walk _ [] = error "queryTreeBuilder called without a path" @@ -185,6 +184,21 @@ { mtbPendingUpdates = HashMap.insert name sbm (mtbPendingUpdates tb) } + pathSeparator :: Word8 + pathSeparator = fromIntegral $ ord '/' + + isPathSeparator :: Word8 -> Bool + isPathSeparator = (== pathSeparator) + + splitDirectories :: RawFilePath -> [RawFilePath] + splitDirectories x + | B.null x = [] + | isPathSeparator (B.head x) = let (root,rest) = B.splitAt 1 x + in root : splitter rest + | otherwise = splitter x + where + splitter = filter (not . B.null) . B.split pathSeparator + -- | Write out a tree to its repository. If it has already been written, -- nothing will happen. writeTreeBuilder :: Repository m @@ -222,36 +236,36 @@ Just tref -> mtbPutEntry tb tb k (TreeEntry tref) return $ bm <> bm' -getEntry :: Repository m => Text -> TreeT m (Maybe (TreeEntry m)) +getEntry :: Repository m => TreeFilePath -> TreeT m (Maybe (TreeEntry m)) getEntry path = do tb <- getBuilder snd <$> lift (queryTreeBuilder tb path GetEntry (toModifyTreeResult TreeEntryPersistent)) -putEntry :: Repository m => Text -> TreeEntry m -> TreeT m () +putEntry :: Repository m => TreeFilePath -> TreeEntry m -> TreeT m () putEntry path ent = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry (const (TreeEntryMutated ent))) putBuilder tb' -dropEntry :: Repository m => Text -> TreeT m () +dropEntry :: Repository m => TreeFilePath -> TreeT m () dropEntry path = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry (const TreeEntryDeleted)) putBuilder tb' -putBlob' :: Repository m => Text -> BlobOid m -> BlobKind -> TreeT m () +putBlob' :: Repository m => TreeFilePath -> BlobOid m -> BlobKind -> TreeT m () putBlob' path b kind = putEntry path (BlobEntry b kind) -putBlob :: Repository m => Text -> BlobOid m -> TreeT m () +putBlob :: Repository m => TreeFilePath -> BlobOid m -> TreeT m () putBlob path b = putBlob' path b PlainBlob -putTree :: Repository m => Text -> TreeOid m -> TreeT m () +putTree :: Repository m => TreeFilePath -> TreeOid m -> TreeT m () putTree path t = putEntry path (TreeEntry t) -putCommit :: Repository m => Text -> CommitOid m -> TreeT m () +putCommit :: Repository m => TreeFilePath -> CommitOid m -> TreeT m () putCommit path c = putEntry path (CommitEntry c) doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeOid m) @@ -289,6 +303,3 @@ 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 --- a/Git/Tree/Builder/Pure.hs +++ b/Git/Tree/Builder/Pure.hs @@ -5,12 +5,11 @@ 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) +type EntryHashMap m = HashMap TreeFilePath (TreeEntry m) -- | Create a new, empty tree. -- @@ -34,7 +33,7 @@ makePureBuilder :: Repository m => Maybe (TreeOid m) - -> HashMap Text (TreeBuilder m) + -> HashMap TreeFilePath (TreeBuilder m) -> (Maybe (Tree m) -> m (TreeBuilder m)) -> EntryHashMap m -> (EntryHashMap m -> m (TreeOid m)) diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -3,7 +3,6 @@ import Control.Applicative import qualified Control.Exception.Lifted as Exc import Control.Failure -import Control.Monad import Control.Monad.IO.Class import qualified Data.Binary as Bin import Data.ByteString (ByteString) @@ -11,12 +10,9 @@ 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) @@ -24,8 +20,7 @@ import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable -import Filesystem.Path.CurrentOS hiding (null, concat) -import Prelude hiding (FilePath) +import System.Posix.ByteString.FilePath data RepositoryFacts = RepositoryFacts { hasSymbolicReferences :: !Bool @@ -34,6 +29,12 @@ type MonadGit m = (Failure GitException m, Applicative m, MonadIO m, MonadBaseControl IO m) +type RefName = Text +type CommitAuthor = Text +type CommitEmail = Text +type CommitMessage = Text +type TreeFilePath = RawFilePath + -- | 'Repository' is the central point of contact between user code and Git -- data objects. Every object must belong to some repository. class (Applicative m, Monad m, Failure GitException m, IsOid (Oid m)) @@ -47,11 +48,11 @@ 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] + createReference :: RefName -> RefTarget m -> m () + lookupReference :: RefName -> m (Maybe (RefTarget m)) + updateReference :: RefName -> RefTarget m -> m () + deleteReference :: RefName -> m () + listReferences :: m [RefName] -- Object lookup lookupCommit :: CommitOid m -> m (Commit m) @@ -69,15 +70,16 @@ 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)] + treeEntry :: Tree m -> TreeFilePath -> m (Maybe (TreeEntry m)) + listTreeEntries :: Tree m -> m [(TreeFilePath, 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) + -> Signature -> Signature -> CommitMessage -> Maybe RefName + -> m (Commit m) + createTag :: CommitOid m -> Signature -> CommitMessage -> Text -> m (Tag m) -- -- Pack files -- buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] @@ -197,14 +199,15 @@ data TreeBuilder m = TreeBuilder { mtbBaseTreeOid :: Maybe (TreeOid m) - , mtbPendingUpdates :: HashMap Text (TreeBuilder m) + , mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder m) , mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m) , mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid m) - , mtbLookupEntry :: Text -> m (Maybe (TreeEntry m)) + , mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry m)) , mtbEntryCount :: m Int - , mtbPutEntry :: TreeBuilder m -> Text -> TreeEntry m + , mtbPutEntry :: TreeBuilder m -> TreeFilePath -> TreeEntry m -> m (ModifiedBuilder m) - , mtbDropEntry :: TreeBuilder m -> Text -> m (ModifiedBuilder m) + , mtbDropEntry :: TreeBuilder m -> TreeFilePath + -> m (ModifiedBuilder m) } data ModifiedBuilder m = ModifiedBuilder (TreeBuilder m) @@ -228,7 +231,7 @@ , commitTree :: !(TreeOid m) , commitAuthor :: !Signature , commitCommitter :: !Signature - , commitLog :: !Text + , commitLog :: !CommitMessage , commitEncoding :: !Text } @@ -236,8 +239,8 @@ lookupCommitParents = mapM lookupCommit . commitParents data Signature = Signature - { signatureName :: !Text - , signatureEmail :: !Text + { signatureName :: !CommitAuthor + , signatureEmail :: !CommitEmail , signatureWhen :: !ZonedTime } deriving Show @@ -291,7 +294,7 @@ untagObjOid (TagObjOid oid) = untag oid {- $references -} -data RefTarget m = RefObj !(CommitOid m) | RefSymbolic !Text +data RefTarget m = RefObj !(CommitOid m) | RefSymbolic !RefName instance Repository m => Show (RefTarget m) where show (RefObj coid) = "RefObj#" ++ T.unpack (renderObjOid coid) @@ -356,7 +359,8 @@ { mergeCommit :: CommitOid m , mergeHeadLeft :: CommitOid m , mergeHeadRight :: CommitOid m - , mergeConflicts :: Map Text (ModificationKind, ModificationKind) + , mergeConflicts :: + Map TreeFilePath (ModificationKind, ModificationKind) } copyMergeResult :: (Repository m, MonadGit m, Repository n, MonadGit n) @@ -395,23 +399,23 @@ | TranslationException Text | TreeCreateFailed Text | TreeBuilderCreateFailed - | TreeBuilderInsertFailed Text - | TreeBuilderRemoveFailed Text + | TreeBuilderInsertFailed TreeFilePath + | TreeBuilderRemoveFailed TreeFilePath | TreeBuilderWriteFailed Text | TreeLookupFailed | TreeCannotTraverseBlob | TreeCannotTraverseCommit - | TreeEntryLookupFailed Text + | TreeEntryLookupFailed TreeFilePath | TreeUpdateFailed | TreeWalkFailed | TreeEmptyCreateFailed | CommitCreateFailed | CommitLookupFailed Text - | ReferenceCreateFailed Text - | ReferenceDeleteFailed Text + | ReferenceCreateFailed RefName + | ReferenceDeleteFailed RefName | RefCannotCreateFromPartialOid | ReferenceListingFailed - | ReferenceLookupFailed Text + | ReferenceLookupFailed RefName | ObjectLookupFailed Text Int | ObjectRefRequiresFullOid | OidCopyFailed diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -1,5 +1,5 @@ Name: gitlib -Version: 2.0.1.1 +Version: 2.1.0.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT @@ -46,15 +46,15 @@ , conduit >= 1.0.0 , containers >= 0.4.2.1 , data-default >= 0.5.0 + , directory >= 1.1.0.2 , failure >= 0.2.0.1 , hashable >= 1.1.2.5 , lifted-base >= 0.2 - , system-fileio >= 0.3.11 - , system-filepath >= 0.4.7 , tagged >= 0.2.3.1 , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0 + , unix >= 2.5 , unordered-containers >= 0.2.3.0 exposed-modules: Git