Fix various issues encountered on Windows

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.

diff --git a/lsp-test.cabal b/lsp-test.cabal
index aca12b0a92e86b2cd904c31573fe71ccd4e479b4..f1035b2572d38ed8bbb416cb9f1a6d51b9c5f96f 100644 (file)
--- 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 15cb2a164d4600530cbc6a626f8fedbfee7890f9..bc04845f8d9774e4f5cd00c48e8cbe74153e1417 100644 (file)
--- 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 bd5bdb959f670652a5e910d5d0942b43fcb0c494..5449dfbbf40317aae94ba65a17ef9d169dc08a6b 100644 (file)
--- 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 a3ba35b3a1a46f723d4ca0fce59775991680c862..ab09726f2ef5490654d4a41099ed53e42f03b608 100644 (file)
--- 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