summaryrefslogtreecommitdiff
path: root/Utility/Gpg.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-07-18 15:30:26 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-07-18 18:00:24 -0400
commitd1da9cf221aeea5c7ac8a313a18b559791a04f12 (patch)
treefe8d7e42efb89441d14ab8d5d71bb8f0f007330b /Utility/Gpg.hs
parentfc5652c811a9a644bb8964b3b8c13df24f2ec7c7 (diff)
switch from System.Cmd.Utils to System.Process
Test suite now passes with -threaded! I traced back all the hangs with -threaded to System.Cmd.Utils. It seems it's just crappy/unsafe/outdated, and should not be used. System.Process seems to be the cool new thing, so converted all the code to use it instead. In the process, --debug stopped printing commands it runs. I may try to bring that back later. Note that even SafeSystem was switched to use System.Process. Since that was a modified version of code from System.Cmd.Utils, it needed to be converted too. I also got rid of nearly all calls to forkProcess, and all calls to executeFile, which I'm also doubtful about working well with -threaded.
Diffstat (limited to 'Utility/Gpg.hs')
-rw-r--r--Utility/Gpg.hs39
1 files changed, 24 insertions, 15 deletions
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index e13afe5d4..26ac688e3 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -11,9 +11,9 @@ import qualified Data.ByteString.Lazy as L
import System.Posix.Types
import Control.Applicative
import Control.Concurrent
-import Control.Exception (finally, bracket)
-import System.Exit
+import Control.Exception (bracket)
import System.Posix.Env (setEnv, unsetEnv, getEnv)
+import System.Process
import Common
@@ -39,18 +39,30 @@ stdParams params = do
readStrict :: [CommandParam] -> IO String
readStrict params = do
params' <- stdParams params
- pOpen ReadFromPipe "gpg" params' hGetContentsStrict
+ (_, Just from, _, pid)
+ <- createProcess (proc "gpg" params')
+ { std_out = CreatePipe }
+ hSetBinaryMode from True
+ r <- hGetContentsStrict from
+ forceSuccessProcess pid "gpg" params'
+ return r
{- Runs gpg, piping an input value to it, and returning its stdout,
- strictly. -}
pipeStrict :: [CommandParam] -> String -> IO String
pipeStrict params input = do
params' <- stdParams params
- (pid, fromh, toh) <- hPipeBoth "gpg" params'
- _ <- forkIO $ finally (hPutStr toh input) (hClose toh)
- output <- hGetContentsStrict fromh
- forceSuccess pid
- return output
+ (Just to, Just from, _, pid)
+ <- createProcess (proc "gpg" params')
+ { std_in = CreatePipe
+ , std_out = CreatePipe }
+ hSetBinaryMode to True
+ hSetBinaryMode from True
+ hPutStr to input
+ hClose to
+ r <- hGetContentsStrict from
+ forceSuccessProcess pid "gpg" params'
+ return r
{- Runs gpg with some parameters, first feeding it a passphrase via
- --passphrase-fd, then feeding it an input, and passing a handle
@@ -70,17 +82,14 @@ passphraseHandle params passphrase a b = do
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
params' <- stdParams $ passphrasefd ++ params
- (pid, fromh, toh) <- hPipeBoth "gpg" params'
- pid2 <- forkProcess $ do
- L.hPut toh =<< a
- hClose toh
- exitSuccess
+ (Just toh, Just fromh, _, pid) <- createProcess (proc "gpg" params')
+ { std_in = CreatePipe, std_out = CreatePipe }
+ L.hPut toh =<< a
hClose toh
ret <- b fromh
-- cleanup
- forceSuccess pid
- _ <- getProcessStatus True False pid2
+ forceSuccessProcess pid "gpg" params'
closeFd frompipe
return ret