diff --git a/Auxiliary.hs b/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Auxiliary.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} + +module Auxiliary where + +import Network +import Control.Concurrent (forkIO, ThreadId) +import System.Environment (withArgs) +import GhcMonad(Ghc(..)) + + +import IdeSession.RPC.API +import IdeSession.RPC.Server +import IdeSession.Util +import IdeSession.Util.PortableProcess + + +#ifdef VERSION_unix +import System.Posix.Process (forkProcess) +#else +forkProcess :: IO () -> IO Pid +forkProcess = error "unsupported on non-Unix" +#endif + + +-- | Generalization of captureOutput +captureGhcOutput :: Ghc a -> Ghc (String, a) +captureGhcOutput = unsafeLiftIO captureOutput + +-- | Lift operations on `IO` to the `Ghc` monad. This is unsafe as it makes +-- operations possible in the `Ghc` monad that weren't possible before +-- (for instance, @unsafeLiftIO forkIO@ is probably a bad idea!). +unsafeLiftIO :: (IO a -> IO b) -> Ghc a -> Ghc b +unsafeLiftIO f (Ghc ghc) = Ghc $ \session -> f (ghc session) + +-- | Generalization of 'unsafeLiftIO' +_unsafeLiftIO1 :: ((c -> IO a) -> IO b) -> (c -> Ghc a) -> Ghc b +_unsafeLiftIO1 f g = Ghc $ \session -> + f $ \c -> case g c of Ghc ghc -> ghc session + +-- | Generalization of 'unsafeLiftIO' +-- +-- TODO: Is there a more obvious way to define this progression? +unsafeLiftIO2 :: ((c -> d -> IO a) -> IO b) -> (c -> d -> Ghc a) -> Ghc b +unsafeLiftIO2 f g = Ghc $ \session -> + f $ \c d -> case g c d of Ghc ghc -> ghc session + +-- | Lift `withArgs` to the `Ghc` monad. Relies on `unsafeLiftIO`. +ghcWithArgs :: [String] -> Ghc a -> Ghc a +ghcWithArgs = unsafeLiftIO . withArgs + +-- | Fork within the `Ghc` monad. Use with caution. +_forkGhc :: Ghc () -> Ghc ThreadId +_forkGhc = unsafeLiftIO forkIO + +-- | forkProcess within the `Ghc` monad. Use with extreme caution. +forkGhcProcess :: Ghc () -> Ghc Pid +forkGhcProcess = unsafeLiftIO forkProcess + +-- | Lifted version of concurrentConversation +ghcConcurrentConversation :: (FilePath -> RpcConversation -> Ghc ()) + -> Socket + -> Socket + -> FilePath + -> Ghc () +ghcConcurrentConversation f requestR responseW errorLog = + unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) f diff --git a/RequestRunning.hs b/RequestRunning.hs new file mode 100644 --- /dev/null +++ b/RequestRunning.hs @@ -0,0 +1,336 @@ +{-# 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 diff --git a/Run.hs b/Run.hs --- a/Run.hs +++ b/Run.hs @@ -107,6 +107,7 @@ import IdeSession.Types.Private import qualified IdeSession.Types.Public as Public import IdeSession.Util +import IdeSession.Util.PortableFiles (toExecutable) import IdeSession.Strict.Container import IdeSession.Strict.IORef import qualified IdeSession.Strict.List as StrictList @@ -134,7 +135,7 @@ getGhcLibdir :: IO FilePath getGhcLibdir = do - let ghcbinary = "ghc-" ++ GHC.cProjectVersion + let ghcbinary = toExecutable $ "ghc-" ++ GHC.cProjectVersion out <- readProcess ghcbinary ["--print-libdir"] "" case lines out of [libdir] -> return libdir diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -1,39 +1,21 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, CPP #-} +{-# LANGUAGE ScopedTypeVariables, CPP #-} -- | Implementation of the server that controls the long-running GHC instance. -- This interacts with the ide-backend library through serialized data only. module Server (ghcServer) where import Prelude hiding (mod, span) -import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId, threadDelay) -import Control.Concurrent.Async (async, withAsync) -import Control.Concurrent.MVar (MVar, newEmptyMVar) -import Control.Monad (void, unless, when, forever) +import Control.Concurrent (throwTo, forkIO, myThreadId, threadDelay) +import Control.Monad (void, unless, when) import Control.Monad.State (StateT, runStateT) import Control.Monad.Trans.Class (lift) import Data.Accessor (accessor, (.>)) import Data.Accessor.Monad.MTL.State (set) -import Data.Function (on, 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.FilePath (()) -import System.IO (Handle, hFlush, hClose) -import System.IO.Temp (createTempDirectory, openTempFile, withSystemTempDirectory) -import System.Mem (performGC) -import System.Posix (Fd, createSession) -import System.Posix.IO -import System.Posix.Files (createNamedPipe) -import System.Posix.Process (forkProcess, getProcessStatus) -import System.Posix.Terminal (openPseudoTerminal) -import System.Posix.Signals (signalProcess, sigKILL, sigTERM) -import qualified Posix -import System.Posix.Types (ProcessID) +import Data.Function (on) +import System.Environment (getEnvironment) +import System.IO.Temp (withSystemTempDirectory) import qualified Control.Exception as Ex -import qualified Data.ByteString as BSS import qualified Data.List as List import qualified Data.Text as Text -import qualified System.Directory as Dir import IdeSession.GHC.API import IdeSession.RPC.Server @@ -42,24 +24,21 @@ import IdeSession.Types.Private import IdeSession.Types.Progress import IdeSession.Util -import IdeSession.Util.BlockingOps import qualified IdeSession.Strict.List as StrictList import qualified IdeSession.Strict.Map as StrictMap import qualified IdeSession.Types.Public as Public import qualified GHC -import GhcMonad(Ghc(..)) -import qualified ObjLink as ObjLink -import qualified Linker as Linker +import qualified ObjLink +import qualified Linker import Hooks import Run import HsWalk -import Debug import GhcShim import RTS - -foreign import ccall "fflush" fflush :: Ptr CFile -> IO () +import Auxiliary +import RequestRunning -------------------------------------------------------------------------------- -- Server-side operations -- @@ -84,30 +63,24 @@ ghcServerEngine rtsInfo errorLog conv@RpcConversation{..} = do -- The initial handshake with the client (configGenerateModInfo, initOpts, sourceDir, sessionDir, distDir) <- handleInit conv - -- Submit static opts and get back leftover dynamic opts. dOpts <- submitStaticOpts initOpts - -- Set up references for the current session of Ghc monad computations. pluginRef <- newIORef StrictMap.empty importsRef <- newIORef StrictMap.empty stRef <- newIORef initExtractIdsSuspendedState errsRef <- liftIO $ newIORef StrictList.nil - -- Get environment on server startup so that we can restore it initEnv <- getEnvironment - -- Start handling requests. From this point on we don't leave the GHC monad. runFromGhc $ do -- Register startup options and perhaps our plugin in dynamic flags. initSession distDir configGenerateModInfo dOpts rtsInfo errsRef stRef pluginRef progressCallback - -- We store the DynFlags _after_ setting the "static" options, so that -- we restore to this state before every call to updateDynamicOpts -- Note that this happens _after_ we have called setSessionDynFlags -- and hence after the package DB has been initialized. storeDynFlags - -- Make sure that the dynamic linker has been initialized. This is done -- implicitly deep in the bowels of GhcMake.load, but if we attempt to load -- C object files before calling GhcMake.load (i.e., before attempting to @@ -115,7 +88,6 @@ -- they rely on linker flags such as @-lz@ (#214). do dflags <- getSessionDynFlags liftIO $ Linker.initDynLinker dflags - -- Start handling RPC calls let go args = do req <- liftIO get @@ -125,20 +97,7 @@ conv pluginRef importsRef errsRef sourceDir genCode targets configGenerateModInfo return args - ReqRun runCmd - | runCmdPty runCmd -> do - fds <- liftIO openPseudoTerminal - conversationTuple <- startConcurrentConversation sessionDir $ \_ _ _ -> - ghcWithArgs args $ ghcHandleRunPtySlave fds runCmd - liftIO $ runPtyMaster fds conversationTuple - liftIO $ put conversationTuple - return args - | otherwise -> do - conversationTuple <- startConcurrentConversation sessionDir $ - ghcConcurrentConversation $ \_errorLog' conv' -> - ghcWithArgs args $ ghcHandleRun conv' runCmd - liftIO $ put conversationTuple - return args + ReqRun runCmd -> runCommand conv args sessionDir runCmd ReqSetEnv env -> do ghcHandleSetEnv conv initEnv env return args @@ -148,8 +107,8 @@ ReqBreakpoint mod span value -> do ghcHandleBreak conv mod span value return args - ReqPrint vars bind forceEval -> do - ghcHandlePrint conv vars bind forceEval + ReqPrint vars bind' forceEval -> do + ghcHandlePrint conv vars bind' forceEval return args ReqLoad objects -> do ghcHandleLoad errorLog conv objects @@ -164,7 +123,6 @@ ghcHandleCrash delay return args go args' - go [] where @@ -173,7 +131,7 @@ let ghcMsg' = Text.pack ghcMsg case parseProgressMessage ghcMsg' of Right (step, numSteps, msg) -> - put $ GhcCompileProgress $ Progress { + put $ GhcCompileProgress Progress { progressStep = step , progressNumSteps = numSteps , progressParsedMsg = Just msg @@ -182,7 +140,6 @@ _ -> -- Ignore messages we cannot parse return () - -- Register startup options and perhaps our plugin in dynamic flags. -- -- This is the only place where the @packageDbArgs@ options are used @@ -237,49 +194,6 @@ #endif } -startConcurrentConversation - :: FilePath - -> (FilePath -> FilePath -> FilePath -> Ghc ()) - -> Ghc (ProcessID, FilePath, FilePath, FilePath) -startConcurrentConversation sessionDir 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 - tempDir <- createTempDirectory sessionDir "rpc." - let stdin = tempDir "stdin" - stdout = tempDir "stdout" - - createNamedPipe stdin 0o600 - createNamedPipe stdout 0o600 - - 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) - -- | We cache our own "module summaries" in between compile requests data ModSummary = ModSummary { -- | We cache the import lists so that we can check if the import @@ -351,7 +265,7 @@ let initialResponse = GhcCompileResult { ghcCompileErrors = errs - , ghcCompileLoaded = force $ loadedModules + , ghcCompileLoaded = force loadedModules , ghcCompileFileMap = fileMap , ghcCompileCache = error "ghcCompileCache set last" -- We construct the diffs incrementally @@ -475,7 +389,7 @@ (newSummaries, finalResponse) <- flip runStateT initialResponse $ do sendPluginResult (StrictMap.toList pluginIdMaps) - graph <- lift $ getModuleGraph + graph <- lift getModuleGraph let name s = Text.pack (moduleNameString (ms_mod_name s)) namedGraph = map (\s -> (name s, s)) graph sortedGraph = List.sortBy (compare `on` fst) namedGraph @@ -485,7 +399,7 @@ liftIO $ writeIORef modsRef (StrictMap.fromList newSummaries) return finalResponse - cache <- liftIO $ constructExplicitSharingCache + cache <- liftIO constructExplicitSharingCache let fullResponse = response { ghcCompileCache = cache } -- TODO: Should we clear the link env caches here? @@ -514,8 +428,8 @@ -- | Handle a print request ghcHandlePrint :: RpcConversation -> Public.Name -> Bool -> Bool -> Ghc () -ghcHandlePrint RpcConversation{..} var bind forceEval = do - vals <- printVars (Text.unpack var) bind forceEval +ghcHandlePrint RpcConversation{..} var bind' forceEval = do + vals <- printVars (Text.unpack var) bind' forceEval liftIO $ put vals -- | Handle a load object request @@ -530,7 +444,7 @@ -- Although resolveObjs does _not_ fail quite so spectacularly, it still -- writes its error messages to stdout. - (suppressed, success) <- captureOutput $ ObjLink.resolveObjs + (suppressed, success) <- captureOutput ObjLink.resolveObjs let response :: Maybe String response = case success of @@ -544,194 +458,6 @@ mapM_ ObjLink.unloadObj objects put () -runPtyMaster :: (Fd, Fd) -> (ProcessID, FilePath, FilePath, 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 $ signalProcess sigTERM 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 :: (Fd, Fd) -> 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" - --- | 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 bs <- BSS.hGetSome stdOutputRd blockSize - unless (BSS.null bs) $ put (GhcRunOutp bs) >> go - 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, Fd, Fd) - 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 - return (stdOutputRd', stdOutputBackup, stdErrorBackup) - - -- Setup loopback pipe so we can write to runStmt's stdin - redirectStdin :: Ghc (Handle, Fd) - 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 - return (stdInputWr', stdInputBackup) - -- | Handle a set-environment request ghcHandleSetEnv :: RpcConversation -> [(String, String)] -> [(String, Maybe String)] -> Ghc () ghcHandleSetEnv RpcConversation{put} initEnv overrides = liftIO $ do @@ -753,50 +479,3 @@ void . forkIO $ threadDelay i >> throwTo tid crash where crash = userError "Intentional crash" - --------------------------------------------------------------------------------- --- Auxiliary -- --------------------------------------------------------------------------------- - --- | Generalization of captureOutput -captureGhcOutput :: Ghc a -> Ghc (String, a) -captureGhcOutput = unsafeLiftIO captureOutput - --- | Lift operations on `IO` to the `Ghc` monad. This is unsafe as it makes --- operations possible in the `Ghc` monad that weren't possible before --- (for instance, @unsafeLiftIO forkIO@ is probably a bad idea!). -unsafeLiftIO :: (IO a -> IO b) -> Ghc a -> Ghc b -unsafeLiftIO f (Ghc ghc) = Ghc $ \session -> f (ghc session) - --- | Generalization of 'unsafeLiftIO' -_unsafeLiftIO1 :: ((c -> IO a) -> IO b) -> (c -> Ghc a) -> Ghc b -_unsafeLiftIO1 f g = Ghc $ \session -> - f $ \c -> case g c of Ghc ghc -> ghc session - --- | Generalization of 'unsafeLiftIO' --- --- TODO: Is there a more obvious way to define this progression? -unsafeLiftIO2 :: ((c -> d -> IO a) -> IO b) -> (c -> d -> Ghc a) -> Ghc b -unsafeLiftIO2 f g = Ghc $ \session -> - f $ \c d -> case g c d of Ghc ghc -> ghc session - --- | Lift `withArgs` to the `Ghc` monad. Relies on `unsafeLiftIO`. -ghcWithArgs :: [String] -> Ghc a -> Ghc a -ghcWithArgs = unsafeLiftIO . withArgs - --- | Fork within the `Ghc` monad. Use with caution. -_forkGhc :: Ghc () -> Ghc ThreadId -_forkGhc = unsafeLiftIO forkIO - --- | forkProcess within the `Ghc` monad. Use with extreme caution. -forkGhcProcess :: Ghc () -> Ghc ProcessID -forkGhcProcess = unsafeLiftIO forkProcess - --- | Lifted version of concurrentConversation -ghcConcurrentConversation :: (FilePath -> RpcConversation -> Ghc ()) - -> FilePath - -> FilePath - -> FilePath - -> Ghc () -ghcConcurrentConversation f requestR responseW errorLog = - unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) f diff --git a/ide-backend-server.cabal b/ide-backend-server.cabal --- a/ide-backend-server.cabal +++ b/ide-backend-server.cabal @@ -1,5 +1,5 @@ name: ide-backend-server -version: 0.10.0 +version: 0.10.0.1 synopsis: An IDE backend server description: Server executable used internally by the ide-backend library. license: MIT @@ -19,6 +19,9 @@ ide-backend-rts/Setup.hs, ide-backend-rts/IdeBackendRTS.hs +Flag pty-support + Description: Enable PTY support + Default: True executable ide-backend-server main-is: ide-backend-server.hs @@ -32,21 +35,19 @@ Conv TraceMonad Haddock - GhcShim.GhcShim742 GhcShim.API - GhcShim.GhcShim78 - GhcShim.GhcShim710 GhcShim - Posix RTS + Auxiliary + RequestRunning + build-depends: base < 10, ghc == 7.4.* || == 7.8.* || == 7.10.* || == 7.11.*, containers >= 0.4.1 && < 1, bytestring >= 0.9.2 && < 1, data-accessor >= 0.2 && < 0.3, data-accessor-mtl >= 0.2 && < 0.3, - async >= 2.0 && < 2.1, - unix >= 2.5 && < 2.8, + async >= 2.0 && < 2.2, text >= 0.11 && < 1.3, directory >= 1.1 && < 1.3, filepath >= 1.3 && < 1.5, @@ -61,8 +62,14 @@ tar >= 0.3 && < 0.5, zlib >= 0.5.3 && < 0.7, file-embed >= 0.0 && < 0.1, - ide-backend-common >= 0.10 && < 0.11 + ide-backend-common >= 0.10 && < 0.11, + network + if os(windows) + build-depends: unix-compat + if !os(windows) + build-depends: unix + -- The standard macros don't give us 7.6.x granularity -- We _could_ add support for 7.6, 7.6.1 specifically is broken (#7548) if impl(ghc == 7.6.1) @@ -74,13 +81,16 @@ -- use whatever version came with ghc Cabal cpp-options: -DGHC_742 + other-modules: GhcShim.GhcShim742 if impl(ghc == 7.8.*) build-depends: time == 1.4.*, haddock-api == 2.15.*, -- use whatever version came with ghc Cabal cpp-options: -DGHC_78 - ghc-options: -dynamic + other-modules: GhcShim.GhcShim78 + if !os(windows) + ghc-options: -dynamic if impl(ghc == 7.10.*) || impl(ghc == 7.11.*) build-depends: time == 1.5.*, haddock-api == 2.16.*, @@ -89,9 +99,14 @@ -- parsing functionality; use whatever version came with ghc Cabal cpp-options: -DGHC_710 + other-modules: GhcShim.GhcShim710 + if !os(windows) ghc-options: -dynamic if impl(ghc > 7.10.1) cpp-options: -DGHC_AFTER_710_1 + if flag(pty-support) && !os(windows) + cpp-options: -DPTY_SUPPORT + other-modules: Posix default-language: Haskell2010 default-extensions: MonoLocalBinds,