git.iko.soy/stackage
on bf52f1d help sign in
stackage/patching/patches/gitlib-s3-3.0.2.patch
276 lines 11 kB history raw
1diff -ru orig/Git/S3.hs new/Git/S3.hs
2--- orig/Git/S3.hs 2014-04-06 09:02:47.247789820 +0300
3+++ new/Git/S3.hs 2014-04-06 09:02:47.000000000 +0300
4@@ -42,7 +42,6 @@
5 import Control.Monad.Trans.Resource
6 import Control.Retry
7 import Data.Aeson as A
8-import Data.Attempt
9 import Data.Bifunctor
10 import Data.Binary as Bin
11 import Data.ByteString (ByteString)
12@@ -141,7 +140,7 @@
13 }
14 deriving (Eq, Show, Generic)
16-type MonadS3 m = (Failure Git.GitException m,
17+type MonadS3 m = (MonadThrow m,
18 MonadIO m, MonadBaseControl IO m, MonadLogger m)
20 data BackendCallbacks = BackendCallbacks
21@@ -478,7 +477,10 @@
22 -> ResourceT m (Response (ResponseMetadata a) a)
23 awsRetry cfg svcfg mgr r =
24 transResourceT liftIO $
25- retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r
26+ retrying def (isLeft . responseResult) $ aws cfg svcfg mgr r
27+ where
28+ isLeft Left{} = True
29+ isLeft Right{} = False
31 listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text]
32 listBucketS3 dets = do
33@@ -622,7 +624,7 @@
34 sha <- oidToSha oid
35 modifyIORef mshas (sha:)
36 return c'GIT_OK
37- checkResult r "lgForEachObject failed"
38+ either throwM return $ checkResult r "lgForEachObject failed"
40 -- Update the known objects map with the fact that we've got a local cache
41 -- of the pack file.
42@@ -637,7 +639,7 @@
43 ++ show (Prelude.length shas) ++ " objects"
44 return shas
46-catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
47+catalogPackFile :: (MonadS3 m, MonadThrow m)
48 => OdbS3Details -> Text -> FilePath -> m [SHA]
49 catalogPackFile dets packSha idxPath = do
50 -- Load the pack file, and iterate over the objects within it to determine
51@@ -710,7 +712,7 @@
52 lgDebug $ "cacheUpdateEntry " ++ show (shaToText sha) ++ " " ++ show ce
53 liftIO $ atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce
55-cacheLoadObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
56+cacheLoadObject :: (MonadS3 m, MonadThrow m)
57 => OdbS3Details -> SHA -> CacheEntry -> Bool
58 -> m (Maybe ObjectInfo)
59 cacheLoadObject dets sha ce metadataOnly = do
60@@ -958,7 +960,7 @@
61 remoteStoreObject _ _ _ =
62 throw (Git.BackendError "remoteStoreObject was not given any data")
64-remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
65+remoteCatalogContents :: (MonadS3 m, MonadThrow m)
66 => OdbS3Details -> ResourceT m ()
67 remoteCatalogContents dets = do
68 lgDebug "remoteCatalogContents"
69@@ -982,7 +984,7 @@
71 | otherwise -> return ()
73-accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
74+accessObject :: (MonadS3 m, MonadThrow m)
75 => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry)
76 accessObject dets sha checkRemote = do
77 mentry <- cacheLookupEntry dets sha
78@@ -1032,19 +1034,19 @@
79 -- cache and with the callback interface. This is to avoid recataloging
80 -- in the future.
82-objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
83+objectExists :: (MonadS3 m, MonadThrow m)
84 => OdbS3Details -> SHA -> Bool -> m CacheEntry
85 objectExists dets sha checkRemote = do
86 mce <- accessObject dets sha checkRemote
87 return $ fromMaybe DoesNotExist mce
89-readObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
90+readObject :: (MonadS3 m, MonadThrow m)
91 => OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo)
92 readObject dets sha metadataOnly = do
93 ce <- objectExists dets sha True
94 cacheLoadObject dets sha ce metadataOnly `orElse` return Nothing
96-readObjectMetadata :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
97+readObjectMetadata :: (MonadS3 m, MonadThrow m)
98 => OdbS3Details -> SHA -> m (Maybe ObjectInfo)
99 readObjectMetadata dets sha = readObject dets sha True
101@@ -1054,7 +1056,7 @@
102 callbackRegisterObject dets sha info
103 cacheStoreObject dets sha info
105-writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
106+writePackFile :: (MonadS3 m, MonadThrow m)
107 => OdbS3Details -> BL.ByteString -> m ()
108 writePackFile dets bytes = do
109 let dir = tempDirectory dets
110@@ -1073,7 +1075,7 @@
111 shas <- catalogPackFile dets packSha idxPath
112 callbackRegisterPackFile dets packSha shas
114-readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
115+readCallback :: (MonadS3 m, MonadThrow m)
116 => Ptr (Ptr ())
117 -> Ptr CSize
118 -> Ptr C'git_otype
119@@ -1104,7 +1106,7 @@
120 BU.unsafeUseAsCString chunk $ copyBytes p ?? len
121 return $ p `plusPtr` len
123-readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
124+readPrefixCallback :: (MonadS3 m, MonadThrow m)
125 => Ptr C'git_oid
126 -> Ptr (Ptr ())
127 -> Ptr CSize
128@@ -1140,7 +1142,7 @@
129 go dets sha False
130 | otherwise = return Nothing
132-readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
133+readHeaderCallback :: (MonadS3 m, MonadThrow m)
134 => Ptr CSize
135 -> Ptr C'git_otype
136 -> Ptr C'git_odb_backend
137@@ -1158,7 +1160,7 @@
138 poke len_p (toLength len)
139 poke type_p (toType typ)
141-writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
142+writeCallback :: (MonadS3 m, MonadThrow m)
143 => Ptr C'git_oid
144 -> Ptr C'git_odb_backend
145 -> Ptr ()
146@@ -1184,7 +1186,7 @@
147 (ObjectInfo (fromLength len) (fromType obj_type)
148 Nothing (Just (BL.fromChunks [bytes])))
150-existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
151+existsCallback :: (MonadS3 m, MonadThrow m)
152 => Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt
153 existsCallback be oid confirmNotExists = do
154 (dets, sha) <- liftIO $ unpackDetails be oid
155@@ -1194,18 +1196,18 @@
156 return $ if ce == DoesNotExist then 0 else 1)
157 (return c'GIT_ERROR)
159-refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
160+refreshCallback :: (MonadS3 m, MonadThrow m)
161 => Ptr C'git_odb_backend -> m CInt
162 refreshCallback _ =
163 return c'GIT_OK -- do nothing
165-foreachCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
166+foreachCallback :: (MonadS3 m, MonadThrow m)
167 => Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr ()
168 -> m CInt
169 foreachCallback _be _callback _payload =
170 return c'GIT_ERROR -- fallback to standard method
172-writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
173+writePackCallback :: (MonadS3 m, MonadThrow m)
174 => Ptr (Ptr C'git_odb_writepack)
175 -> Ptr C'git_odb_backend
176 -> C'git_transfer_progress_callback
177@@ -1248,7 +1250,7 @@
178 foreign import ccall "&freeCallback"
179 freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback
181-packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
182+packAddCallback :: (MonadS3 m, MonadThrow m)
183 => Ptr C'git_odb_writepack
184 -> Ptr ()
185 -> CSize
186@@ -1267,7 +1269,7 @@
187 (castPtr dataPtr) (fromIntegral len)
188 writePackFile dets (BL.fromChunks [bytes])
190-packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
191+packCommitCallback :: (MonadS3 m, MonadThrow m)
192 => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress
193 -> m CInt
194 packCommitCallback _wp _progress =
195@@ -1380,7 +1382,7 @@
196 liftIO $ writeIORef result res
197 readIORef result
199-odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
200+odbS3Backend :: (MonadS3 m, MonadThrow m)
201 => Aws.S3Configuration NormalQuery
202 -> Configuration
203 -> Manager
204@@ -1475,7 +1477,7 @@
206 -- | Given a repository object obtained from Libgit2, add an S3 backend to it,
207 -- making it the primary store for objects associated with that repository.
208-addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
209+addS3Backend :: (MonadS3 m, MonadThrow m)
210 => LgRepo
211 -> Text -- ^ bucket
212 -> Text -- ^ prefix
213@@ -1505,7 +1507,7 @@
214 void $ liftIO $ odbBackendAdd repo odbS3 100
215 return repo
217-s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
218+s3Factory :: (MonadS3 m, MonadThrow m)
219 => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
220 -> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo
221 s3Factory bucket accessKey secretKey dir callbacks = lgFactory
222@@ -1528,7 +1530,7 @@
223 dir
224 callbacks
226-s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
227+s3FactoryLogger :: (MonadS3 m, MonadThrow m)
228 => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
229 -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo
230 s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger
231diff -ru orig/gitlib-s3.cabal new/gitlib-s3.cabal
232--- orig/gitlib-s3.cabal 2014-04-06 09:02:47.247789820 +0300
233+++ new/gitlib-s3.cabal 2014-04-06 09:02:47.000000000 +0300
234@@ -33,7 +33,6 @@
235 , hspec-expectations >= 0.3
236 , data-default >= 0.5.1
237 , directory >= 1.1.0.2
238- , failure >= 0.2.0.1
239 , filepath >= 1.3.0
240 , monad-logger >= 0.3.1.1
241 , resourcet >= 0.4.6
242@@ -52,12 +51,12 @@
243 , ghc-prim
244 , hlibgit2 >= 0.18.0.11
245 , aeson >= 0.6.1.0
246- , attempt >= 0.4.0
247 , aws >= 0.7.5
248 , bifunctors >= 3.2.0.1
249 , binary >= 0.5.1.0
250 , bytestring >= 0.9.2.1
251 , conduit >= 0.5.5
252+ , conduit-extra
253 , data-default >= 0.5.1
254 , directory >= 1.1.0.2
255 , filepath >= 1.3.0
256diff -ru orig/test/Smoke.hs new/test/Smoke.hs
257--- orig/test/Smoke.hs 2014-04-06 09:02:47.247789820 +0300
258+++ new/test/Smoke.hs 2014-04-06 09:02:47.000000000 +0300
259@@ -11,7 +11,6 @@
261 import Aws
262 import Control.Applicative
263-import Control.Failure
264 import Control.Monad.IO.Class
265 import Control.Monad.Logger
266 import Control.Monad.Trans.Reader
267@@ -30,8 +29,7 @@
268 import Test.Hspec.Runner
270 s3Factory
271- :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m,
272- MonadUnsafeIO m, MonadThrow m)
273+ :: (MonadThrow m, MonadIO m, MonadBaseControl IO m)
274 => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo
275 s3Factory = Lg.lgFactory
276 { Git.runRepository = \ctxt m ->