- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
- initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
- launchServerHandler = forkIO $ void $ serverHandler serverOut context
- (result, _) <- bracket launchServerHandler killThread $
- const $ runSession context initState session
+ mainThreadId <- myThreadId
+
+ let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
+ initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty
+ runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
+
+ errorHandler = throwTo mainThreadId :: SessionException -> IO ()
+ serverListenerLauncher =
+ forkIO $ catch (serverHandler serverOut context) errorHandler
+ server = (Just serverIn, Just serverOut, Nothing, serverProc)
+ msgTimeoutMs = messageTimeout config * 10^6
+ serverAndListenerFinalizer tid = do
+ finally (timeout msgTimeoutMs (runSession' exitServer)) $ do
+ -- Make sure to kill the listener first, before closing
+ -- handles etc via cleanupProcess
+ killThread tid
+ -- Give the server some time to exit cleanly
+ -- It makes the server hangs in windows so we have to avoid it
+#ifndef mingw32_HOST_OS
+ timeout msgTimeoutMs (waitForProcess serverProc)
+#endif
+ cleanupProcess server