-> SessionConfig
-> ClientCapabilities
-> FilePath -- ^ Root directory
+ -> Session () -- ^ To exit Server
-> Session a
-> IO a
-runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
+runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitServer session = do
+
absRootDir <- canonicalizePath rootDir
hSetBuffering serverIn NoBuffering
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)
+ runSession' = runSession context initState
+
+ errorHandler = throwTo mainThreadId :: SessionException -> IO()
+ serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler
+ serverFinalizer tid = runSession' exitServer >> killThread tid
+
+ (result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session)
return result
updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
logMsg LogClient msg
liftIO $ B.hPut h (addHeader $ encode msg)
-sendExitMessage :: (MonadIO m, HasReader SessionContext m) => m ()
-sendExitMessage = sendMessage (NotificationMessage "2.0" Exit ExitParams)
-
-- | Execute a block f that will throw a 'Timeout' exception
-- after duration seconds. This will override the global timeout
-- for waiting for messages to arrive defined in 'SessionConfig'.