{-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-}
-- A module that handles request running. This is taken out of Server to allow
-- for conditional compilation on non-Unix platforms.
module RequestRunning (runCommand) where
import IdeSession.RPC.API
import IdeSession.GHC.Requests
import GhcMonad(Ghc(..))
#ifdef VERSION_unix
-- Unix specific imports
import System.Posix (createSession)
import System.Posix.Process (forkProcess, getProcessStatus)
import System.Posix.Terminal (openPseudoTerminal)
#ifdef PTY_SUPPORT
import qualified Posix
#endif
-- General imports
import Network
import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId)
import Control.Concurrent.Async (async, withAsync)
import Control.Concurrent.MVar (MVar, newEmptyMVar)
import Control.Monad (void, unless, forever)
import Data.Function (fix)
import Foreign.C.Types (CFile)
import Foreign.Ptr (Ptr, nullPtr)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import System.Environment (withArgs, getEnvironment, setEnv)
import System.IO (Handle, hFlush, hClose, IOMode(..))
import System.IO.Temp (openTempFile)
import System.Mem (performGC)
import qualified Control.Exception as Ex
import qualified Data.ByteString as BSS
import qualified System.Directory as Dir
import qualified GHC
import IdeSession.RPC.Server
import IdeSession.GHC.API
import IdeSession.RPC.Sockets
import IdeSession.Types.Private
import IdeSession.Util
import IdeSession.Util.PortableProcess
import IdeSession.Util.PortableIO
import IdeSession.Util.BlockingOps
import Run
import Auxiliary
import Debug
foreign import ccall "fflush" fflush :: Ptr CFile -> IO ()
#else
import Control.Monad.Trans (liftIO)
import IdeSession.Util
#endif
runCommand :: RpcConversation -> [String] -> FilePath -> RunCmd -> Ghc [String]
#ifndef VERSION_unix
runCommand RpcConversation{..} args _ _ = do
liftIO $ put $ ReqRunUnsupported "Cannot run commands on non-Unix platforms"
return args
#else
runCommand conv args sessionDir runCmd
| runCmdPty runCmd = do
#if PTY_SUPPORT
fds <- liftIO openPseudoTerminal
conversationTuple <- startConcurrentConversation $ \_ _ _ ->
ghcWithArgs args $ ghcHandleRunPtySlave fds runCmd
liftIO $ runPtyMaster fds conversationTuple
rpcConversationTuple conv conversationTuple
return args
#else
--TODO: fail more gracefully than this?
fail "ide-backend-server not build with -DPTY_SUPPORT / pty-support cabal flag"
#endif
| otherwise = do
conversationTuple <- startConcurrentConversation $
ghcConcurrentConversation $ \_errorLog' conv' ->
ghcWithArgs args $ ghcHandleRun conv' runCmd
rpcConversationTuple conv conversationTuple
return args
rpcConversationTuple :: RpcConversation -> (Pid, Socket, Socket, FilePath) -> Ghc ()
rpcConversationTuple RpcConversation{..} (pid, stdin, stdout, errorLogPath) = do
[stdinPort, stdoutPort] <- liftIO $ mapM socketPort [stdin, stdout]
liftIO $ put $ ReqRunConversation pid (WriteChannel stdinPort) (ReadChannel stdoutPort) errorLogPath
-- | Handle a run request
ghcHandleRun :: RpcConversation -> RunCmd -> Ghc ()
ghcHandleRun RpcConversation{..} runCmd = do
(stdOutputRd, stdOutputBackup, stdErrorBackup) <- redirectStdout
(stdInputWr, stdInputBackup) <- redirectStdin
-- We don't need to keep a reference to the reqThread: when the snippet
-- terminates, the whole server process terminates with it and hence
-- so does the reqThread. If we wanted to reuse this server process we
-- would need to have some sort of handshake so make sure that the client
-- and the server both agree that further requests are no longer accepted
-- (we used to do that when we ran snippets inside the main server process).
ghcThread <- liftIO newEmptyMVar :: Ghc (MVar (Maybe ThreadId))
_reqThread <- liftIO . async $ readRunRequests ghcThread stdInputWr
stdoutThread <- liftIO . async $ readStdout stdOutputRd
-- This is a little tricky. We only want to deliver the UserInterrupt
-- exceptions when we are running 'runInGhc'. If the UserInterrupt arrives
-- before we even get a chance to call 'runInGhc' the exception should not
-- be delivered until we are in a position to catch it; after 'runInGhc'
-- completes we should just ignore any further 'GhcRunInterrupt' requests.
--
-- We achieve this by
--
-- 1. The thread ID is stored in an MVar ('ghcThread'). Initially this
-- MVar is empty, so if a 'GhcRunInterrupt' arrives before we are ready
-- to deal with it the 'reqThread' will block
-- 2. We install an exception handler before putting the thread ID into
-- the MVar
-- 3. We override the MVar with Nothing before leaving the exception handler
-- 4. In the 'reqThread' we ignore GhcRunInterrupts once the 'MVar' is
-- 'Nothing'
runOutcome <- ghandle ghcException . ghandleJust isUserInterrupt return $
GHC.gbracket
(liftIO (myThreadId >>= $putMVar ghcThread . Just))
(\() -> liftIO $ $modifyMVar_ ghcThread (\_ -> return Nothing))
(\() -> runInGhc runCmd)
liftIO $ do
-- Make sure the C buffers are also flushed before swapping the handles
fflush nullPtr
-- Restore stdin and stdout
dupTo stdOutputBackup stdOutput >> closeFd stdOutputBackup
dupTo stdErrorBackup stdError >> closeFd stdErrorBackup
dupTo stdInputBackup stdInput >> closeFd stdInputBackup
-- Closing the write end of the stdout pipe will cause the stdout
-- thread to terminate after it processed all remaining output;
-- wait for this to happen
$wait stdoutThread
-- Report the final result
liftIO $ debug dVerbosity $ "returned from ghcHandleRun with "
++ show runOutcome
put $ GhcRunDone runOutcome
where
-- Wait for and execute run requests from the client
readRunRequests :: MVar (Maybe ThreadId) -> Handle -> IO ()
readRunRequests ghcThread stdInputWr =
let go = do request <- get
case request of
GhcRunInterrupt -> do
$withMVar ghcThread $ \mTid -> do
case mTid of
Just tid -> throwTo tid Ex.UserInterrupt
Nothing -> return () -- See above
go
GhcRunInput bs -> do
BSS.hPut stdInputWr bs
hFlush stdInputWr
go
in go
-- Wait for the process to output something or terminate
readStdout :: Handle -> IO ()
readStdout stdOutputRd =
let go = do
mbs <- Ex.try $ BSS.hGetSome stdOutputRd blockSize
case mbs of
Right bs -> unless (BSS.null bs) $ put (GhcRunOutp bs) >> go
-- hGetSome might throw some very unpleasant exceptions in case
-- someone force cancels the operation
-- (which triggered some weird race conditions in test220 in Issues.hs)
-- Swallowing everything, since an exception here implies that there
-- is no more output to read
Left (_ :: Ex.SomeException) -> return ()
in go
-- Turn an asynchronous exception into a RunResult
isUserInterrupt :: Ex.AsyncException -> Maybe RunResult
isUserInterrupt ex@Ex.UserInterrupt =
Just . RunProgException . showExWithClass . Ex.toException $ ex
isUserInterrupt _ =
Nothing
-- Turn a GHC exception into a RunResult
ghcException :: GhcException -> Ghc RunResult
ghcException = return . RunGhcException . show
-- TODO: What is a good value here?
blockSize :: Int
blockSize = 4096
-- Setup loopback pipe so we can capture runStmt's stdout/stderr
redirectStdout :: Ghc (Handle, FileDescriptor, FileDescriptor)
redirectStdout = liftIO $ do
-- Create pipe
(stdOutputRd, stdOutputWr) <- liftIO createPipe
-- Backup stdout, then replace stdout and stderr with the pipe's write end
stdOutputBackup <- liftIO $ dup stdOutput
stdErrorBackup <- liftIO $ dup stdError
_ <- dupTo stdOutputWr stdOutput
_ <- dupTo stdOutputWr stdError
closeFd stdOutputWr
-- Convert to the read end to a handle and return
stdOutputRd' <- fdToHandle stdOutputRd ReadMode
return (stdOutputRd', stdOutputBackup, stdErrorBackup)
-- Setup loopback pipe so we can write to runStmt's stdin
redirectStdin :: Ghc (Handle, FileDescriptor)
redirectStdin = liftIO $ do
-- Create pipe
(stdInputRd, stdInputWr) <- liftIO createPipe
-- Swizzle stdin
stdInputBackup <- liftIO $ dup stdInput
_ <- dupTo stdInputRd stdInput
closeFd stdInputRd
-- Convert the write end to a handle and return
stdInputWr' <- fdToHandle stdInputWr WriteMode
return (stdInputWr', stdInputBackup)
#if PTY_SUPPORT
runPtyMaster :: (FileDescriptor, FileDescriptor) -> (Pid, Socket, Socket, FilePath) -> IO ()
runPtyMaster (masterFd, slaveFd) (processId, stdin, stdout, errorLog) = do
-- Since we're in the master process, close the slave FD.
closeFd slaveFd
let readOutput :: RpcConversation -> IO RunResult
readOutput conv = fix $ \loop -> do
bs <- Posix.readChunk masterFd `Ex.catch` \ex ->
-- Ignore HardwareFaults as they seem to always happen when
-- process exits..
if ioe_type ex == HardwareFault
then return BSS.empty
else Ex.throwIO ex
if BSS.null bs
then return RunOk
else do
put conv (GhcRunOutp bs)
loop
handleRequests :: RpcConversation -> IO ()
handleRequests conv = forever $ do
request <- get conv
case request of
GhcRunInput bs -> Posix.write masterFd bs
-- Fork a new thread because this could throw exceptions.
GhcRunInterrupt -> void $ forkIO $ sigKillProcess processId
-- Turn a GHC exception into a RunResult
ghcException :: GhcException -> IO RunResult
ghcException = return . RunGhcException . show
void $ forkIO $
concurrentConversation stdin stdout errorLog $ \_ conv -> do
result <- Ex.handle ghcException $
withAsync (handleRequests conv) $ \_ ->
readOutput conv
put conv (GhcRunDone result)
ghcHandleRunPtySlave :: (FileDescriptor, FileDescriptor) -> RunCmd -> Ghc ()
ghcHandleRunPtySlave (masterFd, slaveFd) runCmd = do
liftIO $ do
-- Since we're in the slave process, close the master FD.
closeFd masterFd
-- Create a new session with a controlling terminal.
void createSession
Posix.setControllingTerminal slaveFd
-- Redirect standard IO to the terminal FD.
void $ dupTo slaveFd stdInput
void $ dupTo slaveFd stdOutput
void $ dupTo slaveFd stdError
closeFd slaveFd
-- Set TERM env variable
setEnv "TERM" "xterm-256color"
--FIXME: Properly pass the run result to the client as a GhcRunDone
--value. Instead, we write it to standard output, which gets sent to
--the terminal.
result <- runInGhc runCmd
case result of
-- A successful result will be sent by runPtyMaster - only send
-- failures.
RunOk -> return ()
_ -> liftIO $ putStrLn $ "\r\nProcess done: " ++ show result ++ "\r\n"
#endif
startConcurrentConversation
:: (Socket -> Socket -> FilePath -> Ghc ())
-> Ghc (Pid, Socket, Socket, FilePath)
startConcurrentConversation inner = do
-- Ideally, we'd have the child process create the temp directory and
-- communicate the name back to us, so that the child process can remove the
-- directories again when it's done with it. However, this means we need some
-- interprocess communication, which is awkward. So we create the temp
-- directory here; I suppose we could still delegate the responsibility of
-- deleting the directory to the child, but instead we'll just remove the
-- directory along with the rest of the session temp dirs on session exit.
(stdin, stdout, errorLog) <- liftIO $ do
stdin <- makeSocket
stdout <- makeSocket
tmpDir <- Dir.getTemporaryDirectory
(errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc-snippet-.log"
hClose errorLogHandle
return (stdin, stdout, errorLogPath)
-- Start the concurrent conversion. We use forkGhcProcess rather than forkGhc
-- because we need to change global state in the child process; in particular,
-- we need to redirect stdin, stdout, and stderr (as well as some other global
-- state, including withArgs).
liftIO performGC
processId <- forkGhcProcess $ inner stdin stdout errorLog
-- We wait for the process to finish in a separate thread so that we do not
-- accumulate zombies
--
-- FIXME(mgs): I didn't write this, and I'm not sure I see the point
-- of doing this.
liftIO $ void $ forkIO $
void $ getProcessStatus True False processId
return (processId, stdin, stdout, errorLog)
#endif