diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-02-13 15:35:24 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-02-13 15:35:24 -0400 |
commit | b1813685256f126c1a51170428a35704c7389aa6 (patch) | |
tree | 754d5231540f18bd402a723d02d11e8171aa8edd /Remote/S3.hs | |
parent | 2852570338052585ddc78aa9c3fef776285355a2 (diff) |
S3: Fix check of uuid file stored in bucket, which was not working.
The check was broken in two ways.. First, nowhere did it error out when
checkUUIDFile found a different UUID already in the file. Instead,
it overwrote the uuid file.
And, checkUUIDFile's implementation was for some reason always failing with
a ConnectionClosed exception. Apparently something to do with using two
different runResourceT's and a response getting GCed inbetween. I'm pretty
sure that used to work, but changed to a more obviously correct
implementation.
This commit was sponsored by Peter Hogg on Patreon.
Diffstat (limited to 'Remote/S3.hs')
-rw-r--r-- | Remote/S3.hs | 29 |
1 files changed, 18 insertions, 11 deletions
diff --git a/Remote/S3.hs b/Remote/S3.hs index 341b66d1a..ab8411726 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Remote.S3 (remote, iaHost, configIA, iaItemUrl) where @@ -355,7 +356,8 @@ genBucket c gc u = do {- Writes the UUID to an annex-uuid file within the bucket. - - - If the file already exists in the bucket, it must match. + - If the file already exists in the bucket, it must match, + - or this fails. - - Note that IA buckets can only created by having a file - stored in them. So this also takes care of that. @@ -365,6 +367,9 @@ writeUUIDFile c u info h = do v <- checkUUIDFile c u info h case v of Right True -> noop + Right False -> do + warning "The bucket already exists, and its annex-uuid file indicates it is used by a different special remote." + giveup "Cannot reuse this bucket." _ -> void $ sendS3Handle h mkobject where file = T.pack $ uuidFile c @@ -375,15 +380,17 @@ writeUUIDFile c u info h = do {- Checks if the UUID file exists in the bucket - and has the specified UUID already. -} checkUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool) -checkUUIDFile c u info h = tryNonAsync $ check <$> get +checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do + resp <- tryS3 $ sendS3Handle' h (S3.getObject (bucket info) file) + case resp of + Left _ -> return False + Right r -> do + v <- AWS.loadToMemory r + let !ok = check v + return ok where - get = liftIO - . runResourceT - . either (pure . Left) (Right <$$> AWS.loadToMemory) - =<< tryS3 (sendS3Handle h (S3.getObject (bucket info) file)) - check (Right (S3.GetObjectMemoryResponse _meta rsp)) = + check (S3.GetObjectMemoryResponse _meta rsp) = responseStatus rsp == ok200 && responseBody rsp == uuidb - check (Left _S3Error) = False file = T.pack $ uuidFile c uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] @@ -391,6 +398,9 @@ checkUUIDFile c u info h = tryNonAsync $ check <$> get uuidFile :: RemoteConfig -> FilePath uuidFile c = getFilePrefix c ++ "annex-uuid" +tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a) +tryS3 a = (Right <$> a) `catch` (pure . Left) + data S3Handle = S3Handle { hmanager :: Manager , hawscfg :: AWS.Configuration @@ -465,9 +475,6 @@ s3Configuration c = cfg _ -> giveup $ "bad S3 port value: " ++ s cfg = S3.s3 proto endpoint False -tryS3 :: Annex a -> Annex (Either S3.S3Error a) -tryS3 a = (Right <$> a) `catch` (pure . Left) - data S3Info = S3Info { bucket :: S3.Bucket , storageClass :: S3.StorageClass |