- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
- initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
- errorHandler ex = do x <- readIORef exitOk
- unless x $ throwTo mainThreadId (ex :: SessionException)
- launchServerHandler = forkIO $ catch (serverHandler serverOut context) errorHandler
- (result, _) <- bracket
- launchServerHandler
- (\tid -> do runSession context initState sendExitMessage
- killThread tid
- atomicWriteIORef exitOk True)
- (const $ runSession context initState session)
+ let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
+ initState vfs = SessionState 0 vfs mempty False Nothing mempty
+ runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
+
+ errorHandler = throwTo mainThreadId :: SessionException -> IO ()
+ serverListenerLauncher =
+ forkIO $ catch (serverHandler serverOut context) errorHandler
+ msgTimeoutMs = messageTimeout config * 10^6
+ serverAndListenerFinalizer tid = do
+ let cleanup
+ | Just sp <- mServerProc = do
+ -- Give the server some time to exit cleanly
+ timeout msgTimeoutMs (waitForProcess sp)
+ cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)
+ | otherwise = pure ()
+ finally (timeout msgTimeoutMs (runSession' exitServer))
+ -- Make sure to kill the listener first, before closing
+ -- handles etc via cleanupProcess
+ (killThread tid >> cleanup)
+
+ (result, _) <- bracket serverListenerLauncher
+ serverAndListenerFinalizer
+ (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)