From 1b1df64886e90bb77c2804452945ff0d66963e0a Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 11 Jul 2019 10:22:46 +0200 Subject: [PATCH] Use ProcessHandle in withServer to allow kill it by client code --- src/Language/Haskell/LSP/Test.hs | 4 ++-- src/Language/Haskell/LSP/Test/Replay.hs | 7 ++++--- src/Language/Haskell/LSP/Test/Server.hs | 6 ++---- src/Language/Haskell/LSP/Test/Session.hs | 12 ++++++++---- 4 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 7e87fcb..016abc2 100644 --- 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 7d10763..b20eb08 100644 --- 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 5449dfb..0a77a61 100644 --- 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 21a5fe7..8612148 100644 --- 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 -- 2.30.2