fix stall while storing encrypted data in bup

Forking a new process rather than relying on a thread to feed gpg.
The feeder thread was stalling, probably when the main thread got
to the point it was wait()ing on the gpg to exit.

2 files changed, 41 insertions, 32 deletions

diff --git a/Crypto.hs b/Crypto.hs
index 25d9a1157..4ec186ea2 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -17,6 +17,7 @@ module Crypto (
 	extractCipher,
 	decryptCipher,		
 	encryptKey,
+	withEncryptedContentHandle,
 	withEncryptedContent,
 	withDecryptedContent,
 ) where
@@ -33,8 +34,10 @@ import Data.Bits.Utils
 import System.IO
 import System.Posix.IO
 import System.Posix.Types
+import System.Posix.Process
 import Control.Concurrent
 import Control.Exception
+import System.Exit
 
 import Types
 import Key
@@ -116,6 +119,11 @@ encryptKey (Cipher c) k =
 		keyMtime = Nothing -- to avoid leaking data
 	}
 
+{- Runs an action passing it a handle from which it can 
+ - stream encrypted content. -}
+withEncryptedContentHandle :: Cipher -> L.ByteString -> (Handle -> IO a) -> IO a
+withEncryptedContentHandle = gpgCipherHandle [Params "--symmetric --force-mdc"]
+
 {- Streams encrypted content to an action. -}
 withEncryptedContent :: Cipher -> L.ByteString -> (L.ByteString -> IO a) -> IO a
 withEncryptedContent = gpgCipher [Params "--symmetric --force-mdc"]
@@ -142,17 +150,10 @@ gpgPipeStrict params input = do
 	forceSuccess pid
 	return output
 
-gpgPipeBytes :: [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString)
-gpgPipeBytes params input = do
-	(pid, fromh, toh) <- hPipeBoth "gpg" (gpgParams params)
-	_ <- forkIO $ finally (L.hPut toh input) (hClose toh)
-	output <- L.hGetContents fromh
-	return (pid, output)
-
 {- Runs gpg with a cipher and some parameters, feeding it an input,
- - and piping its output lazily to an action. -}
-gpgCipher :: [CommandParam] -> Cipher -> L.ByteString -> (L.ByteString -> IO a) -> IO a
-gpgCipher params (Cipher c) input a = do
+ - and passing a handle to its output to an action. -}
+gpgCipherHandle :: [CommandParam] -> Cipher -> L.ByteString -> (Handle -> IO a) -> IO a
+gpgCipherHandle params (Cipher c) input a = do
 	-- pipe the passphrase into gpg on a fd
 	(frompipe, topipe) <- createPipe
 	_ <- forkIO $ do
@@ -161,16 +162,29 @@ gpgCipher params (Cipher c) input a = do
 		hClose toh
 	let Fd passphrasefd = frompipe
 	let passphrase = [Param "--passphrase-fd", Param $ show passphrasefd]
-	(pid, output) <- gpgPipeBytes (passphrase ++ params) input
-	
-	ret <- a output
+
+	(pid, fromh, toh) <- hPipeBoth "gpg" $
+		gpgParams $ passphrase ++ params
+	_ <- forkProcess $ do
+		L.hPut toh input
+		hClose toh
+		exitSuccess
+	hClose toh
+	ret <- a fromh
 
 	-- cleanup
 	forceSuccess pid
 	closeFd frompipe
-
 	return ret
 
+{- Runs gpg with a cipher and some parameters, feeding it an input,
+ - and piping its output lazily to an action. -}
+gpgCipher :: [CommandParam] -> Cipher -> L.ByteString -> (L.ByteString -> IO a) -> IO a
+gpgCipher params c input a = do
+	gpgCipherHandle params c input $ \h -> do
+		content <- L.hGetContents h
+		a content
+
 configKeyIds :: RemoteConfig -> IO KeyIds
 configKeyIds c = do
 	let k = configGet c "encryption"
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 6f4c9278e..771212372 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -17,7 +17,6 @@ import System.Process
 import System.Exit
 import System.FilePath
 import Data.List.Utils
-import System.Cmd.Utils
 
 import RemoteClass
 import Types
@@ -96,6 +95,15 @@ bup command buprepo params = do
 	showProgress -- make way for bup output
 	liftIO $ boolSystem "bup" $ bupParams command buprepo params
 
+pipeBup :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
+pipeBup params inh outh = do
+	p <- runProcess "bup" (toCommand params)
+		Nothing Nothing inh outh Nothing
+	ok <- waitForProcess p
+	case ok of
+		ExitSuccess -> return True
+		_ -> return False
+
 bupSplitParams :: Git.Repo -> BupRepo -> Key -> CommandParam -> Annex [CommandParam]
 bupSplitParams r buprepo k src = do
 	o <- getConfig r "bup-split-options" ""
@@ -118,28 +126,15 @@ storeEncrypted r buprepo (cipher, enck) k = do
 	params <- bupSplitParams r buprepo enck (Param "-")
 	liftIO $ flip catch (const $ return False) $ do
 		content <- L.readFile src
-		-- FIXME hangs after a while
-		(pid, h) <- hPipeTo "bup" (toCommand params)
-		withEncryptedContent cipher content $ L.hPut h
-		hClose h
-		forceSuccess pid
-		return True
+		withEncryptedContentHandle cipher content $ \h -> do
+			pipeBup params (Just h) Nothing
 
 retrieve :: BupRepo -> Key -> FilePath -> Annex Bool
 retrieve buprepo k f = do
 	let params = bupParams "join" buprepo [Param $ show k]
-	ret <- liftIO $ try $ do
-		-- pipe bup's stdout directly to file
+	liftIO $ flip catch (const $ return False) $ do
 		tofile <- openFile f WriteMode
-		p <- runProcess "bup" (toCommand params) 
-			Nothing Nothing Nothing (Just tofile) Nothing
-		r <- waitForProcess p
-		case r of
-			ExitSuccess -> return True
-			_ -> return False
-	case ret of
-		Right r -> return r
-		Left _ -> return False
+		pipeBup params Nothing (Just tofile)
 
 retrieveEncrypted :: BupRepo -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted bupreoo (cipher, enck) f = do