{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Process.Typed.Internal where
import qualified Data.ByteString as S
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import qualified Control.Exception as E
import Control.Exception hiding (bracket, finally, handle)
import Control.Monad (void)
import qualified System.Process as P
import Data.Typeable (Typeable)
import System.IO (Handle, hClose, IOMode(ReadWriteMode), withBinaryFile)
import Control.Concurrent.Async (async)
import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, readTMVar, STM, tryPutTMVar, throwSTM)
import System.Exit (ExitCode)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.String (IsString (fromString))
import Control.Monad.IO.Unlift
#if MIN_VERSION_process(1, 4, 0) && !WINDOWS
import System.Posix.Types (GroupID, UserID)
#endif
#if !MIN_VERSION_base(4, 8, 0)
import Control.Applicative (Applicative (..), (<$>), (<$))
#endif
#if !MIN_VERSION_process(1, 3, 0)
import qualified System.Process.Internals as P (createProcess_)
#endif
data ProcessConfig stdin stdout stderr = ProcessConfig
{ forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> CmdSpec
pcCmdSpec :: !P.CmdSpec
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> StreamSpec 'STInput stdin
pcStdin :: !(StreamSpec 'STInput stdin)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> StreamSpec 'STOutput stdout
pcStdout :: !(StreamSpec 'STOutput stdout)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> StreamSpec 'STOutput stderr
pcStderr :: !(StreamSpec 'STOutput stderr)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe FilePath
pcWorkingDir :: !(Maybe FilePath)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe [(FilePath, FilePath)]
pcEnv :: !(Maybe [(String, String)])
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcCloseFds :: !Bool
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcCreateGroup :: !Bool
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcDelegateCtlc :: !Bool
#if MIN_VERSION_process(1, 3, 0)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcDetachConsole :: !Bool
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcCreateNewConsole :: !Bool
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Bool
pcNewSession :: !Bool
#endif
#if MIN_VERSION_process(1, 4, 0) && !WINDOWS
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe GroupID
pcChildGroup :: !(Maybe GroupID)
, forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe UserID
pcChildUser :: !(Maybe UserID)
#endif
}
instance Show (ProcessConfig stdin stdout stderr) where
show :: ProcessConfig stdin stdout stderr -> FilePath
show ProcessConfig stdin stdout stderr
pc = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ case ProcessConfig stdin stdout stderr -> CmdSpec
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> CmdSpec
pcCmdSpec ProcessConfig stdin stdout stderr
pc of
P.ShellCommand FilePath
s -> FilePath
"Shell command: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
s
P.RawCommand FilePath
x [FilePath]
xs -> FilePath
"Raw command: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
escape (FilePath
xFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
xs))
, FilePath
"\n"
, case ProcessConfig stdin stdout stderr -> Maybe FilePath
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe FilePath
pcWorkingDir ProcessConfig stdin stdout stderr
pc of
Maybe FilePath
Nothing -> FilePath
""
Just FilePath
wd -> [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
"Run from: "
, FilePath
wd
, FilePath
"\n"
]
, case ProcessConfig stdin stdout stderr -> Maybe [(FilePath, FilePath)]
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> Maybe [(FilePath, FilePath)]
pcEnv ProcessConfig stdin stdout stderr
pc of
Maybe [(FilePath, FilePath)]
Nothing -> FilePath
""
Just [(FilePath, FilePath)]
e -> [FilePath] -> FilePath
unlines
([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Modified environment:"
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
k, FilePath
v) -> [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FilePath
k, FilePath
"=", FilePath
v]) [(FilePath, FilePath)]
e
]
where
escape :: ShowS
escape FilePath
x
| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
" \\\"'") FilePath
x = ShowS
forall a. Show a => a -> FilePath
show FilePath
x
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = FilePath
"\"\""
| Bool
otherwise = FilePath
x
instance (stdin ~ (), stdout ~ (), stderr ~ ())
=> IsString (ProcessConfig stdin stdout stderr) where
fromString :: FilePath -> ProcessConfig stdin stdout stderr
fromString FilePath
s
| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') FilePath
s = FilePath -> ProcessConfig () () ()
shell FilePath
s
| Bool
otherwise = FilePath -> [FilePath] -> ProcessConfig () () ()
proc FilePath
s []
data StreamType = STInput | STOutput
data StreamSpec (streamType :: StreamType) a = StreamSpec
{ forall (streamType :: StreamType) a.
StreamSpec streamType a -> forall b. (StdStream -> IO b) -> IO b
ssStream :: !(forall b. (P.StdStream -> IO b) -> IO b)
, forall (streamType :: StreamType) a.
StreamSpec streamType a
-> ProcessConfig () () () -> Maybe Handle -> Cleanup a
ssCreate :: !(ProcessConfig () () () -> Maybe Handle -> Cleanup a)
}
deriving (forall a b.
(a -> b) -> StreamSpec streamType a -> StreamSpec streamType b)
-> (forall a b.
a -> StreamSpec streamType b -> StreamSpec streamType a)
-> Functor (StreamSpec streamType)
forall a b. a -> StreamSpec streamType b -> StreamSpec streamType a
forall a b.
(a -> b) -> StreamSpec streamType a -> StreamSpec streamType b
forall (streamType :: StreamType) a b.
a -> StreamSpec streamType b -> StreamSpec streamType a
forall (streamType :: StreamType) a b.
(a -> b) -> StreamSpec streamType a -> StreamSpec streamType b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (streamType :: StreamType) a b.
(a -> b) -> StreamSpec streamType a -> StreamSpec streamType b
fmap :: forall a b.
(a -> b) -> StreamSpec streamType a -> StreamSpec streamType b
$c<$ :: forall (streamType :: StreamType) a b.
a -> StreamSpec streamType b -> StreamSpec streamType a
<$ :: forall a b. a -> StreamSpec streamType b -> StreamSpec streamType a
Functor
instance (streamType ~ 'STInput, res ~ ())
=> IsString (StreamSpec streamType res) where
fromString :: FilePath -> StreamSpec streamType res
fromString = ByteString -> StreamSpec streamType res
ByteString -> StreamSpec 'STInput ()
byteStringInput (ByteString -> StreamSpec streamType res)
-> (FilePath -> ByteString)
-> FilePath
-> StreamSpec streamType res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString
newtype Cleanup a = Cleanup { forall a. Cleanup a -> IO (a, IO ())
runCleanup :: IO (a, IO ()) }
deriving (forall a b. (a -> b) -> Cleanup a -> Cleanup b)
-> (forall a b. a -> Cleanup b -> Cleanup a) -> Functor Cleanup
forall a b. a -> Cleanup b -> Cleanup a
forall a b. (a -> b) -> Cleanup a -> Cleanup b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Cleanup a -> Cleanup b
fmap :: forall a b. (a -> b) -> Cleanup a -> Cleanup b
$c<$ :: forall a b. a -> Cleanup b -> Cleanup a
<$ :: forall a b. a -> Cleanup b -> Cleanup a
Functor
instance Applicative Cleanup where
pure :: forall a. a -> Cleanup a
pure a
x = IO (a, IO ()) -> Cleanup a
forall a. IO (a, IO ()) -> Cleanup a
Cleanup ((a, IO ()) -> IO (a, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
Cleanup IO (a -> b, IO ())
f <*> :: forall a b. Cleanup (a -> b) -> Cleanup a -> Cleanup b
<*> Cleanup IO (a, IO ())
x = IO (b, IO ()) -> Cleanup b
forall a. IO (a, IO ()) -> Cleanup a
Cleanup (IO (b, IO ()) -> Cleanup b) -> IO (b, IO ()) -> Cleanup b
forall a b. (a -> b) -> a -> b
$ do
(a -> b
f', IO ()
c1) <- IO (a -> b, IO ())
f
(IO (b, IO ()) -> IO () -> IO (b, IO ())
forall a b. IO a -> IO b -> IO a
`onException` IO ()
c1) (IO (b, IO ()) -> IO (b, IO ())) -> IO (b, IO ()) -> IO (b, IO ())
forall a b. (a -> b) -> a -> b
$ do
(a
x', IO ()
c2) <- IO (a, IO ())
x
(b, IO ()) -> IO (b, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
x', IO ()
c1 IO () -> IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> IO () -> m a
`finally` IO ()
c2)
defaultProcessConfig :: ProcessConfig () () ()
defaultProcessConfig :: ProcessConfig () () ()
defaultProcessConfig = ProcessConfig
{ pcCmdSpec :: CmdSpec
pcCmdSpec = FilePath -> CmdSpec
P.ShellCommand FilePath
""
, pcStdin :: StreamSpec 'STInput ()
pcStdin = StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
, pcStdout :: StreamSpec 'STOutput ()
pcStdout = StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
, pcStderr :: StreamSpec 'STOutput ()
pcStderr = StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
, pcWorkingDir :: Maybe FilePath
pcWorkingDir = Maybe FilePath
forall a. Maybe a
Nothing
, pcEnv :: Maybe [(FilePath, FilePath)]
pcEnv = Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
, pcCloseFds :: Bool
pcCloseFds = Bool
False
, pcCreateGroup :: Bool
pcCreateGroup = Bool
False
, pcDelegateCtlc :: Bool
pcDelegateCtlc = Bool
False
#if MIN_VERSION_process(1, 3, 0)
, pcDetachConsole :: Bool
pcDetachConsole = Bool
False
, pcCreateNewConsole :: Bool
pcCreateNewConsole = Bool
False
, pcNewSession :: Bool
pcNewSession = Bool
False
#endif
#if MIN_VERSION_process(1, 4, 0) && !WINDOWS
, pcChildGroup :: Maybe GroupID
pcChildGroup = Maybe GroupID
forall a. Maybe a
Nothing
, pcChildUser :: Maybe UserID
pcChildUser = Maybe UserID
forall a. Maybe a
Nothing
#endif
}
proc :: FilePath -> [String] -> ProcessConfig () () ()
proc :: FilePath -> [FilePath] -> ProcessConfig () () ()
proc FilePath
cmd [FilePath]
args = FilePath
-> [FilePath] -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
FilePath
-> [FilePath]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setProc FilePath
cmd [FilePath]
args ProcessConfig () () ()
defaultProcessConfig
setProc :: FilePath -> [String]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setProc :: forall stdin stdout stderr.
FilePath
-> [FilePath]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setProc FilePath
cmd [FilePath]
args ProcessConfig stdin stdout stderr
p = ProcessConfig stdin stdout stderr
p { pcCmdSpec = P.RawCommand cmd args }
shell :: String -> ProcessConfig () () ()
shell :: FilePath -> ProcessConfig () () ()
shell FilePath
cmd = FilePath -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
FilePath
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setShell FilePath
cmd ProcessConfig () () ()
defaultProcessConfig
setShell :: String
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setShell :: forall stdin stdout stderr.
FilePath
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setShell FilePath
cmd ProcessConfig stdin stdout stderr
p = ProcessConfig stdin stdout stderr
p { pcCmdSpec = P.ShellCommand cmd }
setStdin :: StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin :: forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput stdin
spec ProcessConfig stdin0 stdout stderr
pc = ProcessConfig stdin0 stdout stderr
pc { pcStdin = spec }
setStdout :: StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout :: forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput stdout
spec ProcessConfig stdin stdout0 stderr
pc = ProcessConfig stdin stdout0 stderr
pc { pcStdout = spec }
setStderr :: StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr :: forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput stderr
spec ProcessConfig stdin stdout stderr0
pc = ProcessConfig stdin stdout stderr0
pc { pcStderr = spec }
setWorkingDir :: FilePath
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir :: forall stdin stdout stderr.
FilePath
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir FilePath
dir ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcWorkingDir = Just dir }
setWorkingDirInherit
:: ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDirInherit :: forall stdin stdout stderr.
ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDirInherit ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcWorkingDir = Nothing }
setEnv :: [(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv :: forall stdin stdout stderr.
[(FilePath, FilePath)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv [(FilePath, FilePath)]
env ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcEnv = Just env }
setEnvInherit
:: ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnvInherit :: forall stdin stdout stderr.
ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnvInherit ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcEnv = Nothing }
setCloseFds
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCloseFds :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCloseFds Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcCloseFds = x }
setCreateGroup
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCreateGroup :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCreateGroup Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcCreateGroup = x }
setDelegateCtlc
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcDelegateCtlc = x }
#if MIN_VERSION_process(1, 3, 0)
setDetachConsole
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDetachConsole :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDetachConsole Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcDetachConsole = x }
setCreateNewConsole
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCreateNewConsole :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCreateNewConsole Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcCreateNewConsole = x }
setNewSession
:: Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setNewSession :: forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setNewSession Bool
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcNewSession = x }
#endif
#if MIN_VERSION_process(1, 4, 0) && !WINDOWS
setChildGroup
:: GroupID
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildGroup :: forall stdin stdout stderr.
GroupID
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildGroup GroupID
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcChildGroup = Just x }
setChildGroupInherit
:: ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildGroupInherit :: forall stdin stdout stderr.
ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildGroupInherit ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcChildGroup = Nothing }
setChildUser
:: UserID
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildUser :: forall stdin stdout stderr.
UserID
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildUser UserID
x ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcChildUser = Just x }
setChildUserInherit
:: ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildUserInherit :: forall stdin stdout stderr.
ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setChildUserInherit ProcessConfig stdin stdout stderr
pc = ProcessConfig stdin stdout stderr
pc { pcChildUser = Nothing }
#endif
mkStreamSpec :: P.StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec :: forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec StdStream
ss ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())
f = (forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
forall a (streamType :: StreamType).
(forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkManagedStreamSpec ((StdStream -> IO b) -> StdStream -> IO b
forall a b. (a -> b) -> a -> b
$ StdStream
ss) ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())
f
mkPipeStreamSpec :: (ProcessConfig () () () -> Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkPipeStreamSpec :: forall a (streamType :: StreamType).
(ProcessConfig () () () -> Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkPipeStreamSpec ProcessConfig () () () -> Handle -> IO (a, IO ())
f = StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec StdStream
P.CreatePipe ((ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc Maybe Handle
mh ->
case Maybe Handle
mh of
Just Handle
h -> ProcessConfig () () () -> Handle -> IO (a, IO ())
f ProcessConfig () () ()
pc Handle
h
Maybe Handle
Nothing -> FilePath -> IO (a, IO ())
forall a. HasCallStack => FilePath -> a
error FilePath
"Invariant violation: making StreamSpec with CreatePipe unexpectedly did not return a Handle"
mkManagedStreamSpec :: (forall b. (P.StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkManagedStreamSpec :: forall a (streamType :: StreamType).
(forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkManagedStreamSpec forall b. (StdStream -> IO b) -> IO b
ss ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())
f = (forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> Cleanup a)
-> StreamSpec streamType a
forall (streamType :: StreamType) a.
(forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> Cleanup a)
-> StreamSpec streamType a
StreamSpec (StdStream -> IO b) -> IO b
forall b. (StdStream -> IO b) -> IO b
ss (\ProcessConfig () () ()
pc Maybe Handle
mh -> IO (a, IO ()) -> Cleanup a
forall a. IO (a, IO ()) -> Cleanup a
Cleanup (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())
f ProcessConfig () () ()
pc Maybe Handle
mh))
inherit :: StreamSpec anyStreamType ()
inherit :: forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit = StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec StdStream
P.Inherit (\ProcessConfig () () ()
_ Maybe Handle
_ -> ((), IO ()) -> IO ((), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
nullStream :: StreamSpec anyStreamType ()
nullStream :: forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream = (forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a (streamType :: StreamType).
(forall b. (StdStream -> IO b) -> IO b)
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkManagedStreamSpec (StdStream -> IO b) -> IO b
forall b. (StdStream -> IO b) -> IO b
opener ProcessConfig () () () -> Maybe Handle -> IO ((), IO ())
forall {m :: * -> *} {f :: * -> *} {p} {p}.
(Monad m, Applicative f) =>
p -> p -> f ((), m ())
cleanup
where
opener :: (StdStream -> IO r) -> IO r
opener StdStream -> IO r
f =
FilePath -> IOMode -> (Handle -> IO r) -> IO r
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
nullDevice IOMode
ReadWriteMode ((Handle -> IO r) -> IO r) -> (Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Handle
handle ->
StdStream -> IO r
f (Handle -> StdStream
P.UseHandle Handle
handle)
cleanup :: p -> p -> f ((), m ())
cleanup p
_ p
_ =
((), m ()) -> f ((), m ())
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
closed :: StreamSpec anyStreamType ()
#if MIN_VERSION_process(1, 4, 0)
closed :: forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed = StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec StdStream
P.NoStream (\ProcessConfig () () ()
_ Maybe Handle
_ -> ((), IO ()) -> IO ((), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
#else
closed = mkPipeStreamSpec (\_ h -> ((), return ()) <$ hClose h)
#endif
byteStringInput :: L.ByteString -> StreamSpec 'STInput ()
byteStringInput :: ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
lbs = (ProcessConfig () () () -> Handle -> IO ((), IO ()))
-> StreamSpec 'STInput ()
forall a (streamType :: StreamType).
(ProcessConfig () () () -> Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkPipeStreamSpec ((ProcessConfig () () () -> Handle -> IO ((), IO ()))
-> StreamSpec 'STInput ())
-> (ProcessConfig () () () -> Handle -> IO ((), IO ()))
-> StreamSpec 'STInput ()
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
_ Handle
h -> do
IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Handle -> ByteString -> IO ()
L.hPut Handle
h ByteString
lbs
Handle -> IO ()
hClose Handle
h
((), IO ()) -> IO ((), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Handle -> IO ()
hClose Handle
h)
byteStringOutput :: StreamSpec 'STOutput (STM L.ByteString)
byteStringOutput :: StreamSpec 'STOutput (STM ByteString)
byteStringOutput = (ProcessConfig () () () -> Handle -> IO (STM ByteString, IO ()))
-> StreamSpec 'STOutput (STM ByteString)
forall a (streamType :: StreamType).
(ProcessConfig () () () -> Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkPipeStreamSpec ((ProcessConfig () () () -> Handle -> IO (STM ByteString, IO ()))
-> StreamSpec 'STOutput (STM ByteString))
-> (ProcessConfig () () () -> Handle -> IO (STM ByteString, IO ()))
-> StreamSpec 'STOutput (STM ByteString)
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc Handle
h -> ProcessConfig () () () -> Handle -> IO (STM ByteString, IO ())
byteStringFromHandle ProcessConfig () () ()
pc Handle
h
byteStringFromHandle
:: ProcessConfig () () ()
-> Handle
-> IO (STM L.ByteString, IO ())
byteStringFromHandle :: ProcessConfig () () () -> Handle -> IO (STM ByteString, IO ())
byteStringFromHandle ProcessConfig () () ()
pc Handle
h = do
TMVar (Either ByteStringOutputException ByteString)
mvar <- IO (TMVar (Either ByteStringOutputException ByteString))
forall a. IO (TMVar a)
newEmptyTMVarIO
IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
let loop :: ([ByteString] -> [ByteString]) -> IO ()
loop [ByteString] -> [ByteString]
front = do
ByteString
bs <- Handle -> Int -> IO ByteString
S.hGetSome Handle
h Int
defaultChunkSize
if ByteString -> Bool
S.null ByteString
bs
then STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either ByteStringOutputException ByteString)
-> Either ByteStringOutputException ByteString -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either ByteStringOutputException ByteString)
mvar (Either ByteStringOutputException ByteString -> STM ())
-> Either ByteStringOutputException ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteStringOutputException ByteString
forall a b. b -> Either a b
Right (ByteString -> Either ByteStringOutputException ByteString)
-> ByteString -> Either ByteStringOutputException ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
else ([ByteString] -> [ByteString]) -> IO ()
loop (([ByteString] -> [ByteString]) -> IO ())
-> ([ByteString] -> [ByteString]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
([ByteString] -> [ByteString]) -> IO ()
loop [ByteString] -> [ByteString]
forall a. a -> a
id IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either ByteStringOutputException ByteString)
-> Either ByteStringOutputException ByteString -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either ByteStringOutputException ByteString)
mvar (Either ByteStringOutputException ByteString -> STM Bool)
-> Either ByteStringOutputException ByteString -> STM Bool
forall a b. (a -> b) -> a -> b
$ ByteStringOutputException
-> Either ByteStringOutputException ByteString
forall a b. a -> Either a b
Left (ByteStringOutputException
-> Either ByteStringOutputException ByteString)
-> ByteStringOutputException
-> Either ByteStringOutputException ByteString
forall a b. (a -> b) -> a -> b
$ SomeException
-> ProcessConfig () () () -> ByteStringOutputException
ByteStringOutputException SomeException
e ProcessConfig () () ()
pc
SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e
(STM ByteString, IO ()) -> IO (STM ByteString, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TMVar (Either ByteStringOutputException ByteString)
-> STM (Either ByteStringOutputException ByteString)
forall a. TMVar a -> STM a
readTMVar TMVar (Either ByteStringOutputException ByteString)
mvar STM (Either ByteStringOutputException ByteString)
-> (Either ByteStringOutputException ByteString -> STM ByteString)
-> STM ByteString
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteStringOutputException -> STM ByteString)
-> (ByteString -> STM ByteString)
-> Either ByteStringOutputException ByteString
-> STM ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ByteStringOutputException -> STM ByteString
forall e a. Exception e => e -> STM a
throwSTM ByteString -> STM ByteString
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return, Handle -> IO ()
hClose Handle
h)
createPipe :: StreamSpec anyStreamType Handle
createPipe :: forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe = (ProcessConfig () () () -> Handle -> IO (Handle, IO ()))
-> StreamSpec anyStreamType Handle
forall a (streamType :: StreamType).
(ProcessConfig () () () -> Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkPipeStreamSpec ((ProcessConfig () () () -> Handle -> IO (Handle, IO ()))
-> StreamSpec anyStreamType Handle)
-> (ProcessConfig () () () -> Handle -> IO (Handle, IO ()))
-> StreamSpec anyStreamType Handle
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
_ Handle
h -> (Handle, IO ()) -> IO (Handle, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
h, Handle -> IO ()
hClose Handle
h)
useHandleOpen :: Handle -> StreamSpec anyStreamType ()
useHandleOpen :: forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
h = StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec (Handle -> StdStream
P.UseHandle Handle
h) ((ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ())
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
_ Maybe Handle
_ -> ((), IO ()) -> IO ((), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
useHandleClose :: Handle -> StreamSpec anyStreamType ()
useHandleClose :: forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleClose Handle
h = StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a (streamType :: StreamType).
StdStream
-> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ()))
-> StreamSpec streamType a
mkStreamSpec (Handle -> StdStream
P.UseHandle Handle
h) ((ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ())
-> (ProcessConfig () () () -> Maybe Handle -> IO ((), IO ()))
-> StreamSpec anyStreamType ()
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
_ Maybe Handle
_ -> ((), IO ()) -> IO ((), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Handle -> IO ()
hClose Handle
h)
data ExitCodeException = ExitCodeException
{ ExitCodeException -> ExitCode
eceExitCode :: ExitCode
, ExitCodeException -> ProcessConfig () () ()
eceProcessConfig :: ProcessConfig () () ()
, ExitCodeException -> ByteString
eceStdout :: L.ByteString
, ExitCodeException -> ByteString
eceStderr :: L.ByteString
}
deriving Typeable
instance Exception ExitCodeException
instance Show ExitCodeException where
show :: ExitCodeException -> FilePath
show ExitCodeException
ece = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
"Received "
, ExitCode -> FilePath
forall a. Show a => a -> FilePath
show (ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece)
, FilePath
" when running\n"
, ProcessConfig () () () -> FilePath
forall a. Show a => a -> FilePath
show (ExitCodeException -> ProcessConfig () () ()
eceProcessConfig ExitCodeException
ece) { pcEnv = Nothing }
, if ByteString -> Bool
L.null (ExitCodeException -> ByteString
eceStdout ExitCodeException
ece)
then FilePath
""
else FilePath
"Standard output:\n\n" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
L8.unpack (ExitCodeException -> ByteString
eceStdout ExitCodeException
ece)
, if ByteString -> Bool
L.null (ExitCodeException -> ByteString
eceStderr ExitCodeException
ece)
then FilePath
""
else FilePath
"Standard error:\n\n" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
L8.unpack (ExitCodeException -> ByteString
eceStderr ExitCodeException
ece)
]
data ByteStringOutputException = ByteStringOutputException SomeException (ProcessConfig () () ())
deriving (Int -> ByteStringOutputException -> ShowS
[ByteStringOutputException] -> ShowS
ByteStringOutputException -> FilePath
(Int -> ByteStringOutputException -> ShowS)
-> (ByteStringOutputException -> FilePath)
-> ([ByteStringOutputException] -> ShowS)
-> Show ByteStringOutputException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByteStringOutputException -> ShowS
showsPrec :: Int -> ByteStringOutputException -> ShowS
$cshow :: ByteStringOutputException -> FilePath
show :: ByteStringOutputException -> FilePath
$cshowList :: [ByteStringOutputException] -> ShowS
showList :: [ByteStringOutputException] -> ShowS
Show, Typeable)
instance Exception ByteStringOutputException
bracket :: MonadUnliftIO m => IO a -> (a -> IO b) -> (a -> m c) -> m c
bracket :: forall (m :: * -> *) a b c.
MonadUnliftIO m =>
IO a -> (a -> IO b) -> (a -> m c) -> m c
bracket IO a
before a -> IO b
after a -> m c
thing = ((forall a. m a -> IO a) -> IO c) -> m c
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO c) -> m c)
-> ((forall a. m a -> IO a) -> IO c) -> m c
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO a
before a -> IO b
after (m c -> IO c
forall a. m a -> IO a
run (m c -> IO c) -> (a -> m c) -> a -> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m c
thing)
finally :: MonadUnliftIO m => m a -> IO () -> m a
finally :: forall (m :: * -> *) a. MonadUnliftIO m => m a -> IO () -> m a
finally m a
thing IO ()
after = ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
E.finally (m a -> IO a
forall a. m a -> IO a
run m a
thing) IO ()
after
nullDevice :: FilePath
#if WINDOWS
nullDevice = "\\\\.\\NUL"
#else
nullDevice :: FilePath
nullDevice = FilePath
"/dev/null"
#endif