projects
/
lsp-test.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
b00bc72
)
Use ProcessHandle in withServer to allow kill it by client code
author
jneira
<atreyu.bbb@gmail.com>
Thu, 11 Jul 2019 08:22:46 +0000
(10:22 +0200)
committer
jneira
<atreyu.bbb@gmail.com>
Thu, 11 Jul 2019 08:22:46 +0000
(10:22 +0200)
src/Language/Haskell/LSP/Test.hs
patch
|
blob
|
history
src/Language/Haskell/LSP/Test/Replay.hs
patch
|
blob
|
history
src/Language/Haskell/LSP/Test/Server.hs
patch
|
blob
|
history
src/Language/Haskell/LSP/Test/Session.hs
patch
|
blob
|
history
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
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
-- 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 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
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
-- 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
events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
let clientEvents = filter isClientMsg events
@@
-59,8
+61,7
@@
replaySession serverExe sessionDir = do
mainThread <- myThreadId
sessionThread <- liftIO $ forkIO $
mainThread <- myThreadId
sessionThread <- liftIO $ forkIO $
- runSessionWithHandles serverIn
- serverOut
+ runSessionWithHandles serverIn serverOut serverProc
(listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
def
fullCaps
(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 Control.Concurrent.Async
import Control.Monad
-import Language.Haskell.LSP.Test.Compat
import System.IO
import System.Process
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
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
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.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.
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
-- 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
-> (Handle -> SessionContext -> IO ()) -- ^ Server listener
-> SessionConfig
-> ClientCapabilities
-> FilePath -- ^ Root directory
- -> Session () -- ^ To exit
Server
+ -> Session () -- ^ To exit
the Server properly
-> Session a
-> IO a
-> Session a
-> IO a
-runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitServer session = do
+runSessionWithHandles serverIn serverOut server
Proc server
Handler config caps rootDir exitServer session = do
absRootDir <- canonicalizePath rootDir
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
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
(result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session)
return result