diff -ru orig/Git/S3.hs new/Git/S3.hs --- orig/Git/S3.hs 2014-04-06 09:02:47.247789820 +0300 +++ new/Git/S3.hs 2014-04-06 09:02:47.000000000 +0300 @@ -42,7 +42,6 @@ import Control.Monad.Trans.Resource import Control.Retry import Data.Aeson as A -import Data.Attempt import Data.Bifunctor import Data.Binary as Bin import Data.ByteString (ByteString) @@ -141,7 +140,7 @@ } deriving (Eq, Show, Generic) -type MonadS3 m = (Failure Git.GitException m, +type MonadS3 m = (MonadThrow m, MonadIO m, MonadBaseControl IO m, MonadLogger m) data BackendCallbacks = BackendCallbacks @@ -478,7 +477,10 @@ -> ResourceT m (Response (ResponseMetadata a) a) awsRetry cfg svcfg mgr r = transResourceT liftIO $ - retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r + retrying def (isLeft . responseResult) $ aws cfg svcfg mgr r + where + isLeft Left{} = True + isLeft Right{} = False listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text] listBucketS3 dets = do @@ -622,7 +624,7 @@ sha <- oidToSha oid modifyIORef mshas (sha:) return c'GIT_OK - checkResult r "lgForEachObject failed" + either throwM return $ checkResult r "lgForEachObject failed" -- Update the known objects map with the fact that we've got a local cache -- of the pack file. @@ -637,7 +639,7 @@ ++ show (Prelude.length shas) ++ " objects" return shas -catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +catalogPackFile :: (MonadS3 m, MonadThrow m) => OdbS3Details -> Text -> FilePath -> m [SHA] catalogPackFile dets packSha idxPath = do -- Load the pack file, and iterate over the objects within it to determine @@ -710,7 +712,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, MonadThrow m) => OdbS3Details -> SHA -> CacheEntry -> Bool -> m (Maybe ObjectInfo) cacheLoadObject dets sha ce metadataOnly = do @@ -958,7 +960,7 @@ remoteStoreObject _ _ _ = throw (Git.BackendError "remoteStoreObject was not given any data") -remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +remoteCatalogContents :: (MonadS3 m, MonadThrow m) => OdbS3Details -> ResourceT m () remoteCatalogContents dets = do lgDebug "remoteCatalogContents" @@ -982,7 +984,7 @@ | otherwise -> return () -accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +accessObject :: (MonadS3 m, MonadThrow m) => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry) accessObject dets sha checkRemote = do mentry <- cacheLookupEntry dets sha @@ -1032,19 +1034,19 @@ -- cache and with the callback interface. This is to avoid recataloging -- in the future. -objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +objectExists :: (MonadS3 m, MonadThrow 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) +readObject :: (MonadS3 m, MonadThrow 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) +readObjectMetadata :: (MonadS3 m, MonadThrow m) => OdbS3Details -> SHA -> m (Maybe ObjectInfo) readObjectMetadata dets sha = readObject dets sha True @@ -1054,7 +1056,7 @@ callbackRegisterObject dets sha info cacheStoreObject dets sha info -writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +writePackFile :: (MonadS3 m, MonadThrow m) => OdbS3Details -> BL.ByteString -> m () writePackFile dets bytes = do let dir = tempDirectory dets @@ -1073,7 +1075,7 @@ shas <- catalogPackFile dets packSha idxPath callbackRegisterPackFile dets packSha shas -readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +readCallback :: (MonadS3 m, MonadThrow m) => Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype @@ -1104,7 +1106,7 @@ BU.unsafeUseAsCString chunk $ copyBytes p ?? len return $ p `plusPtr` len -readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +readPrefixCallback :: (MonadS3 m, MonadThrow m) => Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize @@ -1140,7 +1142,7 @@ go dets sha False | otherwise = return Nothing -readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +readHeaderCallback :: (MonadS3 m, MonadThrow m) => Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend @@ -1158,7 +1160,7 @@ poke len_p (toLength len) poke type_p (toType typ) -writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +writeCallback :: (MonadS3 m, MonadThrow m) => Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr () @@ -1184,7 +1186,7 @@ (ObjectInfo (fromLength len) (fromType obj_type) Nothing (Just (BL.fromChunks [bytes]))) -existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +existsCallback :: (MonadS3 m, MonadThrow 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 +1196,18 @@ return $ if ce == DoesNotExist then 0 else 1) (return c'GIT_ERROR) -refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +refreshCallback :: (MonadS3 m, MonadThrow 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, MonadThrow 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, MonadThrow m) => Ptr (Ptr C'git_odb_writepack) -> Ptr C'git_odb_backend -> C'git_transfer_progress_callback @@ -1248,7 +1250,7 @@ foreign import ccall "&freeCallback" freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback -packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +packAddCallback :: (MonadS3 m, MonadThrow m) => Ptr C'git_odb_writepack -> Ptr () -> CSize @@ -1267,7 +1269,7 @@ (castPtr dataPtr) (fromIntegral len) writePackFile dets (BL.fromChunks [bytes]) -packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +packCommitCallback :: (MonadS3 m, MonadThrow m) => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress -> m CInt packCommitCallback _wp _progress = @@ -1380,7 +1382,7 @@ liftIO $ writeIORef result res readIORef result -odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +odbS3Backend :: (MonadS3 m, MonadThrow m) => Aws.S3Configuration NormalQuery -> Configuration -> Manager @@ -1475,7 +1477,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, MonadThrow m) => LgRepo -> Text -- ^ bucket -> Text -- ^ prefix @@ -1505,7 +1507,7 @@ void $ liftIO $ odbBackendAdd repo odbS3 100 return repo -s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +s3Factory :: (MonadS3 m, MonadThrow m) => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo s3Factory bucket accessKey secretKey dir callbacks = lgFactory @@ -1528,7 +1530,7 @@ dir callbacks -s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) +s3FactoryLogger :: (MonadS3 m, MonadThrow m) => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger diff -ru orig/gitlib-s3.cabal new/gitlib-s3.cabal --- orig/gitlib-s3.cabal 2014-04-06 09:02:47.247789820 +0300 +++ new/gitlib-s3.cabal 2014-04-06 09:02:47.000000000 +0300 @@ -33,7 +33,6 @@ , hspec-expectations >= 0.3 , data-default >= 0.5.1 , directory >= 1.1.0.2 - , failure >= 0.2.0.1 , filepath >= 1.3.0 , monad-logger >= 0.3.1.1 , resourcet >= 0.4.6 @@ -52,12 +51,12 @@ , ghc-prim , hlibgit2 >= 0.18.0.11 , aeson >= 0.6.1.0 - , attempt >= 0.4.0 , aws >= 0.7.5 , bifunctors >= 3.2.0.1 , binary >= 0.5.1.0 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 + , conduit-extra , data-default >= 0.5.1 , directory >= 1.1.0.2 , filepath >= 1.3.0 diff -ru orig/test/Smoke.hs new/test/Smoke.hs --- orig/test/Smoke.hs 2014-04-06 09:02:47.247789820 +0300 +++ new/test/Smoke.hs 2014-04-06 09:02:47.000000000 +0300 @@ -11,7 +11,6 @@ import Aws import Control.Applicative -import Control.Failure import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Reader @@ -30,8 +29,7 @@ import Test.Hspec.Runner s3Factory - :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m, - MonadUnsafeIO m, MonadThrow m) + :: (MonadThrow m, MonadIO m, MonadBaseControl IO m) => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo s3Factory = Lg.lgFactory { Git.runRepository = \ctxt m ->