bup: Avoid memory leak when transferring encrypted data.

This was a most surprising leak. It occurred in the process that is forked
off to feed data to gpg. That process was passed a lazy ByteString of
input, and ghc seemed to not GC the ByteString as it was lazily read
and consumed, so memory slowly leaked as the file was read and passed
through gpg to bup.

To fix it, I simply changed the feeder to take an IO action that returns
the lazy bytestring, and fed the result directly to hPut.

AFAICS, this should change nothing WRT buffering. But somehow it makes
ghc's GC do the right thing. Probably I triggered some weakness in ghc's
GC (version 6.12.1).

(Note that S3 still has this leak, and others too. Fixing it will involve
another dance with the type system.)

Update: One theory I have is that this has something to do with
the forking of the feeder process. Perhaps, when the ByteString
is produced before the fork, ghc decides it need to hold a pointer
to the start of it, for some reason -- maybe it doesn't realize that
it is only used in the forked process.

3 files changed, 6 insertions, 10 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 16e1bbdcb..6ae002c3b 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -126,8 +126,7 @@ storeEncrypted r buprepo (cipher, enck) k = do
 	let src = gitAnnexLocation g k
 	params <- bupSplitParams r buprepo enck (Param "-")
 	liftIO $ catchBool $ do
-		content <- L.readFile src
-		withEncryptedHandle cipher content $ \h -> do
+		withEncryptedHandle cipher (L.readFile src) $ \h -> do
 			pipeBup params (Just h) Nothing
 
 retrieve :: BupRepo -> Key -> FilePath -> Annex Bool
@@ -142,8 +141,7 @@ retrieveEncrypted buprepo (cipher, enck) f = do
 	let params = bupParams "join" buprepo [Param $ show enck]
 	liftIO $ catchBool $ do
 		(pid, h) <- hPipeFrom "bup" $ toCommand params
-		content <- L.hGetContents h
-		withDecryptedContent cipher content $ L.writeFile f
+		withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
 		forceSuccess pid
 		return True
 
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index d9bee80c3..c680d6121 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -92,8 +92,7 @@ storeEncrypted d (cipher, enck) k = do
 	liftIO $ catchBool $ storeHelper dest $ encrypt src dest
 	where
 		encrypt src dest = do
-			content <- L.readFile src
-			withEncryptedContent cipher content $ L.writeFile dest
+			withEncryptedContent cipher (L.readFile src) $ L.writeFile dest
 			return True
 
 storeHelper :: FilePath -> IO Bool -> IO Bool
@@ -113,8 +112,7 @@ retrieve d k f = liftIO $ copyFile (dirKey d k) f
 retrieveEncrypted :: FilePath -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted d (cipher, enck) f =
 	liftIO $ catchBool $ do
-		content <- L.readFile (dirKey d enck)
-		withDecryptedContent cipher content $ L.writeFile f
+		withDecryptedContent cipher (L.readFile (dirKey d enck)) $ L.writeFile f
 		return True
 
 remove :: FilePath -> Key -> Annex Bool
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index 5d8435932..f40deaf17 100644
--- a/Remote/S3real.hs
+++ b/Remote/S3real.hs
@@ -106,7 +106,7 @@ store r k = s3Action r False $ \(conn, bucket) -> do
 storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
 storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> do
 	content <- lazyKeyContent k
-	res <- liftIO $ withEncryptedContent cipher content $ \s -> do
+	res <- liftIO $ withEncryptedContent cipher (return content) $ \s -> do
 		storeHelper (conn, bucket) r enck s
 	s3Bool res
 
@@ -139,7 +139,7 @@ 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
+			withDecryptedContent cipher (return $ obj_data o) $ \content -> do
 				L.writeFile f content
 				return True
 		Left e -> s3Warning e