Use ProcessHandle in withServer to allow kill it by client code

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 7e87fcb3b915756b7057a71d0b511eb626b2b588..016abc22cb6b6ea6fb898db0264e3ce4da9594ff 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -149,8 +149,8 @@ runSessionWithConfig config serverExe caps rootDir session = do
                                           caps
                                           (Just TraceOff)
                                           Nothing
-  withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
-    runSessionWithHandles serverIn serverOut listenServer config caps rootDir exitServer $ do
+  withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
+    runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
       -- Wrap the session around initialize and shutdown calls
       initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
 

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index 7d10763aab553ba19c0239df863fdafae057d9c3..b20eb08f9cb6d3a7a005e82ca61ccf44806747e3 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -23,6 +23,7 @@ import           Control.Monad
 import           System.FilePath
 import           System.IO
 import           Language.Haskell.LSP.Test
+import           Language.Haskell.LSP.Test.Compat
 import           Language.Haskell.LSP.Test.Files
 import           Language.Haskell.LSP.Test.Decoding
 import           Language.Haskell.LSP.Test.Messages
@@ -43,8 +44,9 @@ replaySession serverExe sessionDir = do
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
-  withServer serverExe False $ \serverIn serverOut pid -> do
+  withServer serverExe False $ \serverIn serverOut serverProc -> do
 
+    pid <- getProcessID serverProc
     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
     let clientEvents = filter isClientMsg events
@@ -59,8 +61,7 @@ replaySession serverExe sessionDir = do
     mainThread <- myThreadId
 
     sessionThread <- liftIO $ forkIO $
-      runSessionWithHandles serverIn
-                            serverOut
+      runSessionWithHandles serverIn serverOut serverProc
                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
                             def
                             fullCaps

diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs
index 5449dfbbf40317aae94ba65a17ef9d169dc08a6b..0a77a6193e6fb9c320531e65f74255576bccf8f4 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Server.hs
+++ b/src/Language/Haskell/LSP/Test/Server.hs
@@ -2,11 +2,10 @@ module Language.Haskell.LSP.Test.Server (withServer) where
 
 import Control.Concurrent.Async
 import Control.Monad
-import Language.Haskell.LSP.Test.Compat
 import System.IO
 import System.Process
 
-withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a
+withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a
 withServer serverExe logStdErr f = do
   -- TODO Probably should just change runServer to accept
   -- separate command and arguments
@@ -19,5 +18,4 @@ withServer serverExe logStdErr f = do
     hSetBinaryMode serverErr True
     let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn
     withAsync errSinkThread $ \_ -> do
-      pid <- getProcessID serverProc
-      f serverIn serverOut pid
+      f serverIn serverOut serverProc

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 21a5fe7002af4061552c390bbc24442bec4786d2..8612148ce870a56b1e3cc1587567607dc60f4955 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -65,6 +65,7 @@ import Language.Haskell.LSP.Test.Exceptions
 import System.Console.ANSI
 import System.Directory
 import System.IO
+import System.Process
 import System.Timeout
 
 -- | A session representing one instance of launching and connecting to a server.
@@ -187,14 +188,15 @@ runSession context state session = runReaderT (runStateT conduit state) context
 -- It also does not automatically send initialize and exit messages.
 runSessionWithHandles :: Handle -- ^ Server in
                       -> Handle -- ^ Server out
+                      -> ProcessHandle -- ^ Server process
                       -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
                       -> SessionConfig
                       -> ClientCapabilities
                       -> FilePath -- ^ Root directory
-                      -> Session () -- ^ To exit Server
+                      -> Session () -- ^ To exit the Server properly
                       -> Session a
                       -> IO a
-runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitServer session = do
+runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
   
   absRootDir <- canonicalizePath rootDir
 
@@ -217,8 +219,10 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitS
       
       errorHandler = throwTo mainThreadId :: SessionException -> IO()
       serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler
-      serverFinalizer tid = finally (timeout 60000000 (runSession' exitServer))
-                                    (killThread tid)
+      server = (Just serverIn, Just serverOut, Nothing, serverProc)
+      serverFinalizer tid = finally (timeout (messageTimeout config * 1000000)
+                                             (runSession' exitServer))
+                                    (cleanupProcess server >> killThread tid)
       
   (result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session)
   return result