yogsototh/stackage
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
stackage/patching/patches/gitlib-s3-3.0.2.patch
Michael Snoyman 44be73a24b New gitlib patches
2014-04-06 09:02:57 +03:00

276 lines
11 KiB
Diff
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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 ->
Reference in a new issue View git blame Copy permalink