{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Control.Monad.Hefty.Concurrent.Subprocess (
module Control.Monad.Hefty.Concurrent.Subprocess,
module Control.Monad.Hefty.Provider,
module System.Process,
module System.Process.Internals,
module System.IO,
module System.Exit,
module Data.ByteString,
)
where
import Control.Applicative ((<|>))
import Control.Concurrent (forkIO)
import Control.Monad (liftM2)
import Control.Monad.Hefty (Eff, Effect, Emb, Freer, RemoveExps, WeakenExps, interpret, liftIO, makeEffectF, (&), (:>))
import Control.Monad.Hefty.Provider
import Control.Monad.Hefty.Unlift (UnliftIO, withRunInIO)
import Data.ByteString (ByteString, hGet, hGetNonBlocking, hPut)
import Data.ByteString qualified as BS
import Data.Function (fix)
import Data.Maybe (fromJust, isNothing)
import System.Exit (ExitCode)
import System.IO (Handle)
import System.Process (CmdSpec (RawCommand, ShellCommand))
import System.Process qualified as Raw
import System.Process.Internals (GroupID, UserID)
import UnliftIO (TMVar, atomically, finally, mask, newEmptyTMVarIO, putTMVar, readTMVar, tryReadTMVar, uninterruptibleMask_)
import UnliftIO.Concurrent (ThreadId, killThread)
import UnliftIO.Process (terminateProcess, waitForProcess)
data Subprocess p :: Effect where
WriteStdin :: ByteString -> Subprocess ('SubprocMode 'Piped o e lp 'Kill) f ()
TryWriteStdin :: ByteString -> Subprocess ('SubprocMode 'Piped o e lp ls) f Bool
ReadStdout :: Subprocess ('SubprocMode i 'Piped e lp ls) f ByteString
ReadStderr :: Subprocess ('SubprocMode i o 'Piped lp ls) f ByteString
PollSubproc :: Subprocess ('SubprocMode i o e lp 'Wait) f (Maybe ExitCode)
data SubprocMode = SubprocMode StreamMode StreamMode StreamMode Lifecycle Lifecycle
data StreamMode = Piped | NoPipe
data Lifecycle = Kill | Wait
makeEffectF ''Subprocess
type SubprocProvider es = Scoped Freer SubprocResult CreateProcess '[Subprocess] es
data SubprocResult p a where
RaceResult :: Either ExitCode a -> SubprocResult ('SubprocMode i o e 'Kill 'Kill) a
SubprocResult :: ExitCode -> Maybe a -> SubprocResult ('SubprocMode i o e 'Wait 'Kill) a
ScopeResult :: Maybe ExitCode -> a -> SubprocResult ('SubprocMode i o e 'Kill 'Wait) a
SubprocScopeResult :: ExitCode -> a -> SubprocResult ('SubprocMode i o e 'Wait 'Wait) a
deriving stock instance (Show a) => Show (SubprocResult p a)
deriving stock instance (Eq a) => Eq (SubprocResult p a)
runSubprocIO
:: (UnliftIO :> es, Emb IO :> es, Emb IO :> RemoveExps es, WeakenExps es)
=> Eff (SubprocProvider (RemoveExps es) ': es) a
-> Eff es a
runSubprocIO :: forall (es :: [Effect]) a.
(UnliftIO :> es, Emb IO :> es, Emb IO :> RemoveExps es,
WeakenExps es) =>
Eff (SubprocProvider (RemoveExps es) : es) a -> Eff es a
runSubprocIO =
forall {k} (b :: * -> *) (t :: k -> * -> *) (i :: k -> *) a
(es :: [k -> Effect]) (r :: [Effect]) (ff :: Effect)
(c :: (* -> *) -> Constraint).
(WeakenExps r, UnliftBase b :> r, Emb b :> RemoveExps r,
KnownLength es, Free c ff) =>
(forall (s :: k) x.
i s
-> Eff ff (Each es s ++ (Scoped ff t i es (RemoveExps r) : r)) x
-> Eff ff (Scoped ff t i es (RemoveExps r) : r) (t s x))
-> Eff ff (Scoped ff t i es (RemoveExps r) : r) a -> Eff ff r a
forall (b :: * -> *) (t :: SubprocMode -> * -> *)
(i :: SubprocMode -> *) a (es :: [SubprocMode -> Effect])
(r :: [Effect]) (ff :: Effect) (c :: (* -> *) -> Constraint).
(WeakenExps r, UnliftBase b :> r, Emb b :> RemoveExps r,
KnownLength es, Free c ff) =>
(forall (s :: SubprocMode) x.
i s
-> Eff ff (Each es s ++ (Scoped ff t i es (RemoveExps r) : r)) x
-> Eff ff (Scoped ff t i es (RemoveExps r) : r) (t s x))
-> Eff ff (Scoped ff t i es (RemoveExps r) : r) a -> Eff ff r a
runRegionScoped @IO \cp :: CreateProcess s
cp@CreateProcess {LifecycleMode lp
subprocLifecycle :: LifecycleMode lp
subprocLifecycle :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
subprocLifecycle, LifecycleMode ls
scopeLifecycle :: LifecycleMode ls
scopeLifecycle :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
scopeLifecycle} Eff
Freer
(Each '[Subprocess] s
++ (Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
x
m ->
((Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
~> IO)
-> IO (SubprocResult s x))
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
(SubprocResult s x)
forall (es :: [Effect]) (ff :: Effect) a
(c :: (* -> *) -> Constraint).
(UnliftIO :> es, Free c ff) =>
((Eff ff es ~> IO) -> IO a) -> Eff ff es a
withRunInIO \Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
~> IO
run -> do
(Maybe Handle
hi, Maybe Handle
ho, Maybe Handle
he, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Raw.createProcess (CreateProcess s -> CreateProcess
forall (stdio :: SubprocMode). CreateProcess stdio -> CreateProcess
toRawCreateProcess CreateProcess s
cp) IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. a -> (a -> b) -> b
& IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
TMVar ExitCode
procStatus <- IO (TMVar ExitCode)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
TMVar x
scopeStatus <- IO (TMVar x)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
((forall a. IO a -> IO a) -> IO (SubprocResult s x))
-> IO (SubprocResult s x)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask \forall a. IO a -> IO a
restore -> do
let
runThread :: TMVar a -> IO a -> IO ThreadId
runThread :: forall a. TMVar a -> IO a -> IO ThreadId
runThread TMVar a
var IO a
a = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
var (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
a
ThreadId
tScope <- TMVar x -> IO x -> IO ThreadId
forall a. TMVar a -> IO a -> IO ThreadId
runThread TMVar x
scopeStatus (IO x -> IO ThreadId) -> IO x -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO x -> IO x
forall a. IO a -> IO a
restore (IO x -> IO x)
-> (Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> IO x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> IO x
Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
~> IO
run (Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> IO x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> IO x
forall a b. (a -> b) -> a -> b
$ do
Eff
Freer
(Subprocess ('SubprocMode i o e lp ls)
: Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
Eff
Freer
(Each '[Subprocess] s
++ (Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
x
m
Eff
Freer
(Subprocess ('SubprocMode i o e lp ls)
: Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> (Eff
Freer
(Subprocess ('SubprocMode i o e lp ls)
: Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a b. a -> (a -> b) -> b
& (Subprocess ('SubprocMode i o e lp ls)
~~> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
-> Eff
Freer
(Subprocess ('SubprocMode i o e lp ls)
: Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
(c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
WriteStdin ByteString
s -> Handle -> ByteString -> IO ()
hPut (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
hi) ByteString
s IO ()
-> (IO ()
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a b. a -> (a -> b) -> b
& IO ()
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
IO ()
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
()
forall a.
IO a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
TryWriteStdin ByteString
s -> do
Maybe ExitCode
stat <- STM (Maybe ExitCode)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
(Maybe ExitCode)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ExitCode)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
(Maybe ExitCode))
-> STM (Maybe ExitCode)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
(Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM (Maybe ExitCode)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ExitCode
procStatus
if Maybe ExitCode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ExitCode
stat
then do
Handle -> ByteString -> IO ()
hPut (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
hi) ByteString
s IO ()
-> (IO ()
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
())
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
()
forall a b. a -> (a -> b) -> b
& IO ()
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
()
forall a.
IO a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a.
a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
Bool
True
else x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a.
a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
Bool
False
Subprocess
('SubprocMode i o e lp ls)
(Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
x
ReadStdout -> Handle -> IO ByteString
hRead (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
ho) IO ByteString
-> (IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a b. a -> (a -> b) -> b
& IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
ByteString
forall a.
IO a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
Subprocess
('SubprocMode i o e lp ls)
(Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
x
ReadStderr -> Handle -> IO ByteString
hRead (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
he) IO ByteString
-> (IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x)
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a b. a -> (a -> b) -> b
& IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
IO ByteString
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
ByteString
forall a.
IO a
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
Subprocess
('SubprocMode i o e lp ls)
(Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es))
x
PollSubproc -> STM x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x)
-> STM x
-> Eff
Freer
(Scope
SubprocResult
CreateProcess
(ScopeC
Freer SubprocResult CreateProcess '[Subprocess] (RemoveExps es))
: es)
x
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM (Maybe ExitCode)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ExitCode
procStatus
ThreadId
_ <- TMVar ExitCode -> IO ExitCode -> IO ThreadId
forall a. TMVar a -> IO a -> IO ThreadId
runThread TMVar ExitCode
procStatus (IO ExitCode -> IO ThreadId) -> IO ExitCode -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
ph
IO (SubprocResult s x) -> IO ExitCode -> IO (SubprocResult s x)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally
case (LifecycleMode lp
subprocLifecycle, LifecycleMode ls
scopeLifecycle) of
(LifecycleMode lp
WaitMode, LifecycleMode ls
WaitMode) ->
(ExitCode -> x -> SubprocResult s x)
-> IO ExitCode -> IO x -> IO (SubprocResult s x)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
ExitCode -> x -> SubprocResult s x
ExitCode -> x -> SubprocResult ('SubprocMode i o e 'Wait 'Wait) x
forall a (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode).
ExitCode -> a -> SubprocResult ('SubprocMode o e lp 'Wait 'Wait) a
SubprocScopeResult
(STM ExitCode -> IO ExitCode
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ExitCode -> IO ExitCode) -> STM ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM ExitCode
forall a. TMVar a -> STM a
readTMVar TMVar ExitCode
procStatus)
(STM x -> IO x
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM x -> IO x) -> STM x -> IO x
forall a b. (a -> b) -> a -> b
$ TMVar x -> STM x
forall a. TMVar a -> STM a
readTMVar TMVar x
scopeStatus)
(LifecycleMode lp
WaitMode, LifecycleMode ls
KillMode) -> do
ExitCode
exitCode <- STM ExitCode -> IO ExitCode
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ExitCode -> IO ExitCode) -> STM ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM ExitCode
forall a. TMVar a -> STM a
readTMVar TMVar ExitCode
procStatus
Maybe x
scopeResult <- STM (Maybe x) -> IO (Maybe x)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe x) -> IO (Maybe x)) -> STM (Maybe x) -> IO (Maybe x)
forall a b. (a -> b) -> a -> b
$ TMVar x -> STM (Maybe x)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar x
scopeStatus
SubprocResult s x -> IO (SubprocResult s x)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubprocResult s x -> IO (SubprocResult s x))
-> SubprocResult s x -> IO (SubprocResult s x)
forall a b. (a -> b) -> a -> b
$ ExitCode
-> Maybe x -> SubprocResult ('SubprocMode i o e 'Wait 'Kill) x
forall a (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode).
ExitCode
-> Maybe a -> SubprocResult ('SubprocMode o e lp 'Wait 'Kill) a
SubprocResult ExitCode
exitCode Maybe x
scopeResult
(LifecycleMode lp
KillMode, LifecycleMode ls
WaitMode) -> do
x
scopeResult <- STM x -> IO x
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM x -> IO x) -> STM x -> IO x
forall a b. (a -> b) -> a -> b
$ TMVar x -> STM x
forall a. TMVar a -> STM a
readTMVar TMVar x
scopeStatus
Maybe ExitCode
exitCode <- STM (Maybe ExitCode) -> IO (Maybe ExitCode)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ExitCode) -> IO (Maybe ExitCode))
-> STM (Maybe ExitCode) -> IO (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM (Maybe ExitCode)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ExitCode
procStatus
SubprocResult s x -> IO (SubprocResult s x)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubprocResult s x -> IO (SubprocResult s x))
-> SubprocResult s x -> IO (SubprocResult s x)
forall a b. (a -> b) -> a -> b
$ Maybe ExitCode
-> x -> SubprocResult ('SubprocMode i o e 'Kill 'Wait) x
forall a (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode).
Maybe ExitCode
-> a -> SubprocResult ('SubprocMode o e lp 'Kill 'Wait) a
ScopeResult Maybe ExitCode
exitCode x
scopeResult
(LifecycleMode lp
KillMode, LifecycleMode ls
KillMode) ->
Either ExitCode x -> SubprocResult s x
Either ExitCode x
-> SubprocResult ('SubprocMode i o e 'Kill 'Kill) x
forall a (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode).
Either ExitCode a
-> SubprocResult ('SubprocMode o e lp 'Kill 'Kill) a
RaceResult
(Either ExitCode x -> SubprocResult s x)
-> IO (Either ExitCode x) -> IO (SubprocResult s x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Either ExitCode x) -> IO (Either ExitCode x)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically
( (ExitCode -> Either ExitCode x
forall a b. a -> Either a b
Left (ExitCode -> Either ExitCode x)
-> STM ExitCode -> STM (Either ExitCode x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar ExitCode -> STM ExitCode
forall a. TMVar a -> STM a
readTMVar TMVar ExitCode
procStatus)
STM (Either ExitCode x)
-> STM (Either ExitCode x) -> STM (Either ExitCode x)
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (x -> Either ExitCode x
forall a b. b -> Either a b
Right (x -> Either ExitCode x) -> STM x -> STM (Either ExitCode x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar x -> STM x
forall a. TMVar a -> STM a
readTMVar TMVar x
scopeStatus)
)
do
IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
uninterruptibleMask_ do
ProcessHandle -> IO ()
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ()
terminateProcess ProcessHandle
ph
ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread ThreadId
tScope
STM ExitCode -> IO ExitCode
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ExitCode -> IO ExitCode) -> STM ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ TMVar ExitCode -> STM ExitCode
forall a. TMVar a -> STM a
readTMVar TMVar ExitCode
procStatus
hRead :: Handle -> IO ByteString
hRead :: Handle -> IO ByteString
hRead Handle
h = (((ByteString -> IO ByteString) -> ByteString -> IO ByteString)
-> ByteString -> IO ByteString)
-> ByteString
-> ((ByteString -> IO ByteString) -> ByteString -> IO ByteString)
-> IO ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ByteString -> IO ByteString) -> ByteString -> IO ByteString)
-> ByteString -> IO ByteString
forall a. (a -> a) -> a
fix ByteString
BS.empty \ByteString -> IO ByteString
next ByteString
acc -> do
ByteString
s <- Handle -> Int -> IO ByteString
hGet Handle
h Int
chunkSize
if ByteString -> Bool
BS.null ByteString
s
then ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
acc
else ByteString -> IO ByteString
next (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
s
chunkSize :: Int
chunkSize :: Int
chunkSize = Int
4096
data CreateProcess p where
CreateProcess
:: { forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> CmdSpec
cmdspec :: CmdSpec
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream o
stdin :: StdStream i
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream e
stdout :: StdStream o
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream lp
stderr :: StdStream e
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
subprocLifecycle :: LifecycleMode lp
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
scopeLifecycle :: LifecycleMode ls
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe String
cwd :: Maybe FilePath
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls)
-> Maybe [(String, String)]
env :: Maybe [(String, String)]
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
closeFds :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
createGroup :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
delegateCtlc :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
detachConsole :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
createNewConsole :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
newSession :: Bool
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe GroupID
childGroup :: Maybe GroupID
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe UserID
childUser :: Maybe UserID
, forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
useProcessJobs :: Bool
}
-> CreateProcess ('SubprocMode i o e lp ls)
data StdStream s where
CreatePipe :: StdStream 'Piped
Inherit :: StdStream 'NoPipe
UseHandle
:: Handle
-> StdStream 'NoPipe
NoStream :: StdStream 'NoPipe
data LifecycleMode t where
KillMode :: LifecycleMode 'Kill
WaitMode :: LifecycleMode 'Wait
process :: FilePath -> [String] -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
process :: String
-> [String]
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
process String
cmd [String]
args = CmdSpec
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
command (CmdSpec
-> CreateProcess
('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait))
-> CmdSpec
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CmdSpec
RawCommand String
cmd [String]
args
shell :: String -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
shell :: String
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
shell = CmdSpec
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
command (CmdSpec
-> CreateProcess
('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait))
-> (String -> CmdSpec)
-> String
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CmdSpec
ShellCommand
command :: CmdSpec -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
command :: CmdSpec
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
command CmdSpec
cmdspec = CmdSpec
-> StdStream 'NoPipe
-> StdStream 'NoPipe
-> StdStream 'NoPipe
-> LifecycleMode 'Wait
-> LifecycleMode 'Wait
-> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)
forall (i :: StreamMode) (o :: StreamMode) (e :: StreamMode)
(lp :: Lifecycle) (ls :: Lifecycle).
CmdSpec
-> StdStream i
-> StdStream o
-> StdStream e
-> LifecycleMode lp
-> LifecycleMode ls
-> CreateProcess ('SubprocMode i o e lp ls)
commandWith CmdSpec
cmdspec StdStream 'NoPipe
Inherit StdStream 'NoPipe
Inherit StdStream 'NoPipe
Inherit LifecycleMode 'Wait
WaitMode LifecycleMode 'Wait
WaitMode
commandWith
:: CmdSpec
-> StdStream i
-> StdStream o
-> StdStream e
-> LifecycleMode lp
-> LifecycleMode ls
-> CreateProcess ('SubprocMode i o e lp ls)
commandWith :: forall (i :: StreamMode) (o :: StreamMode) (e :: StreamMode)
(lp :: Lifecycle) (ls :: Lifecycle).
CmdSpec
-> StdStream i
-> StdStream o
-> StdStream e
-> LifecycleMode lp
-> LifecycleMode ls
-> CreateProcess ('SubprocMode i o e lp ls)
commandWith CmdSpec
cmdspec StdStream i
stdin StdStream o
stdout StdStream e
stderr LifecycleMode lp
subprocLifecycle LifecycleMode ls
scopeLifecycle =
CreateProcess
{ cmdspec :: CmdSpec
cmdspec = CmdSpec
cmdspec
, stdin :: StdStream i
stdin = StdStream i
stdin
, stdout :: StdStream o
stdout = StdStream o
stdout
, stderr :: StdStream e
stderr = StdStream e
stderr
, LifecycleMode lp
subprocLifecycle :: LifecycleMode lp
subprocLifecycle :: LifecycleMode lp
subprocLifecycle
, LifecycleMode ls
scopeLifecycle :: LifecycleMode ls
scopeLifecycle :: LifecycleMode ls
scopeLifecycle
, cwd :: Maybe String
cwd = Maybe String
forall a. Maybe a
Nothing
, env :: Maybe [(String, String)]
env = Maybe [(String, String)]
forall a. Maybe a
Nothing
, closeFds :: Bool
closeFds = Bool
False
, createGroup :: Bool
createGroup = Bool
False
, delegateCtlc :: Bool
delegateCtlc = Bool
False
, detachConsole :: Bool
detachConsole = Bool
False
, createNewConsole :: Bool
createNewConsole = Bool
False
, newSession :: Bool
newSession = Bool
False
, childGroup :: Maybe GroupID
childGroup = Maybe GroupID
forall a. Maybe a
Nothing
, childUser :: Maybe UserID
childUser = Maybe UserID
forall a. Maybe a
Nothing
, useProcessJobs :: Bool
useProcessJobs = Bool
False
}
toRawCreateProcess :: CreateProcess stdio -> Raw.CreateProcess
toRawCreateProcess :: forall (stdio :: SubprocMode). CreateProcess stdio -> CreateProcess
toRawCreateProcess (CreateProcess {Bool
Maybe String
Maybe [(String, String)]
Maybe UserID
Maybe GroupID
CmdSpec
LifecycleMode lp
LifecycleMode ls
StdStream i
StdStream o
StdStream e
subprocLifecycle :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
scopeLifecycle :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> LifecycleMode ls
cmdspec :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> CmdSpec
cwd :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe String
stdin :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream o
stdout :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream e
stderr :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> StdStream lp
env :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls)
-> Maybe [(String, String)]
closeFds :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
createGroup :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
delegateCtlc :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
detachConsole :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
createNewConsole :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
newSession :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
childGroup :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe GroupID
childUser :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Maybe UserID
useProcessJobs :: forall (o :: StreamMode) (e :: StreamMode) (lp :: StreamMode)
(ls :: Lifecycle) (ls :: Lifecycle).
CreateProcess ('SubprocMode o e lp ls ls) -> Bool
cmdspec :: CmdSpec
stdin :: StdStream i
stdout :: StdStream o
stderr :: StdStream e
subprocLifecycle :: LifecycleMode lp
scopeLifecycle :: LifecycleMode ls
cwd :: Maybe String
env :: Maybe [(String, String)]
closeFds :: Bool
createGroup :: Bool
delegateCtlc :: Bool
detachConsole :: Bool
createNewConsole :: Bool
newSession :: Bool
childGroup :: Maybe GroupID
childUser :: Maybe UserID
useProcessJobs :: Bool
..}) =
Raw.CreateProcess
{ cmdspec :: CmdSpec
cmdspec = CmdSpec
cmdspec
, cwd :: Maybe String
cwd = Maybe String
cwd
, env :: Maybe [(String, String)]
env = Maybe [(String, String)]
env
, std_in :: StdStream
std_in = StdStream i -> StdStream
forall (pipe :: StreamMode). StdStream pipe -> StdStream
toRawStdStream StdStream i
stdin
, std_out :: StdStream
std_out = StdStream o -> StdStream
forall (pipe :: StreamMode). StdStream pipe -> StdStream
toRawStdStream StdStream o
stdout
, std_err :: StdStream
std_err = StdStream e -> StdStream
forall (pipe :: StreamMode). StdStream pipe -> StdStream
toRawStdStream StdStream e
stderr
, close_fds :: Bool
close_fds = Bool
closeFds
, create_group :: Bool
create_group = Bool
createGroup
, delegate_ctlc :: Bool
delegate_ctlc = Bool
delegateCtlc
, detach_console :: Bool
detach_console = Bool
detachConsole
, create_new_console :: Bool
create_new_console = Bool
createNewConsole
, new_session :: Bool
new_session = Bool
newSession
, child_group :: Maybe GroupID
child_group = Maybe GroupID
childGroup
, child_user :: Maybe UserID
child_user = Maybe UserID
childUser
, use_process_jobs :: Bool
use_process_jobs = Bool
useProcessJobs
}
toRawStdStream :: StdStream pipe -> Raw.StdStream
toRawStdStream :: forall (pipe :: StreamMode). StdStream pipe -> StdStream
toRawStdStream = \case
StdStream pipe
CreatePipe -> StdStream
Raw.CreatePipe
StdStream pipe
Inherit -> StdStream
Raw.Inherit
UseHandle Handle
h -> Handle -> StdStream
Raw.UseHandle Handle
h
StdStream pipe
NoStream -> StdStream
Raw.NoStream