{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
module Foreign.Nix.Shellout.Helpers where
import Foreign.Nix.Shellout.Types ( NixActionError(..), RunOptions (logFn, executables), LogFn (LogFn), NixAction, Executables )
import qualified System.Process as P
import qualified Data.Text.IO as TIO
import qualified Data.Text as T
import qualified System.IO as SIO
import GHC.IO.Exception (IOErrorType(..), IOException(..), ExitCode)
import Foreign.C.Error (Errno(Errno), ePIPE)
import Data.Text (Text)
import Control.Error (ExceptT, runExceptT)
import Control.Concurrent (MVar, newEmptyMVar, forkIO, takeMVar, putMVar, killThread)
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, throwIO, onException, try, mask, handle, evaluate)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Data.Text as Text
import Control.Monad.Except (MonadError (throwError))
import Control.Monad.Reader (asks)
import Control.Monad.Trans (lift)
import Data.Function ((&))
data Executable =
ExeFromPathEnv Text
| ExeFromFilePath FilePath
getExecOr :: Monad m => (Executables -> Maybe FilePath) -> Text -> NixAction e m Executable
getExecOr :: (Executables -> Maybe FilePath) -> Text -> NixAction e m Executable
getExecOr Executables -> Maybe FilePath
getter Text
exeName =
let f :: Maybe FilePath -> Executable
f = \case
Maybe FilePath
Nothing -> Text -> Executable
ExeFromPathEnv Text
exeName
Just FilePath
fp -> FilePath -> Executable
ExeFromFilePath FilePath
fp
in (RunOptions m -> Executable) -> NixAction e m Executable
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Maybe FilePath -> Executable
f (Maybe FilePath -> Executable)
-> (RunOptions m -> Maybe FilePath) -> RunOptions m -> Executable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executables -> Maybe FilePath
getter (Executables -> Maybe FilePath)
-> (RunOptions m -> Executables) -> RunOptions m -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunOptions m -> Executables
forall (m :: * -> *). RunOptions m -> Executables
executables)
readProcess :: (MonadIO m)
=> ((Text, Text) -> ExitCode -> ExceptT e m a)
-> Executable
-> [Text]
-> NixAction e m a
readProcess :: ((Text, Text) -> ExitCode -> ExceptT e m a)
-> Executable -> [Text] -> NixAction e m a
readProcess (Text, Text) -> ExitCode -> ExceptT e m a
with Executable
exec [Text]
args = do
let exec' :: Text
exec' = case Executable
exec of
ExeFromPathEnv Text
name -> Text
name
ExeFromFilePath FilePath
fp -> FilePath
fp FilePath -> (FilePath -> Text) -> Text
forall a b. a -> (a -> b) -> b
& FilePath -> Text
Text.pack
(LogFn Text -> [Text] -> m ()
l) <- (RunOptions m -> LogFn m) -> NixAction e m (LogFn m)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunOptions m -> LogFn m
forall (m :: * -> *). RunOptions m -> LogFn m
logFn
m () -> NixAction e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> NixAction e m ()) -> m () -> NixAction e m ()
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> m ()
l Text
exec' [Text]
args
(ExitCode
exc, Text
out, Text
err) <- IO (ExitCode, Text, Text) -> NixAction e m (ExitCode, Text, Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO (ExitCode, Text, Text) -> NixAction e m (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
-> NixAction e m (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> TextEncoding -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCodeAndEncoding
(FilePath -> [FilePath] -> CreateProcess
P.proc (Text -> FilePath
Text.unpack Text
exec') ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Text.unpack [Text]
args)) TextEncoding
SIO.utf8 Text
""
m (Either e a) -> NixAction e m (Either e a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((Text, Text) -> ExitCode -> ExceptT e m a
with (Text
out, Text
err) ExitCode
exc)) NixAction e m (Either e a)
-> (Either e a -> NixAction e m a) -> NixAction e m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e
e ->
NixActionError e -> NixAction e m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NixActionError e -> NixAction e m a)
-> NixActionError e -> NixAction e m a
forall a b. (a -> b) -> a -> b
$ NixActionError :: forall e. Text -> e -> NixActionError e
NixActionError
{ actionStderr :: Text
actionStderr = Text
err
, actionError :: e
actionError = e
e }
Right a
a -> a -> NixAction e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
readCreateProcessWithExitCodeAndEncoding
:: P.CreateProcess
-> SIO.TextEncoding
-> Text
-> IO (ExitCode, Text, Text)
readCreateProcessWithExitCodeAndEncoding :: CreateProcess -> TextEncoding -> Text -> IO (ExitCode, Text, Text)
readCreateProcessWithExitCodeAndEncoding CreateProcess
cp TextEncoding
encoding Text
input = do
let cp_opts :: CreateProcess
cp_opts = CreateProcess
cp
{ std_in :: StdStream
P.std_in = StdStream
P.CreatePipe
, std_out :: StdStream
P.std_out = StdStream
P.CreatePipe
, std_err :: StdStream
P.std_err = StdStream
P.CreatePipe }
CreateProcess
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
P.withCreateProcess CreateProcess
cp_opts ((Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text))
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$
\(Just Handle
inh) (Just Handle
outh) (Just Handle
errh) ProcessHandle
ph -> do
Handle -> TextEncoding -> IO ()
SIO.hSetEncoding Handle
outh TextEncoding
encoding
Handle -> TextEncoding -> IO ()
SIO.hSetEncoding Handle
errh TextEncoding
encoding
Handle -> TextEncoding -> IO ()
SIO.hSetEncoding Handle
inh TextEncoding
encoding
Text
out <- Handle -> IO Text
TIO.hGetContents Handle
outh
Text
err <- Handle -> IO Text
TIO.hGetContents Handle
errh
IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ()
forall a. NFData a => a -> ()
rnf Text
out) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitOut ->
IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ()
forall a. NFData a => a -> ()
rnf Text
err) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitErr -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
input) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
TIO.hPutStr Handle
inh Text
input
IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
SIO.hClose Handle
inh
IO ()
waitOut
IO ()
waitErr
Handle -> IO ()
SIO.hClose Handle
outh
Handle -> IO ()
SIO.hClose Handle
errh
ExitCode
ex <- ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
ph
(ExitCode, Text, Text) -> IO (ExitCode, Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, Text
out, Text
err)
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait IO ()
async IO () -> IO a
body = do
MVar (Either SomeException ())
waitVar <- IO (MVar (Either SomeException ()))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (Either SomeException ()))
((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
async) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException ()) -> Either SomeException () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ())
waitVar
let wait :: IO ()
wait = MVar (Either SomeException ()) -> IO (Either SomeException ())
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException ())
waitVar IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return
IO a -> IO a
forall a. IO a -> IO a
restore (IO () -> IO a
body IO ()
wait) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` ThreadId -> IO ()
killThread ThreadId
tid
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
IOError { ioe_type :: IOException -> IOErrorType
ioe_type = IOErrorType
ResourceVanished
, ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe }
| CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IOException
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e