module HaskellWorks.Polysemy.Hedgehog.Process
( defaultExecConfig
, execFlex
, execFlexOk
, execFlexOk'
, execOk
, execOk_
, exec
, procFlex
, procFlex'
, binFlex
, waitSecondsForProcess
, waitSecondsForProcessOk
) where
import qualified Control.Concurrent as IO
import qualified Control.Concurrent.Async as IO
import Data.Monoid (Last (..))
import GHC.Stack (callStack)
import qualified HaskellWorks.IO.Process as IO
import HaskellWorks.Polysemy.Cabal
import HaskellWorks.Polysemy.Error.Types
import HaskellWorks.Polysemy.Hedgehog.Assert
import HaskellWorks.Polysemy.Hedgehog.Jot
import HaskellWorks.Polysemy.Hedgehog.Process.Internal
import HaskellWorks.Polysemy.Prelude
import HaskellWorks.Polysemy.System.Environment
import HaskellWorks.Polysemy.System.Process
import qualified Data.List as L
import Polysemy
import Polysemy.Error
import Polysemy.Log
data ExecConfig = ExecConfig
{ ExecConfig -> Last [(String, String)]
execConfigEnv :: Last [(String, String)]
, ExecConfig -> Last String
execConfigCwd :: Last FilePath
} deriving (ExecConfig -> ExecConfig -> Bool
(ExecConfig -> ExecConfig -> Bool)
-> (ExecConfig -> ExecConfig -> Bool) -> Eq ExecConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExecConfig -> ExecConfig -> Bool
== :: ExecConfig -> ExecConfig -> Bool
$c/= :: ExecConfig -> ExecConfig -> Bool
/= :: ExecConfig -> ExecConfig -> Bool
Eq, (forall x. ExecConfig -> Rep ExecConfig x)
-> (forall x. Rep ExecConfig x -> ExecConfig) -> Generic ExecConfig
forall x. Rep ExecConfig x -> ExecConfig
forall x. ExecConfig -> Rep ExecConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExecConfig -> Rep ExecConfig x
from :: forall x. ExecConfig -> Rep ExecConfig x
$cto :: forall x. Rep ExecConfig x -> ExecConfig
to :: forall x. Rep ExecConfig x -> ExecConfig
Generic, Int -> ExecConfig -> ShowS
[ExecConfig] -> ShowS
ExecConfig -> String
(Int -> ExecConfig -> ShowS)
-> (ExecConfig -> String)
-> ([ExecConfig] -> ShowS)
-> Show ExecConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecConfig -> ShowS
showsPrec :: Int -> ExecConfig -> ShowS
$cshow :: ExecConfig -> String
show :: ExecConfig -> String
$cshowList :: [ExecConfig] -> ShowS
showList :: [ExecConfig] -> ShowS
Show)
defaultExecConfig :: ExecConfig
defaultExecConfig :: ExecConfig
defaultExecConfig = ExecConfig
{ execConfigEnv :: Last [(String, String)]
execConfigEnv = Last [(String, String)]
forall a. Monoid a => a
mempty
, execConfigCwd :: Last String
execConfigCwd = Last String
forall a. Monoid a => a
mempty
}
execFlexOk :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> String
-> String
-> [String]
-> Sem r String
execFlexOk :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
String -> String -> [String] -> Sem r String
execFlexOk = ExecConfig -> String -> String -> [String] -> Sem r String
forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig -> String -> String -> [String] -> Sem r String
execFlexOk' ExecConfig
defaultExecConfig
execFlexOk' :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> String
-> [String]
-> Sem r String
execFlexOk' :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig -> String -> String -> [String] -> Sem r String
execFlexOk' ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments = (HasCallStack => Sem r String) -> Sem r String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r String) -> Sem r String)
-> (HasCallStack => Sem r String) -> Sem r String
forall a b. (a -> b) -> a -> b
$ do
(ExitCode
exitResult, String
stdout, String
stderr) <- ExecConfig
-> String -> String -> [String] -> Sem r (ExitCode, String, String)
forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig
-> String -> String -> [String] -> Sem r (ExitCode, String, String)
execFlex ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments
case ExitCode
exitResult of
ExitFailure Int
exitCode -> do
String -> Sem r ()
forall (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
String -> Sem r ()
jot_ (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
L.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[ String
"Process exited with non-zero exit-code: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show @Int Int
exitCode ]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
stdout then [] else [String
"━━━━ stdout ━━━━" , String
stdout])
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
stderr then [] else [String
"━━━━ stderr ━━━━" , String
stderr])
CallStack -> String -> Sem r String
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
callStack String
"Execute process failed"
ExitCode
ExitSuccess -> String -> Sem r String
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout
execFlex :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> String
-> [String]
-> Sem r (ExitCode, String, String)
execFlex :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig
-> String -> String -> [String] -> Sem r (ExitCode, String, String)
execFlex ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments = (HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String))
-> (HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ do
CreateProcess
cp <- ExecConfig -> String -> String -> [String] -> Sem r CreateProcess
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
ExecConfig -> String -> String -> [String] -> Sem r CreateProcess
procFlex' ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments
String -> Sem r ()
forall (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
String -> Sem r ()
jot_ (String -> Sem r ()) -> ShowS -> String -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"━━━━ command ━━━━\n" <>) (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
ShellCommand String
cmd -> String
cmd
RawCommand String
cmd [String]
args -> String
cmd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
L.unwords (ShowS
argQuote ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args)
CreateProcess -> String -> Sem r (ExitCode, String, String)
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r) =>
CreateProcess -> String -> Sem r (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
cp String
""
execOk_ :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> [String]
-> Sem r ()
execOk_ :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig -> String -> [String] -> Sem r ()
execOk_ ExecConfig
execConfig String
bin [String]
arguments = Sem r String -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r String -> Sem r ()) -> Sem r String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ ExecConfig -> String -> [String] -> Sem r String
forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig -> String -> [String] -> Sem r String
execOk ExecConfig
execConfig String
bin [String]
arguments
execOk :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> [String]
-> Sem r String
execOk :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig -> String -> [String] -> Sem r String
execOk ExecConfig
execConfig String
bin [String]
arguments = (HasCallStack => Sem r String) -> Sem r String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r String) -> Sem r String)
-> (HasCallStack => Sem r String) -> Sem r String
forall a b. (a -> b) -> a -> b
$ do
(ExitCode
exitResult, String
stdout, String
stderr) <- ExecConfig
-> String -> [String] -> Sem r (ExitCode, String, String)
forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig
-> String -> [String] -> Sem r (ExitCode, String, String)
exec ExecConfig
execConfig String
bin [String]
arguments
case ExitCode
exitResult of
ExitFailure Int
exitCode ->CallStack -> String -> Sem r String
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
callStack (String -> Sem r String)
-> ([String] -> String) -> [String] -> Sem r String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
L.unlines ([String] -> Sem r String) -> [String] -> Sem r String
forall a b. (a -> b) -> a -> b
$
[ String
"Process exited with non-zero exit-code: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show @Int Int
exitCode ]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
stdout then [] else [String
"━━━━ stdout ━━━━" , String
stdout])
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
stderr then [] else [String
"━━━━ stderr ━━━━" , String
stderr])
ExitCode
ExitSuccess -> String -> Sem r String
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout
exec :: ()
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> [String]
-> Sem r (ExitCode, String, String)
exec :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Hedgehog r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
ExecConfig
-> String -> [String] -> Sem r (ExitCode, String, String)
exec ExecConfig
execConfig String
bin [String]
arguments = (HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String))
-> (HasCallStack => Sem r (ExitCode, String, String))
-> Sem r (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ do
let cp :: CreateProcess
cp = (String -> [String] -> CreateProcess
proc String
bin [String]
arguments)
{ env = getLast $ execConfigEnv execConfig
, cwd = getLast $ execConfigCwd execConfig
}
String -> Sem r ()
forall (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
String -> Sem r ()
jot_ (String -> Sem r ()) -> ShowS -> String -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( String
"━━━━ command ━━━━\n" <>) (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String
bin String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
L.unwords (ShowS
argQuote ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
arguments)
CreateProcess -> String -> Sem r (ExitCode, String, String)
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r) =>
CreateProcess -> String -> Sem r (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
cp String
""
waitSecondsForProcess :: ()
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> Int
-> ProcessHandle
-> Sem r (Either TimedOut (Maybe ExitCode))
waitSecondsForProcess :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
Int -> ProcessHandle -> Sem r (Either TimedOut (Maybe ExitCode))
waitSecondsForProcess Int
seconds ProcessHandle
hProcess = IO (Either TimedOut (Maybe ExitCode))
-> Sem r (Either TimedOut (Maybe ExitCode))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either TimedOut (Maybe ExitCode))
-> Sem r (Either TimedOut (Maybe ExitCode)))
-> IO (Either TimedOut (Maybe ExitCode))
-> Sem r (Either TimedOut (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$
IO TimedOut
-> IO (Maybe ExitCode) -> IO (Either TimedOut (Maybe ExitCode))
forall a b. IO a -> IO b -> IO (Either a b)
IO.race
(Int -> IO ()
IO.threadDelay (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000) IO () -> IO TimedOut -> IO TimedOut
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TimedOut -> IO TimedOut
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TimedOut
TimedOut)
(ProcessHandle -> IO (Maybe ExitCode)
IO.maybeWaitForProcess ProcessHandle
hProcess)
waitSecondsForProcessOk :: ()
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> Int
-> ProcessHandle
-> Sem r (Either TimedOut ExitCode)
waitSecondsForProcessOk :: forall (r :: EffectRow).
(Member Hedgehog r, Member (Embed IO) r,
Member (Error GenericError) r, Member (Error IOException) r,
Member Log r) =>
Int -> ProcessHandle -> Sem r (Either TimedOut ExitCode)
waitSecondsForProcessOk Int
seconds ProcessHandle
hProcess = (HasCallStack => Sem r (Either TimedOut ExitCode))
-> Sem r (Either TimedOut ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (Either TimedOut ExitCode))
-> Sem r (Either TimedOut ExitCode))
-> (HasCallStack => Sem r (Either TimedOut ExitCode))
-> Sem r (Either TimedOut ExitCode)
forall a b. (a -> b) -> a -> b
$ do
Either TimedOut (Maybe ExitCode)
result <- Int -> ProcessHandle -> Sem r (Either TimedOut (Maybe ExitCode))
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
Int -> ProcessHandle -> Sem r (Either TimedOut (Maybe ExitCode))
waitSecondsForProcess Int
seconds ProcessHandle
hProcess
case Either TimedOut (Maybe ExitCode)
result of
Left TimedOut
TimedOut -> do
String -> Sem r ()
forall (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
String -> Sem r ()
jot_ String
"Timed out waiting for process to exit"
Either TimedOut ExitCode -> Sem r (Either TimedOut ExitCode)
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedOut -> Either TimedOut ExitCode
forall a b. a -> Either a b
Left TimedOut
TimedOut)
Right Maybe ExitCode
maybeExitCode -> do
case Maybe ExitCode
maybeExitCode of
Maybe ExitCode
Nothing -> CallStack -> String -> Sem r (Either TimedOut ExitCode)
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
callStack String
"No exit code for process"
Just ExitCode
exitCode -> do
String -> Sem r ()
forall (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
String -> Sem r ()
jot_ (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String
"Process exited " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitCode
Either TimedOut ExitCode -> Sem r (Either TimedOut ExitCode)
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Either TimedOut ExitCode
forall a b. b -> Either a b
Right ExitCode
exitCode)
binFlex :: ()
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> String
-> String
-> Sem r FilePath
binFlex :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
String -> String -> Sem r String
binFlex String
pkg String
binaryEnv = do
Maybe String
maybeEnvBin <- String -> Sem r (Maybe String)
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
String -> Sem r (Maybe String)
lookupEnv String
binaryEnv
case Maybe String
maybeEnvBin of
Just String
envBin -> String -> Sem r String
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return String
envBin
Maybe String
Nothing -> String -> Sem r String
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
String -> Sem r String
binDist String
pkg
procFlex :: ()
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> String
-> String
-> [String]
-> Sem r CreateProcess
procFlex :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
String -> String -> [String] -> Sem r CreateProcess
procFlex = ExecConfig -> String -> String -> [String] -> Sem r CreateProcess
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
ExecConfig -> String -> String -> [String] -> Sem r CreateProcess
procFlex' ExecConfig
defaultExecConfig
procFlex' :: ()
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> ExecConfig
-> String
-> String
-> [String]
-> Sem r CreateProcess
procFlex' :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
ExecConfig -> String -> String -> [String] -> Sem r CreateProcess
procFlex' ExecConfig
execConfig String
pkg String
binaryEnv [String]
arguments = (HasCallStack => Sem r CreateProcess) -> Sem r CreateProcess
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r CreateProcess) -> Sem r CreateProcess)
-> (HasCallStack => Sem r CreateProcess) -> Sem r CreateProcess
forall a b. (a -> b) -> a -> b
$ do
String
bin <- String -> String -> Sem r String
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
String -> String -> Sem r String
binFlex String
pkg String
binaryEnv
CreateProcess -> Sem r CreateProcess
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> CreateProcess
proc String
bin [String]
arguments)
{ env = getLast $ execConfigEnv execConfig
, cwd = getLast $ execConfigCwd execConfig
, create_group = True
}