2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE RankNTypes #-}
9 module Language.Haskell.LSP.Test.Session
16 , runSessionWithHandles
34 import Control.Applicative
35 import Control.Concurrent hiding (yield)
36 import Control.Exception
37 import Control.Lens hiding (List)
39 import Control.Monad.IO.Class
40 import Control.Monad.Except
41 #if __GLASGOW_HASKELL__ == 806
42 import Control.Monad.Fail
44 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
45 import qualified Control.Monad.Trans.Reader as Reader (ask)
46 import Control.Monad.Trans.State (StateT, runStateT)
47 import qualified Control.Monad.Trans.State as State
48 import qualified Data.ByteString.Lazy.Char8 as B
50 import Data.Aeson.Encode.Pretty
51 import Data.Conduit as Conduit
52 import Data.Conduit.Parser as Parser
56 import qualified Data.Map as Map
57 import qualified Data.Text as T
58 import qualified Data.Text.IO as T
59 import qualified Data.HashMap.Strict as HashMap
62 import Language.Haskell.LSP.Messages
63 import Language.Haskell.LSP.Types.Capabilities
64 import Language.Haskell.LSP.Types
65 import Language.Haskell.LSP.Types.Lens
66 import qualified Language.Haskell.LSP.Types.Lens as LSP
67 import Language.Haskell.LSP.VFS
68 import Language.Haskell.LSP.Test.Compat
69 import Language.Haskell.LSP.Test.Decoding
70 import Language.Haskell.LSP.Test.Exceptions
71 import System.Console.ANSI
72 import System.Directory
74 import System.Process (ProcessHandle())
77 -- | A session representing one instance of launching and connecting to a server.
79 -- You can send and receive messages to the server within 'Session' via
80 -- 'Language.Haskell.LSP.Test.message',
81 -- 'Language.Haskell.LSP.Test.sendRequest' and
82 -- 'Language.Haskell.LSP.Test.sendNotification'.
84 newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
85 deriving (Functor, Applicative, Monad, MonadIO, Alternative)
87 #if __GLASGOW_HASKELL__ >= 806
88 instance MonadFail Session where
90 lastMsg <- fromJust . lastReceivedMessage <$> get
91 liftIO $ throw (UnexpectedMessage s lastMsg)
94 -- | Stuff you can configure for a 'Session'.
95 data SessionConfig = SessionConfig
96 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
98 -- ^ Redirect the server's stderr to this stdout, defaults to False.
99 -- Can be overriden with @LSP_TEST_LOG_STDERR@.
100 , logMessages :: Bool
101 -- ^ Trace the messages sent and received to stdout, defaults to False.
102 -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
103 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
104 , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
105 , ignoreLogNotifications :: Bool
106 -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and
107 -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
112 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
113 defaultConfig :: SessionConfig
114 defaultConfig = SessionConfig 60 False False True Nothing False
116 instance Default SessionConfig where
119 data SessionMessage = ServerMessage FromServerMessage
123 data SessionContext = SessionContext
126 , rootDir :: FilePath
127 , messageChan :: Chan SessionMessage -- ^ Where all messages come through
128 -- Keep curTimeoutId in SessionContext, as its tied to messageChan
129 , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
130 , requestMap :: MVar RequestMap
131 , initRsp :: MVar InitializeResponse
132 , config :: SessionConfig
133 , sessionCapabilities :: ClientCapabilities
136 class Monad m => HasReader r m where
138 asks :: (r -> b) -> m b
141 instance HasReader SessionContext Session where
142 ask = Session (lift $ lift Reader.ask)
144 instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
145 ask = lift $ lift Reader.ask
147 getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
148 getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar
150 -- Pass this the timeoutid you *were* waiting on
151 bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
152 bumpTimeoutId prev = do
153 v <- asks curTimeoutId
154 -- when updating the curtimeoutid, account for the fact that something else
155 -- might have bumped the timeoutid in the meantime
156 liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1)))
158 data SessionState = SessionState
162 , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
163 , overridingTimeout :: Bool
164 -- ^ The last received message from the server.
165 -- Used for providing exception information
166 , lastReceivedMessage :: Maybe FromServerMessage
167 , curDynCaps :: Map.Map T.Text Registration
168 -- ^ The capabilities that the server has dynamically registered with us so
172 class Monad m => HasState s m where
177 modify :: (s -> s) -> m ()
178 modify f = get >>= put . f
180 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
181 modifyM f = get >>= f >>= put
183 instance HasState SessionState Session where
184 get = Session (lift State.get)
185 put = Session . lift . State.put
187 instance Monad m => HasState s (StateT s m) where
191 instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)
196 instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)
201 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
202 runSession context state (Session session) = runReaderT (runStateT conduit state) context
204 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
206 handler (Unexpected "ConduitParser.empty") = do
207 lastMsg <- fromJust . lastReceivedMessage <$> get
208 name <- getParserName
209 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
214 msg <- liftIO $ readChan (messageChan context)
215 unless (ignoreLogNotifications (config context) && isLogNotification msg) $
219 isLogNotification (ServerMessage (NotShowMessage _)) = True
220 isLogNotification (ServerMessage (NotLogMessage _)) = True
221 isLogNotification _ = False
223 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
224 watchdog = Conduit.awaitForever $ \msg -> do
225 curId <- getCurTimeoutId
227 ServerMessage sMsg -> yield sMsg
228 TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout
230 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
231 -- It also does not automatically send initialize and exit messages.
232 runSessionWithHandles :: Handle -- ^ Server in
233 -> Handle -- ^ Server out
234 -> ProcessHandle -- ^ Server process
235 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
237 -> ClientCapabilities
238 -> FilePath -- ^ Root directory
239 -> Session () -- ^ To exit the Server properly
242 runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
243 absRootDir <- canonicalizePath rootDir
245 hSetBuffering serverIn NoBuffering
246 hSetBuffering serverOut NoBuffering
247 -- This is required to make sure that we don’t get any
248 -- newline conversion or weird encoding issues.
249 hSetBinaryMode serverIn True
250 hSetBinaryMode serverOut True
252 reqMap <- newMVar newRequestMap
253 messageChan <- newChan
254 timeoutIdVar <- newMVar 0
255 initRsp <- newEmptyMVar
257 mainThreadId <- myThreadId
259 let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
260 initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty
261 runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
263 errorHandler = throwTo mainThreadId :: SessionException -> IO ()
264 serverListenerLauncher =
265 forkIO $ catch (serverHandler serverOut context) errorHandler
266 server = (Just serverIn, Just serverOut, Nothing, serverProc)
267 serverAndListenerFinalizer tid = do
268 finally (timeout (messageTimeout config * 1^6)
269 (runSession' exitServer))
270 -- Make sure to kill the listener first, before closing
271 -- handles etc via cleanupProcess
272 (killThread tid >> cleanupProcess server)
274 (result, _) <- bracket serverListenerLauncher
275 serverAndListenerFinalizer
276 (const $ runSession' session)
279 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
280 updateStateC = awaitForever $ \msg -> do
284 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
285 => FromServerMessage -> m ()
287 -- Keep track of dynamic capability registration
288 updateState (ReqRegisterCapability req) = do
289 let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations
291 s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
293 updateState (ReqUnregisterCapability req) = do
294 let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations
296 let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
297 in s { curDynCaps = newCurDynCaps }
299 updateState (NotPublishDiagnostics n) = do
300 let List diags = n ^. params . diagnostics
301 doc = n ^. params . uri
303 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
304 in s { curDiagnostics = newDiags }
306 updateState (ReqApplyWorkspaceEdit r) = do
308 allChangeParams <- case r ^. params . edit . documentChanges of
310 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
311 return $ map getParams cs
312 Nothing -> case r ^. params . edit . changes of
314 mapM_ checkIfNeedsOpened (HashMap.keys cs)
315 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
316 Nothing -> error "No changes!"
319 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
320 return $ s { vfs = newVFS }
322 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
323 mergedParams = map mergeParams groupedParams
325 -- TODO: Don't do this when replaying a session
326 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
328 -- Update VFS to new document versions
329 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
330 latestVersions = map ((^. textDocument) . last) sortedVersions
331 bumpedVersions = map (version . _Just +~ 1) latestVersions
333 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
336 update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
337 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
338 in s { vfs = newVFS }
340 where checkIfNeedsOpened uri = do
341 oldVFS <- vfs <$> get
344 -- if its not open, open it
345 unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
346 let fp = fromJust $ uriToFilePath uri
347 contents <- liftIO $ T.readFile fp
348 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
349 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
350 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
353 let (newVFS,_) = openVFS (vfs s) msg
354 return $ s { vfs = newVFS }
356 getParams (TextDocumentEdit docId (List edits)) =
357 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
358 in DidChangeTextDocumentParams docId (List changeEvents)
360 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
362 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
364 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
366 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
367 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
368 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
369 updateState _ = return ()
371 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
373 h <- serverIn <$> ask
375 liftIO $ B.hPut h (addHeader $ encode msg)
377 -- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
378 -- after duration seconds. This will override the global timeout
379 -- for waiting for messages to arrive defined in 'SessionConfig'.
380 withTimeout :: Int -> Session a -> Session a
381 withTimeout duration f = do
382 chan <- asks messageChan
383 timeoutId <- getCurTimeoutId
384 modify $ \s -> s { overridingTimeout = True }
386 threadDelay (duration * 1000000)
387 writeChan chan (TimeoutMessage timeoutId)
389 bumpTimeoutId timeoutId
390 modify $ \s -> s { overridingTimeout = False }
393 data LogMsgType = LogServer | LogClient
396 -- | Logs the message if the config specified it
397 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
398 => LogMsgType -> a -> m ()
400 shouldLog <- asks $ logMessages . config
401 shouldColor <- asks $ logColor . config
402 liftIO $ when shouldLog $ do
403 when shouldColor $ setSGR [SetColor Foreground Dull color]
404 putStrLn $ arrow ++ showPretty msg
405 when shouldColor $ setSGR [Reset]
408 | t == LogServer = "<-- "
411 | t == LogServer = Magenta
414 showPretty = B.unpack . encodePretty