async exception safety

Use async/cancel so helper threads are not left running.

Bracket createPipe to ensure the handles get closed.
This commit is contained in:
Joey Hess 2020-06-05 13:58:21 -04:00
parent a0d09f1d9e
commit 074260f036
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38

View file

@ -47,7 +47,7 @@ import Utility.Tmp
#endif #endif
import Utility.Format (decode_c) import Utility.Format (decode_c)
import Control.Concurrent import Control.Concurrent.Async
import Control.Monad.IO.Class import Control.Monad.IO.Class
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
@ -154,15 +154,22 @@ pipeStrict (GpgCmd cmd) params input = do
feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
feedRead cmd params passphrase feeder reader = do feedRead cmd params passphrase feeder reader = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
-- pipe the passphrase into gpg on a fd let setup = liftIO $ do
(frompipe, topipe) <- liftIO System.Posix.IO.createPipe -- pipe the passphrase into gpg on a fd
liftIO $ void $ forkIO $ do (frompipe, topipe) <- System.Posix.IO.createPipe
toh <- fdToHandle topipe toh <- fdToHandle topipe
hPutStrLn toh passphrase t <- async $ do
hPutStrLn toh passphrase
hClose toh
let Fd pfd = frompipe
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
return (passphrasefd, frompipe, toh, t)
let cleanup (_, frompipe, toh, t) = liftIO $ do
closeFd frompipe
hClose toh hClose toh
let Fd pfd = frompipe cancel t
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] bracket setup cleanup $ \(passphrasefd, _, _, _) ->
liftIO (closeFd frompipe) `after` go (passphrasefd ++ params) go (passphrasefd ++ params)
#else #else
-- store the passphrase in a temp file for gpg -- store the passphrase in a temp file for gpg
withTmpFile "gpg" $ \tmpfile h -> do withTmpFile "gpg" $ \tmpfile h -> do
@ -188,13 +195,14 @@ pipeLazy (GpgCmd cmd) params feeder reader = do
setup = liftIO . createProcess setup = liftIO . createProcess
cleanup = liftIO . cleanupProcess cleanup = liftIO . cleanupProcess
go p (Just to, Just from, _, pid) = do go p (Just to, Just from, _, pid) =
liftIO $ void $ forkIO $ do let runfeeder = do
feeder to feeder to
hClose to hClose to
r <- reader from in bracketIO (async runfeeder) cancel $ const $ do
liftIO $ forceSuccessProcess p pid r <- reader from
return r liftIO $ forceSuccessProcess p pid
return r
go _ _ = error "internal" go _ _ = error "internal"
{- Finds gpg public keys matching some string. (Could be an email address, {- Finds gpg public keys matching some string. (Could be an email address,