module Shellout
(Driver(..), Shell, TaskName, Cmd, new)
where
import Control.Concurrent (MVar, newEmptyMVar, putMVar,
takeMVar)
import Control.Concurrent.Async (Async, async, link)
import Control.Concurrent.STM (TQueue, atomically, newTQueue,
readTQueue, tryReadTQueue,
writeTQueue)
import Control.Monad (unless)
import Data.Text (Text, unpack)
import Data.Text.IO (hGetLine)
import GHC.IO.Handle (Handle)
import System.Exit (ExitCode (..), exitWith)
import System.IO (hIsEOF)
import System.Process.Typed (closed, createPipe, getStderr,
getStdout, setStderr, setStdin,
setStdout, shell, waitExitCode,
withProcess)
data Driver a = Driver
{
initialState :: Text -> a
, handleNothing :: a -> IO a
, handleOut :: a -> Text -> IO a
, handleErr :: a -> Text -> IO a
, handleSuccess :: a -> IO ()
, handleFailure :: a -> IO ()
}
data Output = Msg Text | Err Text | Success | Failure Int
data Processor = Processor (TQueue Text) (TQueue Output)
type Shell = (TaskName -> Cmd -> IO ())
type TaskName = Text
type Cmd = Text
new :: Driver a -> IO Shell
new driver = do
processor <- Processor <$> newChan <*> newChan
_ <- spawn $ processorLoop processor
pure $ execute processor driver
where newChan = atomically newTQueue
execute :: forall a. Processor -> Driver a -> TaskName -> Cmd -> IO ()
execute (Processor input output) driver task cmd = do
send input cmd
loop (initialState driver task)
where
maybeReceive = atomically . tryReadTQueue
loop :: a -> IO ()
loop acc = do
out <- maybeReceive output
case out of
Nothing -> do
newAcc <- handleNothing driver acc
loop newAcc
Just (Msg msg) -> do
newAcc <- handleOut driver acc msg
loop newAcc
Just (Err msg) -> do
newAcc <- handleErr driver acc msg
loop newAcc
Just Success ->
handleSuccess driver acc
Just (Failure c) -> do
handleFailure driver acc
exitWith $ ExitFailure c
processorLoop :: Processor -> IO ()
processorLoop processor@(Processor input output) = do
cmd <- atomically $ readTQueue input
let config = setStdin closed
$ setStdout createPipe
$ setStderr createPipe
$ shell (unpack cmd)
withProcess config $ \p -> do
stdoutLock <- newEmptyMVar
stderrLock <- newEmptyMVar
_ <- spawn $ sendOutput Msg (getStdout p) stdoutLock
_ <- spawn $ sendOutput Err (getStderr p) stderrLock
code <- waitExitCode p
takeMVar stdoutLock
takeMVar stderrLock
let result = case code of
ExitSuccess -> Success
ExitFailure i -> Failure i
send output result
processorLoop processor
where
sendOutput :: (Text -> Output) -> Handle -> MVar () -> IO ()
sendOutput wrap handle lock = do
let loop = do
isDone <- hIsEOF handle
unless isDone $ do
out <- hGetLine handle
send output $ wrap out
loop
loop
putMVar lock ()
spawn :: IO a -> IO (Async a)
spawn x = do
thread <- async x
link thread
pure thread
send :: TQueue a -> a -> IO ()
send x = atomically . writeTQueue x