- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
- initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
- launchServerHandler = forkIO $ catch (serverHandler serverOut context)
- (throwTo mainThreadId :: SessionException -> IO())
- (result, _) <- bracket
- launchServerHandler
- (\tid -> do runSession context initState sendExitMessage
- killThread tid)
- (const $ runSession context initState session)
+ let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
+ initState vfs = SessionState (IdInt 0) vfs mempty False Nothing
+ 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)
+ serverAndListenerFinalizer tid = do
+ finally (timeout (messageTimeout config * 1^6)
+ (runSession' exitServer))
+ (cleanupProcess server >> killThread tid)
+
+ (result, _) <- bracket serverListenerLauncher
+ serverAndListenerFinalizer
+ (const $ runSession' session)