diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Gpg.hs | 36 | ||||
| -rw-r--r-- | Utility/Process.hs | 1 | ||||
| -rw-r--r-- | Utility/Tmp.hs | 13 |
3 files changed, 31 insertions, 19 deletions
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index a00bf99da..410259b11 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -11,14 +11,15 @@ module Utility.Gpg where import Control.Applicative import Control.Concurrent +import Control.Monad.IO.Class import qualified Data.Map as M +import Control.Monad.Catch (bracket, MonadMask) import Common import qualified Build.SysConfig as SysConfig #ifndef mingw32_HOST_OS import System.Posix.Types -import Control.Exception (bracket) import System.Path import Utility.Env #else @@ -104,18 +105,18 @@ pipeStrict params input = do - - Note that to avoid deadlock with the cleanup stage, - the reader must fully consume gpg's input before returning. -} -feedRead :: [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a +feedRead :: (MonadIO m, MonadMask m) => [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead params passphrase feeder reader = do #ifndef mingw32_HOST_OS -- pipe the passphrase into gpg on a fd - (frompipe, topipe) <- createPipe - void $ forkIO $ do + (frompipe, topipe) <- liftIO createPipe + liftIO $ void $ forkIO $ do toh <- fdToHandle topipe hPutStrLn toh passphrase hClose toh let Fd pfd = frompipe let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] - closeFd frompipe `after` go (passphrasefd ++ params) + liftIO (closeFd frompipe) `after` go (passphrasefd ++ params) #else -- store the passphrase in a temp file for gpg withTmpFile "gpg" $ \tmpfile h -> do @@ -128,15 +129,24 @@ feedRead params passphrase feeder reader = do go params' = pipeLazy params' feeder reader {- Like feedRead, but without passphrase. -} -pipeLazy :: [CommandParam] -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a +pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a pipeLazy params feeder reader = do - params' <- stdParams $ Param "--batch" : params - withBothHandles createProcessSuccess (proc gpgcmd params') - $ \(to, from) -> do - void $ forkIO $ do - feeder to - hClose to - reader from + params' <- liftIO $ stdParams $ Param "--batch" : params + let p = (proc gpgcmd params') + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + bracket (setup p) (cleanup p) go + where + setup = liftIO . createProcess + cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid + go p = do + let (to, from) = bothHandles p + liftIO $ void $ forkIO $ do + feeder to + hClose to + reader from {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of diff --git a/Utility/Process.hs b/Utility/Process.hs index 1f722af81..e25618eba 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ module Utility.Process ( stdinHandle, stdoutHandle, stderrHandle, + bothHandles, processHandle, devNull, ) where diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index bed30bb4d..7da5cc284 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -9,11 +9,12 @@ module Utility.Tmp where -import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import System.FilePath +import Control.Monad.IO.Class +import Control.Monad.Catch (bracket, MonadMask) import Utility.Exception import Utility.FileSystemEncoding @@ -42,18 +43,18 @@ viaTmp a file content = bracket setup cleanup use {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. -} -withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = openTempFile tmpdir template - remove (name, handle) = do + create = liftIO $ openTempFile tmpdir template + remove (name, handle) = liftIO $ do hClose handle catchBoolIO (removeFile name >> return True) use (name, handle) = a name handle |