import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
-import Data.IORef
import Data.List
import qualified Data.Map as Map
import qualified Data.Text as T
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.
--
-- 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
+ -> Session () -- ^ To exit the Server properly
-> Session a
-> IO a
-runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
- -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.
-
- exitOk <- newIORef False
+runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
absRootDir <- canonicalizePath rootDir
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)
+ runSession' = runSession context initState
+
+ errorHandler = throwTo mainThreadId :: SessionException -> IO()
+ serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler
+ server = (Just serverIn, Just serverOut, Nothing, serverProc)
+ serverFinalizer tid = finally (timeout (messageTimeout config * 1000000)
+ (runSession' exitServer))
+ (terminateProcess serverProc
+ >> hClose serverOut
+ >> 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'.