aboutsummaryrefslogtreecommitdiffstats
path: root/src/Process
diff options
context:
space:
mode:
Diffstat (limited to 'src/Process')
-rw-r--r--src/Process/Shell.hs260
1 files changed, 253 insertions, 7 deletions
diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs
index ffebad5..5b079a9 100644
--- a/src/Process/Shell.hs
+++ b/src/Process/Shell.hs
@@ -9,54 +9,279 @@
module Process.Shell
( sh,
Quotable (..),
+ Outputable (..),
+ Inputable (..),
ExitCodeException (..),
DecodeException (..),
)
where
+import Conduit
import Control.Exception (Exception, throw)
import Control.Monad
-import Control.Monad.Reader
import Data.Aeson
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.ByteString.UTF8 qualified as B
-import Data.Functor.Identity
+import Data.Conduit.Process.Typed
+import Data.Function
import Data.Maybe
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
-import Data.Void
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Quote
-import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char
import Prelude hiding (exp)
data Script = Script (LB.ByteString -> LB.ByteString) String
-class Processable m r where
- sh_ :: m Script -> m r
+class Processable m a where
+ sh_ :: m Script -> m a
instance (MonadIO m) => Processable m () where
sh_ = ((\(Script _ s) -> liftIO (runProcess_ (fromString s))) =<<)
-instance (MonadIO m, Outputable a) => Processable m a where
+instance (MonadIO m, Outputable stdoutAndStderr) => Processable m stdoutAndStderr where
sh_ = ((\(Script strip s) -> fmap (fromLBS . strip) (liftIO (readProcessInterleaved_ (fromString s)))) =<<)
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (stdout, stderr) where
sh_ = ((\(Script stripNL s) -> fmap (\(out, err) -> (fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess_ (fromString s)))) =<<)
+instance (MonadIO m, Outputable stdout) => Processable m (stdout, ()) where
+ sh_ = ((\(Script stripNL s) -> fmap (\out -> (fromLBS (stripNL out), ())) (liftIO (readProcessStdout_ (fromString s)))) =<<)
+
+instance (MonadIO m, Outputable stderr) => Processable m ((), stderr) where
+ sh_ = ((\(Script stripNL s) -> fmap (\err -> ((), fromLBS (stripNL err))) (liftIO (readProcessStderr_ (fromString s)))) =<<)
+
instance (MonadIO m) => Processable m ExitCode where
sh_ = ((\(Script _ s) -> liftIO (runProcess (fromString s))) =<<)
+instance (MonadIO m, Outputable stdoutAndStderr) => Processable m (ExitCode, stdoutAndStderr) where
+ sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, outErr) -> (exitCode, fromLBS (stripNL outErr))) (liftIO (readProcessInterleaved (fromString s)))) =<<)
+
+instance (MonadIO m, Outputable stdout) => Processable m (ExitCode, stdout, ()) where
+ sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, out) -> (exitCode, fromLBS (stripNL out), ())) (liftIO (readProcessStdout (fromString s)))) =<<)
+
+instance (MonadIO m, Outputable stderr) => Processable m (ExitCode, (), stderr) where
+ sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, err) -> (exitCode, (), fromLBS (stripNL err))) (liftIO (readProcessStderr (fromString s)))) =<<)
+
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (ExitCode, stdout, stderr) where
sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, out, err) -> (exitCode, fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess (fromString s)))) =<<)
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stdoutAndStderr, Monoid stdoutAndStderr) =>
+ Processable (ConduitT stdin Void m) stdoutAndStderr
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout createSource
+ & setStderr createSource
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ outErr <-
+ ( mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStdout p >> getStderr p))
+ .| stripC
+ )
+ .| foldC
+ checkExitCode p
+ pure outErr
+ )
+ )
+ =<<
+ )
+
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stdout, Outputable stderr, Monoid stdout, Monoid stderr) =>
+ Processable (ConduitT stdin Void m) (stdout, stderr)
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout createSource
+ & setStderr createSource
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ outErr <-
+ (,)
+ <$> ( ( mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStdout p))
+ .| stripC
+ )
+ .| foldC
+ )
+ <*> ( ( mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStderr p))
+ .| stripC
+ )
+ .| foldC
+ )
+ checkExitCode p
+ pure outErr
+ )
+ )
+ =<<
+ )
+
+instance
+ (Monad m, MonadIO m, MonadResource m, Inputable stdin) =>
+ Processable (ConduitT stdin Void m) ()
+ where
+ sh_ =
+ ( ( \(Script _ s) -> do
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout inherit
+ & setStderr inherit
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ checkExitCode p
+ )
+ )
+ =<<
+ )
+
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stdout, Monoid stdout) =>
+ Processable (ConduitT stdin Void m) (stdout, ())
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout createSource
+ & setStderr inherit
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ out <-
+ ( mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStdout p))
+ .| stripC
+ )
+ .| foldC
+ checkExitCode p
+ pure (out, ())
+ )
+ )
+ =<<
+ )
+
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stderr, Monoid stderr) =>
+ Processable (ConduitT stdin Void m) ((), stderr)
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout inherit
+ & setStderr createSource
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ err <-
+ ( mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStderr p))
+ .| stripC
+ )
+ .| foldC
+ checkExitCode p
+ pure ((), err)
+ )
+ )
+ =<<
+ )
+
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stdoutAndStderr) =>
+ Processable (ConduitT stdin stdoutAndStderr m) ()
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout createSource
+ & setStderr createSource
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ mapOutput fromLBS $
+ mapOutput LB.fromStrict (transPipe liftIO (getStdout p >> getStderr p))
+ .| stripC
+ checkExitCode p
+ )
+ )
+ =<<
+ )
+
+instance
+ (MonadIO m, MonadResource m, Inputable stdin, Outputable stdout, Outputable stderr) =>
+ Processable (ConduitT stdin (Either stderr stdout) m) ()
+ where
+ sh_ =
+ ( ( \(Script strip s) -> do
+ let stripC = awaitForever (\i -> maybe (yield (strip i)) (\_ -> yield i) =<< peekC)
+ bracketP
+ ( startProcess
+ ( fromString s
+ & setStdin createSinkClose
+ & setStdout createSource
+ & setStderr createSource
+ )
+ )
+ stopProcess
+ ( \p -> do
+ awaitForever (yield . LB.toStrict . toLBS) .| transPipe liftIO (getStdin p)
+ transPipe liftIO $ do
+ mapOutput Right (mapOutput fromLBS (mapOutput LB.fromStrict (getStdout p) .| stripC))
+ mapOutput Left (mapOutput fromLBS (mapOutput LB.fromStrict (getStderr p) .| stripC))
+ checkExitCode p
+ )
+ )
+ =<<
+ )
+
class Outputable a where
fromLBS :: LB.ByteString -> a
@@ -75,6 +300,27 @@ instance Outputable T.Text where
instance Outputable LT.Text where
fromLBS = LT.decodeUtf8
+class Inputable a where
+ toLBS :: a -> LB.ByteString
+
+instance Inputable () where
+ toLBS _ = LB.pack ""
+
+instance Inputable String where
+ toLBS = LB.fromString
+
+instance Inputable B.ByteString where
+ toLBS = LB.fromStrict
+
+instance Inputable LB.ByteString where
+ toLBS = id
+
+instance Inputable T.Text where
+ toLBS = LT.encodeUtf8 . LT.fromStrict
+
+instance Inputable LT.Text where
+ toLBS = LT.encodeUtf8
+
data DecodeException = DecodeException String
deriving (Show)
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 04:18:02 +0000