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.
This commit is contained in:
parent
fc5652c811
commit
d1da9cf221
32 changed files with 178 additions and 740 deletions
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue