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 (cleanupProcess server >> killThread tid)
272 (result, _) <- bracket serverListenerLauncher
273 serverAndListenerFinalizer
274 (const $ runSession' session)
277 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
278 updateStateC = awaitForever $ \msg -> do
282 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
283 => FromServerMessage -> m ()
285 -- Keep track of dynamic capability registration
286 updateState (ReqRegisterCapability req) = do
287 let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations
289 s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
291 updateState (ReqUnregisterCapability req) = do
292 let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations
294 let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
295 in s { curDynCaps = newCurDynCaps }
297 updateState (NotPublishDiagnostics n) = do
298 let List diags = n ^. params . diagnostics
299 doc = n ^. params . uri
301 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
302 in s { curDiagnostics = newDiags }
304 updateState (ReqApplyWorkspaceEdit r) = do
306 allChangeParams <- case r ^. params . edit . documentChanges of
308 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
309 return $ map getParams cs
310 Nothing -> case r ^. params . edit . changes of
312 mapM_ checkIfNeedsOpened (HashMap.keys cs)
313 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
314 Nothing -> error "No changes!"
317 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
318 return $ s { vfs = newVFS }
320 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
321 mergedParams = map mergeParams groupedParams
323 -- TODO: Don't do this when replaying a session
324 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
326 -- Update VFS to new document versions
327 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
328 latestVersions = map ((^. textDocument) . last) sortedVersions
329 bumpedVersions = map (version . _Just +~ 1) latestVersions
331 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
334 update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
335 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
336 in s { vfs = newVFS }
338 where checkIfNeedsOpened uri = do
339 oldVFS <- vfs <$> get
342 -- if its not open, open it
343 unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
344 let fp = fromJust $ uriToFilePath uri
345 contents <- liftIO $ T.readFile fp
346 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
347 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
348 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
351 let (newVFS,_) = openVFS (vfs s) msg
352 return $ s { vfs = newVFS }
354 getParams (TextDocumentEdit docId (List edits)) =
355 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
356 in DidChangeTextDocumentParams docId (List changeEvents)
358 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
360 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
362 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
364 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
365 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
366 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
367 updateState _ = return ()
369 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
371 h <- serverIn <$> ask
373 liftIO $ B.hPut h (addHeader $ encode msg)
375 -- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
376 -- after duration seconds. This will override the global timeout
377 -- for waiting for messages to arrive defined in 'SessionConfig'.
378 withTimeout :: Int -> Session a -> Session a
379 withTimeout duration f = do
380 chan <- asks messageChan
381 timeoutId <- getCurTimeoutId
382 modify $ \s -> s { overridingTimeout = True }
384 threadDelay (duration * 1000000)
385 writeChan chan (TimeoutMessage timeoutId)
387 bumpTimeoutId timeoutId
388 modify $ \s -> s { overridingTimeout = False }
391 data LogMsgType = LogServer | LogClient
394 -- | Logs the message if the config specified it
395 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
396 => LogMsgType -> a -> m ()
398 shouldLog <- asks $ logMessages . config
399 shouldColor <- asks $ logColor . config
400 liftIO $ when shouldLog $ do
401 when shouldColor $ setSGR [SetColor Foreground Dull color]
402 putStrLn $ arrow ++ showPretty msg
403 when shouldColor $ setSGR [Reset]
406 | t == LogServer = "<-- "
409 | t == LogServer = Magenta
412 showPretty = B.unpack . encodePretty