gitlib 2.0.1.1 → 2.1.0.0

raw patch · 10 files changed

+120/−103 lines, 10 filesdep +directorydep +unixdep −system-fileiodep −system-filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, unix

Dependencies removed: system-fileio, system-filepath

API changes (from Hackage documentation)

Files

• Git/Blob.hs +2/−2
• Git/Commit.hs +11/−2
• Git/Commit/Push.hs +19/−23
• Git/Reference.hs +2/−3
• Git/Repository.hs +7/−11
• Git/Tree.hs +6/−3
• Git/Tree/Builder.hs +34/−23
• Git/Tree/Builder/Pure.hs +2/−3
• Git/Types.hs +34/−30
• gitlib.cabal +3/−3

@@ -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

@@ -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'') 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 "/"

@@ -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))

@@ -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

@@ -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