summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-04-19 14:45:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-04-19 14:45:19 -0400
commita441e08da1e6305f36db782ec9eda44f213ffa29 (patch)
tree7f2c0fbbdf9dd779cb020faed1614bbd6f69eabc
parent1687fecd33ff73a71b2084532e9731796758047a (diff)
Fix stalls in S3 when transferring encrypted data.
Stalls were caused by code that did approximatly: content' <- liftIO $ withEncryptedContent cipher content return store content' The return evaluated without actually reading content from S3, and so the cleanup code began waiting on gpg to exit before gpg could send all its data. Fixing it involved moving the `store` type action into the IO monad: liftIO $ withEncryptedContent cipher content store Which was a bit of a pain to do, thank you type system, but avoids the problem as now the whole content is consumed, and stored, before cleanup.
-rw-r--r--Crypto.hs5
-rw-r--r--Remote/S3real.hs76
-rw-r--r--debian/changelog1
-rw-r--r--doc/bugs/encrypted_S3_stalls.mdwn2
4 files changed, 50 insertions, 34 deletions
diff --git a/Crypto.hs b/Crypto.hs
index 1f4493b94..41f6b999b 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -199,7 +199,10 @@ gpgPipeStrict params input = do
return output
{- Runs gpg with a cipher and some parameters, feeding it an input,
- - and passing a handle to its output to an action. -}
+ - and passing a handle to its output to an action.
+ -
+ - Note that to avoid deadlock with the cleanup stage,
+ - the action must fully consume gpg's input before returning. -}
gpgCipherHandle :: [CommandParam] -> Cipher -> L.ByteString -> (Handle -> IO a) -> IO a
gpgCipherHandle params c input a = do
-- pipe the passphrase into gpg on a fd
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index b88b22037..fe68a7f5b 100644
--- a/Remote/S3real.hs
+++ b/Remote/S3real.hs
@@ -100,13 +100,13 @@ s3Setup u c = do
loc <- liftIO $ getBucketLocation conn bucket
case loc of
Right _ -> return ()
- Left err@(NetworkError _) -> error $ prettyReqError err
+ Left err@(NetworkError _) -> s3Error err
Left (AWSError _ _) -> do
showNote $ "creating bucket in " ++ datacenter
res <- liftIO $ createBucketIn conn bucket datacenter
case res of
Right _ -> return ()
- Left err -> error $ prettyReqError err
+ Left err -> s3Error err
gitConfigSpecialRemote u fullconfig "s3" "true"
return fullconfig
@@ -141,33 +141,32 @@ checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
case res of
Right _ -> return $ Right True
Left (AWSError _ _) -> return $ Right False
- Left e -> return $ Left (error $ prettyReqError e)
+ Left e -> return $ Left (s3Error e)
where
noconn = Left $ error "S3 not configured"
store :: Remote Annex -> Key -> Annex Bool
-store r k = storeHelper r k =<< lazyKeyContent k
+store r k = s3Action r False $ \(conn, bucket) -> do
+ content <- lazyKeyContent k
+ res <- liftIO $ storeHelper (conn, bucket) r k content
+ s3Bool res
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted r (cipher, enck) k = do
+storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> do
content <- lazyKeyContent k
- content' <- liftIO $ withEncryptedContent cipher content return
- storeHelper r enck content'
+ res <- liftIO $ withEncryptedContent cipher content $ \s -> do
+ storeHelper (conn, bucket) r enck s
+ s3Bool res
lazyKeyContent :: Key -> Annex L.ByteString
lazyKeyContent k = do
g <- Annex.gitRepo
liftIO $ L.readFile $ gitAnnexLocation g k
-storeHelper :: Remote Annex -> Key -> L.ByteString -> Annex Bool
-storeHelper r k content = s3Action r False $ \(conn, bucket) -> do
+storeHelper :: (AWSConnection, String) -> Remote Annex -> Key -> L.ByteString -> IO (AWSResult ())
+storeHelper (conn, bucket) r k content = do
let object = setStorageClass storageclass $ bucketKey bucket k content
- res <- liftIO $ sendObject conn object
- case res of
- Right _ -> return True
- Left e -> do
- warning $ prettyReqError e
- return False
+ sendObject conn object
where
storageclass =
case fromJust $ M.lookup "storageclass" $ fromJust $ config r of
@@ -175,30 +174,41 @@ storeHelper r k content = s3Action r False $ \(conn, bucket) -> do
_ -> STANDARD
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
-retrieve = retrieveHelper (return . obj_data)
-
-retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool
-retrieveEncrypted r (cipher, enck) f = retrieveHelper decrypt r enck f
- where
- decrypt o = withDecryptedContent cipher (obj_data o) return
-
-retrieveHelper :: (S3Object -> IO L.ByteString) -> Remote Annex -> Key -> FilePath -> Annex Bool
-retrieveHelper a r k f = s3Action r False $ \(conn, bucket) -> do
+retrieve r k f = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
case res of
Right o -> do
- content <- liftIO $ a o
- liftIO $ L.writeFile f content
+ liftIO $ L.writeFile f $ obj_data o
return True
- Left e -> do
- warning $ prettyReqError e
- return False
-
+ Left e -> s3Warning e
+
+retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool
+retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
+ res <- liftIO $ getObject conn $ bucketKey bucket enck L.empty
+ case res of
+ Right o -> liftIO $
+ withDecryptedContent cipher (obj_data o) $ \content -> do
+ L.writeFile f content
+ return True
+ Left e -> s3Warning e
+
remove :: Remote Annex -> Key -> Annex Bool
remove r k = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
case res of
Right _ -> return True
- Left e -> do
- warning $ prettyReqError e
- return False
+ Left e -> s3Warning e
+
+s3Warning :: ReqError -> Annex Bool
+s3Warning e = do
+ warning $ prettyReqError e
+ return False
+
+s3Error :: ReqError -> a
+s3Error e = error $ prettyReqError e
+
+s3Bool :: AWSResult () -> Annex Bool
+s3Bool res = do
+ case res of
+ Right _ -> return True
+ Left e -> s3Warning e
diff --git a/debian/changelog b/debian/changelog
index aa00d3fca..60ccace7a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -3,6 +3,7 @@ git-annex (0.20110418) UNRELEASED; urgency=low
* Don't run gpg in batch mode, so it can prompt for passphrase when
there is no agent.
* Add missing build dep on dataenc.
+ * Fix stalls in S3 when transferring encrypted data.
-- Joey Hess <joeyh@debian.org> Sun, 17 Apr 2011 14:29:49 -0400
diff --git a/doc/bugs/encrypted_S3_stalls.mdwn b/doc/bugs/encrypted_S3_stalls.mdwn
index c4484b9c4..109e6e793 100644
--- a/doc/bugs/encrypted_S3_stalls.mdwn
+++ b/doc/bugs/encrypted_S3_stalls.mdwn
@@ -5,3 +5,5 @@ dialup.
There was a similar issue with bup, which I fixed by forking a process
rather than using a thread to do some IO. Probably need the same here.
--[[Joey]]
+
+[[done]] --[[Joey]]