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.
This commit is contained in:
Joey Hess 2011-04-17 00:34:38 -04:00
parent 11da36e48f
commit d996637fd6
2 changed files with 41 additions and 32 deletions

View file

@ -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"

View file

@ -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