gonito/Handler/Runner.hs
2021-03-01 08:07:06 +01:00

155 lines
4.7 KiB
Haskell

module Handler.Runner where
import Import
import qualified System.IO as SIO
import System.Process
import System.Exit
import System.Environment
import Control.Concurrent.STM
import Control.Concurrent.Lifted (threadDelay)
import qualified Data.ByteString as BS
import Control.Monad.IO.Class
type Channel = TChan (Maybe Text)
data RunnerStatus a = RunnerOK a | RunnerError ExitCode
newtype Runner a = Runner { runRunner :: Channel -> Handler (RunnerStatus a) }
getChannel :: Runner Channel
getChannel = Runner {
runRunner = \chan -> return $ RunnerOK chan
}
instance Functor Runner where
fmap f runner = Runner {
runRunner = \chan -> do
s <- (runRunner runner) chan
return $ case s of
RunnerOK v -> RunnerOK $ f v
RunnerError e -> RunnerError e
}
instance Applicative Runner where
pure v = Runner {
runRunner = \_ -> return $ RunnerOK v
}
liftA2 f runner1 runner2 = Runner {
runRunner = \chan -> do
s1 <- (runRunner runner1) chan
case s1 of
RunnerOK v1 -> do
s2 <- (runRunner runner2) chan
case s2 of
RunnerOK v2 -> return $ RunnerOK $ f v1 v2
RunnerError e -> return $ RunnerError e
RunnerError e -> return $ RunnerError e
}
instance Monad Runner where
runner >>= k = Runner {
runRunner = \chan -> do
s <- (runRunner runner) chan
case s of
RunnerError e -> return $ RunnerError e
RunnerOK v -> do
sn <- (runRunner (k v)) chan
return $ case sn of
RunnerError e -> RunnerError e
RunnerOK w -> RunnerOK w
}
instance MonadIO Runner where
liftIO action = Runner {
runRunner = \_ -> do
r <- liftIO action
return $ RunnerOK r
}
runWithChannel :: Channel -> Runner () -> Handler ExitCode
runWithChannel chan runner = do
s <- (runRunner runner) chan
return $ case s of
RunnerOK () -> ExitSuccess
RunnerError e -> e
runProg :: Maybe FilePath -> FilePath -> [String] -> Runner ()
runProg workingDir programPath args = Runner {
runRunner = \chan -> do
(code, _) <- runProgram workingDir programPath args chan
case code of
ExitSuccess -> return $ RunnerOK ()
_ -> return $ RunnerError code
}
runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
runProgram workingDir programPath args chan = do
env <- liftIO $ getEnvironment
(_, Just hout, Just herr, pid) <-
liftIO $ createProcess (proc programPath args){
std_out = CreatePipe,
std_err = CreatePipe,
-- https://serverfault.com/questions/544156/git-clone-fail-instead-of-prompting-for-credentials
env = Just (("GIT_TERMINAL_PROMPT", "0") : env),
cwd = workingDir}
(code, out) <- gatherOutput pid hout herr chan
_ <- liftIO $ waitForProcess pid
return (code, out)
gatherOutput :: ProcessHandle -> Handle -> Handle -> Channel -> Handler (ExitCode, Text)
gatherOutput ph hout herr chan = work mempty mempty
where
work accout accerr = do
-- Read any outstanding input.
resterr <- takeABit herr accerr
restout <- takeABit hout accout
liftIO $ threadDelay 1000000
-- Check on the process.
s <- liftIO $ getProcessExitCode ph
-- Exit or loop.
case s of
Nothing -> work restout resterr
Just ec -> do
-- Get any last bit written between the read and the status
-- check.
_ <- takeFinalBit herr resterr
allTheRest <- takeFinalBit hout restout
return (ec, allTheRest)
takeABit h acc = do
bs <- liftIO $ BS.hGetNonBlocking h (64 * 1024)
let acc' = acc <> (decodeUtf8 bs)
let (fullLines, rest) = processOutput acc'
mapM_ (msg chan) fullLines
return rest
takeFinalBit h rest = do
lastPart <- liftIO $ BS.hGetContents h
let allTheRest = rest <> (decodeUtf8 lastPart)
mapM_ (msg chan) $ lines allTheRest
return allTheRest
msg :: Channel -> Text -> Handler ()
msg chan m = do
liftIO $ SIO.hPutStrLn stderr (unpack m)
liftIO $ atom $ writeTChan chan $ Just (m ++ "\n")
err :: Channel -> Text -> Handler ()
err = msg
raw :: Channel -> Text -> Handler ()
raw = msg
atom = Control.Concurrent.STM.atomically
processOutput :: Text -> ([Text], Text)
processOutput = processOutput' . lines
where processOutput' [] = ([], "")
processOutput' out = (init out, last out)
init [] = []
init [x] = []
init (x:xs) = (x:(init xs))
last [x] = x
last (_:xs) = last xs