There are a few things going on here, some specific to Windows and some are
race conditions that are just easier to hit on Windows but can be
reproduced on Linux if you add some delays.
1. You can’t kill threads on Windows that are blocked in an hGet.
So what you have to do is to make the hGet fail somehow, e.g., by
terminating the process that the hGet is reading from which will
make hGet fail.
2. You already terminate the process by sending the exit notification.
However, there is a race condition where listenServer will throw an
UnexpectedServerTermination exception after the server has
terminated as a result of the exit notification. On Linux, you
usually get lucky and end up killing the listenServer thread first
but due to 1 you always hit this on Windows. If you add a delay
after sending the exit notification you can also reproduce this on
Linux.
3. You need to set the handles to binary mode. Otherwise you end up
with newline conversions turning \r\n into \n which will cause
parse errors.
, aeson
, aeson-pretty
, ansi-terminal
, aeson
, aeson-pretty
, ansi-terminal
, bytestring
, conduit
, conduit-parse
, bytestring
, conduit
, conduit-parse
import Data.Aeson
import Data.Default
import qualified Data.HashMap.Strict as HashMap
import Data.Aeson
import Data.Default
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
import Language.Haskell.LSP.Types
import qualified Data.Map as Map
import Data.Maybe
import Language.Haskell.LSP.Types
-> Session a -- ^ The session to run.
-> IO a
runSessionWithConfig config serverExe caps rootDir session = do
-> Session a -- ^ The session to run.
-> IO a
runSessionWithConfig config serverExe caps rootDir session = do
+ -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.
+ exitOk <- newIORef False
pid <- getCurrentProcessID
absRootDir <- canonicalizePath rootDir
pid <- getCurrentProcessID
absRootDir <- canonicalizePath rootDir
(Just TraceOff)
Nothing
withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
(Just TraceOff)
Nothing
withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
- runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
+ runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do
-- Wrap the session around initialize and shutdown calls
initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
-- Wrap the session around initialize and shutdown calls
initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
-- Run the actual test
result <- session
-- Run the actual test
result <- session
+ liftIO $ atomicWriteIORef exitOk True
sendNotification Exit ExitParams
return result
where
sendNotification Exit ExitParams
return result
where
+ catchWhenTrue :: IORef Bool -> IO () -> IO ()
+ catchWhenTrue exitOk a =
+ a `catch` (\e -> do
+ x <- readIORef exitOk
+ unless x $ throw (e :: SomeException))
+
-- | Listens to the server output, makes sure it matches the record and
-- signals any semaphores
-- | Listens to the server output, makes sure it matches the record and
-- signals any semaphores
+ -- Note that on Windows, we cannot kill a thread stuck in getNextMessage.
+ -- So we have to wait for the exit notification to kill the process first
+ -- and then getNextMessage will fail.
listenServer :: Handle -> SessionContext -> IO ()
listenServer serverOut context = do
msgBytes <- getNextMessage serverOut
listenServer :: Handle -> SessionContext -> IO ()
listenServer serverOut context = do
msgBytes <- getNextMessage serverOut
module Language.Haskell.LSP.Test.Server (withServer) where
module Language.Haskell.LSP.Test.Server (withServer) where
-import Control.Concurrent
-import Control.Exception
+import Control.Concurrent.Async
import Control.Monad
import Language.Haskell.LSP.Test.Compat
import System.IO
import Control.Monad
import Language.Haskell.LSP.Test.Compat
import System.IO
-- separate command and arguments
let cmd:args = words serverExe
createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
-- separate command and arguments
let cmd:args = words serverExe
createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
- (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc
-
+ withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do
-- Need to continuously consume to stderr else it gets blocked
-- Can't pass NoStream either to std_err
hSetBuffering serverErr NoBuffering
-- Need to continuously consume to stderr else it gets blocked
-- Can't pass NoStream either to std_err
hSetBuffering serverErr NoBuffering
- errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn
-
+ hSetBinaryMode serverErr True
+ let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn
+ withAsync errSinkThread $ \_ -> do
pid <- getProcessID serverProc
pid <- getProcessID serverProc
-
- finally (f serverIn serverOut pid) $ do
- killThread errSinkThread
- terminateProcess serverProc
+ f serverIn serverOut pid
hSetBuffering serverIn NoBuffering
hSetBuffering serverOut NoBuffering
hSetBuffering serverIn NoBuffering
hSetBuffering serverOut NoBuffering
+ -- This is required to make sure that we don’t get any
+ -- newline conversion or weird encoding issues.
+ hSetBinaryMode serverIn True
+ hSetBinaryMode serverOut True
reqMap <- newMVar newRequestMap
messageChan <- newChan
reqMap <- newMVar newRequestMap
messageChan <- newChan