gitlib 3.0.2 → 3.1.0
raw patch · 12 files changed
+152/−76 lines, 12 filesdep +conduit-combinatorsdep +exceptionsdep +lifted-asyncdep −failuredep ~conduitdep ~resourcet
Dependencies added: conduit-combinators, exceptions, lifted-async, system-filepath
Dependencies removed: failure
Dependency ranges changed: conduit, resourcet
Files
- Git/Blob.hs +11/−15
- Git/Commit.hs +5/−8
- Git/Commit/Push.hs +8/−8
- Git/Object.hs +8/−10
- Git/Reference.hs +2/−3
- Git/Repository.hs +1/−1
- Git/Tree.hs +3/−6
- Git/Tree/Builder.hs +4/−6
- Git/Tree/Working.hs +80/−0
- Git/Types.hs +16/−7
- Git/Working.hs +5/−8
- gitlib.cabal +9/−4
Git/Blob.hs view
@@ -1,20 +1,16 @@ module Git.Blob where +import Conduit import Control.Applicative import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Resource import Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Conduit-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Binary as CB 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 Filesystem.Path.CurrentOS import Git.Types createBlobUtf8 :: MonadGit r m => Text -> m (BlobOid r)@@ -34,9 +30,9 @@ blobContentsToByteString (BlobStringLazy bs) = return $ B.concat (BL.toChunks bs) blobContentsToByteString (BlobStream bs) =- B.concat <$> (bs $$ CL.consume)+ B.concat . BL.toChunks <$> (bs $$ sinkLazy) blobContentsToByteString (BlobSizedStream bs _) =- B.concat <$> (bs $$ CL.consume)+ B.concat . BL.toChunks <$> (bs $$ sinkLazy) blobToByteString :: MonadGit r m => Blob r m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents@@ -45,22 +41,22 @@ => BlobContents m -> m BL.ByteString blobContentsToLazyByteString (BlobString bs) = return $ BL.fromChunks [bs] blobContentsToLazyByteString (BlobStringLazy bs) = return bs-blobContentsToLazyByteString (BlobStream bs) = bs $$ CB.sinkLbs-blobContentsToLazyByteString (BlobSizedStream bs _) = bs $$ CB.sinkLbs+blobContentsToLazyByteString (BlobStream bs) = bs $$ sinkLazy+blobContentsToLazyByteString (BlobSizedStream bs _) = bs $$ sinkLazy blobToLazyByteString :: MonadGit r m => Blob r m -> m BL.ByteString blobToLazyByteString (Blob _ contents) = blobContentsToLazyByteString contents writeBlob :: (MonadGit r m, MonadIO m, MonadResource m)- => FilePath -> BlobContents m -> m ()+ => Prelude.FilePath -> BlobContents m -> m () writeBlob path (BlobString bs) = liftIO $ B.writeFile path bs-writeBlob path (BlobStringLazy bs) = CB.sourceLbs bs $$ CB.sinkFile path-writeBlob path (BlobStream str) = str $$ CB.sinkFile path-writeBlob path (BlobSizedStream str _) = str $$ CB.sinkFile path+writeBlob path (BlobStringLazy bs) = sourceLazy bs $$ sinkFile (decodeString path)+writeBlob path (BlobStream str) = str $$ sinkFile (decodeString path)+writeBlob path (BlobSizedStream str _) = str $$ sinkFile (decodeString path) treeBlobEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, BlobOid r, BlobKind)]-treeBlobEntries tree = sourceTreeBlobEntries tree $$ CL.consume+treeBlobEntries tree = sourceTreeBlobEntries tree $$ sinkList sourceTreeBlobEntries :: MonadGit r m
Git/Commit.hs view
@@ -1,10 +1,7 @@ module Git.Commit where -import Control.Failure+import Conduit import Control.Monad-import Control.Monad.Trans.Class-import Data.Conduit-import qualified Data.Conduit.List as CL import Data.Function import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet@@ -41,7 +38,7 @@ (parentRefs,needed') <- foldM copyParent ([],needed) parents (tr,needed'') <- copyTree (commitTree commit) needed' unless (renderObjOid (commitTree commit) == renderObjOid tr) $- failure $ BackendError $ "Error copying tree: "+ throwM $ BackendError $ "Error copying tree: " <> renderObjOid (commitTree commit) <> " /= " <> renderObjOid tr @@ -60,7 +57,7 @@ copyParent (prefs,needed') cref = do (cref2,needed'') <- copyCommit cref Nothing needed' unless (renderObjOid cref == renderObjOid cref2) $- failure $ BackendError $ "Error copying commit: "+ throwM $ BackendError $ "Error copying commit: " <> renderObjOid cref <> " /= " <> renderObjOid cref2 let x = cref2 `seq` (cref2:prefs) return $ x `seq` needed'' `seq` (x,needed'')@@ -71,8 +68,8 @@ -> m [CommitOid r] -- ^ All the objects in between listCommits mhave need = sourceObjects mhave need False- $= CL.mapM (\(CommitObjOid c) -> return c)- $$ CL.consume+ $= mapMC (\(CommitObjOid c) -> return c)+ $$ sinkList traverseCommits :: MonadGit r m => (CommitOid r -> m a) -> CommitOid r -> m [a] traverseCommits f need = mapM f =<< listCommits Nothing need
Git/Commit/Push.hs view
@@ -1,8 +1,8 @@ module Git.Commit.Push where import Control.Applicative-import Control.Failure import Control.Monad+import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Control@@ -33,14 +33,14 @@ mrref' <- for mrref $ \rref -> if rref `elem` commits then lift $ copyCommitOid rref- else failure $ PushNotFastForward- $ "SHA " <> renderObjOid rref- <> " not found in remote"+ else throwM $ 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: "+ throwM $ 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)@@ -79,6 +79,6 @@ mref <- fmap renderOid <$> resolveReference refName unless (maybe False (renderObjOid coid ==) mref) $- failure (BackendError $- "Could not resolve destination reference '"- <> refName <> "'in project")+ throwM (BackendError $+ "Could not resolve destination reference '"+ <> refName <> "'in project")
Git/Object.hs view
@@ -1,13 +1,11 @@ module Git.Object where -import Control.Monad-import Control.Monad.Trans.Class-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Function-import Data.Maybe-import Git.Types-import Prelude hiding (FilePath)+import Conduit+import Control.Monad+import Data.Function+import Data.Maybe+import Git.Types+import Prelude hiding (FilePath) listObjects :: MonadGit r m => Maybe (CommitOid r) -- ^ A commit we may already have@@ -15,7 +13,7 @@ -> Bool -- ^ Include commit trees also? -> m [ObjectOid r] -- ^ All the objects in between listObjects mhave need alsoTrees =- sourceObjects mhave need alsoTrees $$ CL.consume+ sourceObjects mhave need alsoTrees $$ sinkList traverseObjects :: MonadGit r m => (ObjectOid r -> m a) -> CommitOid r -> m [a] traverseObjects f need = mapM f =<< listObjects Nothing need False@@ -41,4 +39,4 @@ listAllObjects :: MonadGit r m => Maybe (CommitOid r) -> CommitOid r -> m [ObjectOid r] listAllObjects mhave need =- sourceObjects mhave need True $= expandTreeObjects $$ CL.consume+ sourceObjects mhave need True $= expandTreeObjects $$ sinkList
Git/Reference.hs view
@@ -1,11 +1,10 @@ module Git.Reference where +import Conduit import Git.Types-import Data.Conduit-import Data.Conduit.List as CL listReferences :: MonadGit r m => m [RefName]-listReferences = sourceReferences $$ CL.consume+listReferences = sourceReferences $$ sinkList resolveReference :: MonadGit r m => RefName -> m (Maybe (Oid r)) resolveReference name = do
Git/Repository.hs view
@@ -3,7 +3,7 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class-import Data.Conduit+import Control.Monad.Trans.Control import Git.Types import System.Directory
Git/Tree.hs view
@@ -1,10 +1,7 @@ module Git.Tree where -import Control.Failure+import Conduit import Control.Monad-import Control.Monad.Trans.Class-import Data.Conduit-import qualified Data.Conduit.List as CL import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Monoid@@ -15,14 +12,14 @@ import Git.Types listTreeEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, TreeEntry r)]-listTreeEntries tree = sourceTreeEntries tree $$ CL.consume+listTreeEntries tree = sourceTreeEntries tree $$ sinkList copyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry (BlobEntry oid kind) needed = do (b,needed') <- copyBlob oid needed unless (renderObjOid oid == renderObjOid b) $- failure $ BackendError $ "Error copying blob: "+ throwM $ BackendError $ "Error copying blob: " <> renderObjOid oid <> " /= " <> renderObjOid b return (BlobEntry b kind, needed') copyTreeEntry (CommitEntry oid) needed = do
Git/Tree/Builder.hs view
@@ -25,11 +25,11 @@ ) where import Control.Applicative-import Control.Failure import Control.Monad+import Control.Monad.Catch import Control.Monad.Fix-import Control.Monad.Logger import Control.Monad.IO.Class+import Control.Monad.Logger import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Data.ByteString as B@@ -57,8 +57,6 @@ toModifyTreeResult _ Nothing = TreeEntryNotFound toModifyTreeResult f (Just x) = f x -newtype TreeT r m a = TreeT { runTreeT :: StateT (TreeBuilder r m) m a }- instance Functor m => Functor (TreeT r m) where fmap f (TreeT t) = TreeT (fmap f t) @@ -143,9 +141,9 @@ update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound) update _ _ _ (Right (Just BlobEntry {})) =- failure TreeCannotTraverseBlob+ throwM TreeCannotTraverseBlob update _ _ _ (Right (Just CommitEntry {})) =- failure TreeCannotTraverseCommit+ throwM TreeCannotTraverseCommit update bm name names arg = do sbm <- case arg of
+ Git/Tree/Working.hs view
@@ -0,0 +1,80 @@+module Git.Tree.Working where++import Control.Applicative+import Control.Concurrent.Async.Lifted+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control+import qualified Data.ByteString as B (readFile)+import qualified Data.ByteString.Char8 as B8+import Data.Foldable (foldl')+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import Data.Tagged+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Git hiding (Options)+import Prelude hiding (log)+import System.FilePath.Posix+import System.Posix.Files++data FileEntry m = FileEntry+ { fileModTime :: UTCTime+ , fileBlobOid :: BlobOid m+ , fileBlobKind :: BlobKind+ , fileChecksum :: BlobOid m+ }++type FileTree m = HashMap TreeFilePath (FileEntry m)++readFileTree :: (MonadBaseControl IO m, MonadIO m, MonadGit r m)+ => RefName+ -> FilePath+ -> Bool+ -> m (FileTree r)+readFileTree ref wdir getHash = do+ h <- resolveReference ref+ case h of+ Nothing -> pure Map.empty+ Just h' -> do+ tr <- lookupTree . commitTree =<< lookupCommit (Tagged h')+ readFileTree' tr wdir getHash++readFileTree' :: (MonadBaseControl IO m, MonadIO m, MonadGit r m)+ => Tree r -> FilePath -> Bool+ -> m (FileTree r)+readFileTree' tr wdir getHash = do+ blobs <- treeBlobEntries tr+ stats <- mapConcurrently go blobs+ return $ foldl' (\m (!fp,!fent) -> maybe m (flip (Map.insert fp) m) fent)+ Map.empty stats+ where+ go (!fp,!oid,!kind) = do+ fent <- readModTime wdir getHash (B8.unpack fp) oid kind+ fent `seq` return (fp,fent)++readModTime :: (MonadIO m, MonadGit r m)+ => FilePath+ -> Bool+ -> FilePath+ -> BlobOid r+ -> BlobKind+ -> m (Maybe (FileEntry r))+readModTime wdir getHash fp oid kind = do+ let path = wdir </> fp+ -- debug' $ pack $ "Checking file: " ++ path+ estatus <- liftIO $ try $ getSymbolicLinkStatus path+ case (estatus :: Either SomeException FileStatus) of+ Right status | isRegularFile status ->+ Just <$> (FileEntry+ <$> pure (posixSecondsToUTCTime+ (realToFrac (modificationTime status)))+ <*> pure oid+ <*> pure kind+ <*> if getHash+ then hashContents . BlobString+ =<< liftIO (B.readFile path)+ else return oid)+ _ -> return Nothing
Git/Types.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 707+{-# LANGUAGE AllowAmbiguousTypes #-}+#endif+ module Git.Types where +import Conduit import Control.Applicative import qualified Control.Exception.Lifted as Exc-import Control.Failure import Control.Monad-import Control.Monad.Trans.Class+import Control.Monad.Trans.State import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL-import Data.Conduit-import qualified Data.Conduit.List as CL import Data.HashMap.Strict (HashMap) import Data.Hashable import Data.Map (Map)@@ -35,7 +38,7 @@ -- | '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,+class (Applicative m, Monad m, MonadThrow m, IsOid (Oid r), Show (Oid r), Eq (Oid r), Ord (Oid r)) => MonadGit r m | m -> r where type Oid r :: *@@ -69,6 +72,9 @@ lookupBlob :: BlobOid r -> m (Blob r m) lookupTag :: TagOid r -> m (Tag r) + readIndex :: TreeT r m ()+ writeIndex :: TreeT r m ()+ -- Working with trees newTreeBuilder :: Maybe (Tree r) -> m (TreeBuilder r m) @@ -169,7 +175,7 @@ , blobContents :: !(BlobContents m) } -type ByteSource m = Producer m ByteString+type ByteSource m = Source m ByteString data BlobContents m = BlobString !ByteString | BlobStringLazy !BL.ByteString@@ -184,6 +190,8 @@ _ == _ = False {- $trees -}+newtype TreeT r m a = TreeT { runTreeT :: StateT (TreeBuilder r m) m a }+ data TreeEntry r = BlobEntry { blobEntryOid :: !(BlobOid r) , blobEntryKind :: !BlobKind } | TreeEntry { treeEntryOid :: !(TreeOid r) }@@ -245,7 +253,7 @@ forM_ (commitParents commit) $ yield <=< lift . lookupCommit lookupCommitParents :: MonadGit r m => Commit r -> m [Commit r]-lookupCommitParents commit = sourceCommitParents commit $$ CL.consume+lookupCommitParents commit = sourceCommitParents commit $$ sinkList data Signature = Signature { signatureName :: !CommitAuthor@@ -413,6 +421,7 @@ | IndexCreateFailed Text | PathEncodingError Text | PushNotFastForward Text+ | TagLookupFailed Text | TranslationException Text | TreeCreateFailed Text | TreeBuilderCreateFailed
Git/Working.hs view
@@ -2,14 +2,11 @@ module Git.Working where +import Conduit import Control.Applicative-import Control.Failure-import Control.Monad.IO.Class-import Control.Monad.Trans.Resource-import Data.Conduit-import Data.Conduit.List as CL-import Data.Text as T+import Control.Monad.Catch import Data.Semigroup+import Data.Text as T import Git.Blob import Git.Types import System.Directory@@ -26,7 +23,7 @@ -> Bool -> m () checkoutFiles destPath tree decode cloneSubmodules =- sourceTreeEntries tree $$ CL.mapM_ $ \(path, entry) ->+ sourceTreeEntries tree $$ mapM_C $ \(path, entry) -> case (destPath </>) <$> decode path of Left e -> decodeError path e Right fullPath -> do@@ -39,7 +36,7 @@ | cloneSubmodules -> cloneSubmodule oid fullPath | otherwise -> liftIO $ createDirectory fullPath where- decodeError path e = failure $ PathEncodingError $+ decodeError path e = throwM $ PathEncodingError $ "Could not decode path " <> T.pack (show path) <> ":" <> T.pack e checkoutBlob oid kind fullPath = do
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 3.0.2+Version: 3.1.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT@@ -42,18 +42,21 @@ base >= 3 && < 5 , base16-bytestring >= 0.1.1.5 , bytestring >= 0.9.2.1- , conduit >= 1.0.0+ , conduit >= 1.1.0+ , conduit-combinators >= 0.2.4 , containers >= 0.4.2.1 , directory >= 1.1.0.2- , failure >= 0.2.0.1+ , exceptions >= 0.5 , filepath >= 1.3.0.0 , hashable >= 1.1.2.5+ , lifted-async >= 0.1.1 , lifted-base >= 0.2 , monad-control >= 0.3.2.1 , monad-logger >= 0.3.4.1 , mtl >= 2.1.2- , resourcet >= 0.4.8+ , resourcet >= 1.1.0 , semigroups >= 0.11+ , system-filepath >= 0.4.10 , tagged >= 0.2.3.1 , text >= 0.11.2 , time >= 1.4@@ -73,11 +76,13 @@ Git.Tree Git.Tree.Builder Git.Tree.Builder.Pure+ Git.Tree.Working Git.Tutorial Git.Types Git.Utils Git.Working default-extensions: + BangPatterns ConstraintKinds DeriveDataTypeable FlexibleContexts