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.

1 files changed, 43 insertions, 33 deletions

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