ide-backend-server 0.10.0 → 0.10.0.1
raw patch · 5 files changed
+448/−351 lines, 5 filesdep +networkdep +unix-compatdep ~asyncdep ~unix
Dependencies added: network, unix-compat
Dependency ranges changed: async, unix
Files
- Auxiliary.hs +66/−0
- RequestRunning.hs +336/−0
- Run.hs +2/−1
- Server.hs +20/−341
- ide-backend-server.cabal +24/−9
+ Auxiliary.hs view
@@ -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
+ RequestRunning.hs view
@@ -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
Run.hs view
@@ -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
Server.hs view
@@ -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
ide-backend-server.cabal view
@@ -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,