155 lines
4.7 KiB
Haskell
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
|