gitlib-s3 3.0.2 → 3.1.0
raw patch · 4 files changed
+61/−67 lines, 4 filesdep +conduit-combinatorsdep +exceptionsdep −failuredep ~awsdep ~conduitdep ~monad-loggersetup-changed
Dependencies added: conduit-combinators, exceptions
Dependencies removed: failure
Dependency ranges changed: aws, conduit, monad-logger, resourcet
Files
- Git/S3.hs +44/−54
- Setup.hs +2/−0
- gitlib-s3.cabal +11/−8
- test/Smoke.hs +4/−5
Git/S3.hs view
@@ -28,30 +28,28 @@ import Aws.Core import qualified Aws.S3 as Aws import Bindings.Libgit2+import Conduit import Control.Applicative import Control.Concurrent.STM hiding (orElse)-import Control.Exception.Lifted-import Control.Lens ((??), under, reversed)+import Control.Exception (assert)+import Control.Lens ((??), under, reversed, has, _Left) import Control.Monad-import Control.Monad.IO.Class+import Control.Monad.Catch import Control.Monad.Logger hiding (LogLevel)-import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource+import Control.Monad.Trans.Resource.Internal import Control.Retry import Data.Aeson as A-import Data.Attempt import Data.Bifunctor import Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as BU-import Data.Conduit-import Data.Conduit.Binary hiding (mapM_, drop)-import qualified Data.Conduit.List as CList+import Data.Conduit.Internal hiding (yield) import Data.Default import Data.Foldable (for_) import Data.HashMap.Strict (HashMap)@@ -141,8 +139,8 @@ } deriving (Eq, Show, Generic) -type MonadS3 m = (Failure Git.GitException m,- MonadIO m, MonadBaseControl IO m, MonadLogger m)+type MonadS3 m = (MonadExcept m, MonadIO m, MonadBaseControl IO m,+ MonadLogger m) data BackendCallbacks = BackendCallbacks { checkQuota :: ObjectLength -> IO (Maybe QuotaStatus)@@ -478,7 +476,7 @@ -> ResourceT m (Response (ResponseMetadata a) a) awsRetry cfg svcfg mgr r = transResourceT liftIO $- retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r+ retrying def (has _Left . responseResult) $ aws cfg svcfg mgr r listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text] listBucketS3 dets = do@@ -541,10 +539,10 @@ bucket (T.pack path) range `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of- Just (Left e) -> throwIO $ Git.BackendError e+ Just (Left e) -> throwM $ Git.BackendError e Just (Right r) -> transResourceT liftIO $- fst <$> (sourceLbs r $$+ Data.Conduit.Binary.take 0)+ return $ ResumableSource (sourceLazy r) (return ()) _ -> do lgDebug $ "Aws.getObject: " ++ show filepath ++ " " ++ show range res <- awsRetry (configuration dets) (s3configuration dets)@@ -562,13 +560,13 @@ let bucket = bucketName dets path = T.append (objectPrefix dets) filepath- lbs <- BL.fromChunks <$> (src $$ CList.consume)+ lbs <- src $$ sinkLazy cbResult <- wrapPutObject (putObject (callbacks dets)) bucket path (ObjectLength (BL.length lbs)) lbs `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of- Just (Left e) -> throwIO $ Git.BackendError e+ Just (Left e) -> throwM $ Git.BackendError e Just (Right r) -> return r _ -> do lgDebug $ "Aws.putObject: " ++ show filepath@@ -598,7 +596,7 @@ withCString oidStr $ \cstr -> withForeignPtr ptr $ \ptr' -> do r <- c'git_oid_fromstr ptr' cstr- when (r < 0) $ throwIO Git.OidCopyFailed+ when (r < 0) $ throwM Git.OidCopyFailed return ptr instance A.ToJSON RefTarget where@@ -637,8 +635,7 @@ ++ show (Prelude.length shas) ++ " objects" return shas -catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> Text -> FilePath -> m [SHA]+catalogPackFile :: MonadS3 m => OdbS3Details -> Text -> FilePath -> m [SHA] catalogPackFile dets packSha idxPath = do -- Load the pack file, and iterate over the objects within it to determine -- what it contains. When 'withPackFile' returns, the pack file will be@@ -710,7 +707,7 @@ lgDebug $ "cacheUpdateEntry " ++ show (shaToText sha) ++ " " ++ show ce liftIO $ atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce -cacheLoadObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+cacheLoadObject :: MonadS3 m => OdbS3Details -> SHA -> CacheEntry -> Bool -> m (Maybe ObjectInfo) cacheLoadObject dets sha ce metadataOnly = do@@ -767,7 +764,7 @@ ++ show sha m <- liftIO $ atomically $ readTVar (knownPackFiles dets) mresult <- case M.lookup idxPath m of- Nothing -> throwIO $ Git.BackendError $+ Nothing -> throwM $ Git.BackendError $ "Accessing unknown pack file " <> T.pack idxPath Just (ptr, _) -> lgReadFromPack ptr sha metadataOnly for mresult $ \(typ, len, bytes) ->@@ -834,7 +831,7 @@ regObj = wrapRegisterObject (registerObject (callbacks dets)) sha - err = throwIO (Git.BackendError $+ err = throwM (Git.BackendError $ "callbackRecordInfo called with " <> T.pack (show ce)) remoteObjectExists :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m Bool@@ -853,7 +850,7 @@ liftIO $ removeFile path blocks <- do result <- getFileS3 dets (takeFileName path) Nothing- transResourceT liftIO $ result $$+- CList.consume+ transResourceT liftIO $ result $$+- sinkList lgDebug $ "remoteReadFile: downloaded " ++ show path case blocks of [] -> return Nothing@@ -915,7 +912,7 @@ minfo <- lift $ remoteReadFile dets path for minfo $ \ObjectInfo {..} -> case infoData of- Nothing -> throw $ Git.BackendError $+ Nothing -> throwM $ Git.BackendError $ "Failed to download data for " <> T.pack path Just xs -> liftIO $ BL.writeFile path xs @@ -934,7 +931,7 @@ (fromIntegral quotaStatusAmount) (fromIntegral quotaStatusLimit) wrapSetException (setException (callbacks dets)) e- throw e+ throwM e where go = do lgDebug $ "remoteWriteFile " ++ show path@@ -942,7 +939,7 @@ fromIntegral (getObjectType typ)) :: (Int64,Int64)) payload = BL.append hdr bytes- putFileS3 dets path (sourceLbs payload)+ putFileS3 dets path (sourceLazy payload) remoteLoadObject :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m (Maybe ObjectInfo)@@ -951,14 +948,13 @@ path = tmpDir </> fromSha sha remoteReadFile dets path -remoteStoreObject :: MonadS3 m- => OdbS3Details -> SHA -> ObjectInfo -> ResourceT m ()+remoteStoreObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> ResourceT m () remoteStoreObject dets sha (ObjectInfo _ typ _ (Just bytes)) = remoteWriteFile dets (shaToText sha) typ bytes remoteStoreObject _ _ _ =- throw (Git.BackendError "remoteStoreObject was not given any data")+ throwM $ Git.BackendError "remoteStoreObject was not given any data" -remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+remoteCatalogContents :: MonadS3 m => OdbS3Details -> ResourceT m () remoteCatalogContents dets = do lgDebug "remoteCatalogContents"@@ -982,8 +978,7 @@ | otherwise -> return () -accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry)+accessObject :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry) accessObject dets sha checkRemote = do mentry <- cacheLookupEntry dets sha case mentry of@@ -1032,20 +1027,17 @@ -- cache and with the callback interface. This is to avoid recataloging -- in the future. -objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> SHA -> Bool -> m CacheEntry+objectExists :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m CacheEntry objectExists dets sha checkRemote = do mce <- accessObject dets sha checkRemote return $ fromMaybe DoesNotExist mce -readObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo)+readObject :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo) readObject dets sha metadataOnly = do ce <- objectExists dets sha True cacheLoadObject dets sha ce metadataOnly `orElse` return Nothing -readObjectMetadata :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> SHA -> m (Maybe ObjectInfo)+readObjectMetadata :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe ObjectInfo) readObjectMetadata dets sha = readObject dets sha True writeObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> m ()@@ -1054,8 +1046,7 @@ callbackRegisterObject dets sha info cacheStoreObject dets sha info -writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> BL.ByteString -> m ()+writePackFile :: MonadS3 m => OdbS3Details -> BL.ByteString -> m () writePackFile dets bytes = do let dir = tempDirectory dets len = BL.length bytes@@ -1073,7 +1064,7 @@ shas <- catalogPackFile dets packSha idxPath callbackRegisterPackFile dets packSha shas -readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+readCallback :: MonadS3 m => Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype@@ -1104,7 +1095,7 @@ BU.unsafeUseAsCString chunk $ copyBytes p ?? len return $ p `plusPtr` len -readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+readPrefixCallback :: MonadS3 m => Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize@@ -1140,7 +1131,7 @@ go dets sha False | otherwise = return Nothing -readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+readHeaderCallback :: MonadS3 m => Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend@@ -1158,7 +1149,7 @@ poke len_p (toLength len) poke type_p (toType typ) -writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+writeCallback :: MonadS3 m => Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr ()@@ -1184,7 +1175,7 @@ (ObjectInfo (fromLength len) (fromType obj_type) Nothing (Just (BL.fromChunks [bytes]))) -existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+existsCallback :: MonadS3 m => Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt existsCallback be oid confirmNotExists = do (dets, sha) <- liftIO $ unpackDetails be oid@@ -1194,18 +1185,17 @@ return $ if ce == DoesNotExist then 0 else 1) (return c'GIT_ERROR) -refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)- => Ptr C'git_odb_backend -> m CInt+refreshCallback :: MonadS3 m => Ptr C'git_odb_backend -> m CInt refreshCallback _ = return c'GIT_OK -- do nothing -foreachCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+foreachCallback :: MonadS3 m => Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr () -> m CInt foreachCallback _be _callback _payload = return c'GIT_ERROR -- fallback to standard method -writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+writePackCallback :: MonadS3 m => Ptr (Ptr C'git_odb_writepack) -> Ptr C'git_odb_backend -> C'git_transfer_progress_callback@@ -1248,7 +1238,7 @@ foreign import ccall "&freeCallback" freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback -packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+packAddCallback :: MonadS3 m => Ptr C'git_odb_writepack -> Ptr () -> CSize@@ -1267,7 +1257,7 @@ (castPtr dataPtr) (fromIntegral len) writePackFile dets (BL.fromChunks [bytes]) -packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+packCommitCallback :: MonadS3 m => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress -> m CInt packCommitCallback _wp _progress =@@ -1380,7 +1370,7 @@ liftIO $ writeIORef result res readIORef result -odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+odbS3Backend :: MonadS3 m => Aws.S3Configuration NormalQuery -> Configuration -> Manager@@ -1475,7 +1465,7 @@ -- | Given a repository object obtained from Libgit2, add an S3 backend to it, -- making it the primary store for objects associated with that repository.-addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+addS3Backend :: MonadS3 m => LgRepo -> Text -- ^ bucket -> Text -- ^ prefix@@ -1505,7 +1495,7 @@ void $ liftIO $ odbBackendAdd repo odbS3 100 return repo -s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+s3Factory :: MonadS3 m => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo s3Factory bucket accessKey secretKey dir callbacks = lgFactory@@ -1528,7 +1518,7 @@ dir callbacks -s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+s3FactoryLogger :: MonadS3 m => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger
Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
gitlib-s3.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-s3-Version: 3.0.2+Version: 3.1.0 Synopsis: Gitlib repository backend for storing Git objects in Amazon S3 Description: Gitlib repository backend for storing Git objects in Amazon S3. License-file: LICENSE@@ -27,16 +27,17 @@ , gitlib-test >= 3.0.0 , gitlib-libgit2 >= 3.0.0 , hlibgit2 >= 0.18.0.11- , aws >= 0.7.5+ , aws >= 0.9+ , exceptions >= 0.6 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3 , data-default >= 0.5.1 , directory >= 1.1.0.2- , failure >= 0.2.0.1+ , exceptions >= 0.6 , filepath >= 1.3.0 , monad-logger >= 0.3.1.1- , resourcet >= 0.4.6+ , resourcet >= 1.1.0 , temporary >= 1.1.2.4 , text >= 0.11.2 , transformers >= 0.2.2@@ -53,20 +54,22 @@ , hlibgit2 >= 0.18.0.11 , aeson >= 0.6.1.0 , attempt >= 0.4.0- , aws >= 0.7.5+ , aws >= 0.9 , bifunctors >= 3.2.0.1 , binary >= 0.5.1.0 , bytestring >= 0.9.2.1- , conduit >= 0.5.5+ , conduit >= 1.1.0+ , conduit-combinators >= 0.2.4 , data-default >= 0.5.1 , directory >= 1.1.0.2+ , exceptions >= 0.6 , filepath >= 1.3.0 , http-conduit >= 2.0 , lens >= 3.8 , lifted-base >= 0.2.0.2 , monad-control- , monad-logger >= 0.3.1.1- , resourcet >= 0.4.6+ , monad-logger >= 0.3.6.1+ , resourcet >= 1.1.2.2 , retry >= 0.2.0.0 , split >= 0.2 , stm >= 2.4
test/Smoke.hs view
@@ -11,7 +11,7 @@ import Aws import Control.Applicative-import Control.Failure+import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Reader@@ -29,10 +29,9 @@ import Test.Hspec.HUnit () import Test.Hspec.Runner -s3Factory- :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m,- MonadUnsafeIO m, MonadThrow m)- => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo+s3Factory :: (MonadThrow m, MonadCatch m, MonadMask m,+ MonadIO m, MonadBaseControl IO m)+ => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo s3Factory = Lg.lgFactory { Git.runRepository = \ctxt m -> runNoLoggingT $ Lg.runLgRepository ctxt (s3back >> m) }