Block terminal

This commit is contained in:
Filip Gralinski 2018-11-17 10:07:59 +01:00
parent 62e282f136
commit 879eb4e044

View File

@ -4,6 +4,7 @@ module Handler.Runner where
import Import import Import
import System.Process import System.Process
import System.Exit import System.Exit
import System.Environment
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Lifted (threadDelay) import Control.Concurrent.Lifted (threadDelay)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -83,9 +84,13 @@ runProg workingDir programPath args = Runner {
runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text) runProgram :: Maybe FilePath -> FilePath -> [String] -> Channel -> Handler (ExitCode, Text)
runProgram workingDir programPath args chan = do runProgram workingDir programPath args chan = do
env <- liftIO $ getEnvironment
(_, Just hout, Just herr, pid) <- (_, Just hout, Just herr, pid) <-
liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, liftIO $ createProcess (proc programPath args){
std_out = CreatePipe,
std_err = 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} cwd = workingDir}
(code, out) <- gatherOutput pid hout herr chan (code, out) <- gatherOutput pid hout herr chan
_ <- liftIO $ waitForProcess pid _ <- liftIO $ waitForProcess pid