From 3c7aa3a876b2142ceae3b649fbb5bd80e95aff77 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Wed, 5 Jun 2019 13:58:20 +0200 Subject: [PATCH] Fix various issues encountered on Windows MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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. --- lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test.hs | 15 ++++++++++++++- src/Language/Haskell/LSP/Test/Server.hs | 16 ++++++---------- src/Language/Haskell/LSP/Test/Session.hs | 4 ++++ 4 files changed, 25 insertions(+), 11 deletions(-) diff --git a/lsp-test.cabal b/lsp-test.cabal index aca12b0..f1035b2 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -40,6 +40,7 @@ library , aeson , aeson-pretty , ansi-terminal + , async , bytestring , conduit , conduit-parse diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 15cb2a1..bc04845 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -92,6 +92,7 @@ import qualified Data.Text.IO as T import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap +import Data.IORef import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Types @@ -135,6 +136,8 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> 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 @@ -146,7 +149,7 @@ runSessionWithConfig config serverExe caps rootDir session = do (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 @@ -165,12 +168,22 @@ runSessionWithConfig config serverExe caps rootDir session = do -- Run the actual test result <- session + liftIO $ atomicWriteIORef exitOk True 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 + -- 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 diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs index bd5bdb9..5449dfb 100644 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -1,7 +1,6 @@ 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 @@ -13,15 +12,12 @@ withServer serverExe logStdErr f = do -- 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 - 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 - - finally (f serverIn serverOut pid) $ do - killThread errSinkThread - terminateProcess serverProc + f serverIn serverOut pid diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a3ba35b..ab09726 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -197,6 +197,10 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi 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 -- 2.30.2