2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE RankNTypes #-}
8 module Language.Haskell.LSP.Test.Session
15 , runSessionWithHandles
31 import Control.Concurrent hiding (yield)
32 import Control.Exception
33 import Control.Lens hiding (List)
35 import Control.Monad.IO.Class
36 import Control.Monad.Except
37 #if __GLASGOW_HASKELL__ == 806
38 import Control.Monad.Fail
40 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
41 import qualified Control.Monad.Trans.Reader as Reader (ask)
42 import Control.Monad.Trans.State (StateT, runStateT)
43 import qualified Control.Monad.Trans.State as State (get, put)
44 import qualified Data.ByteString.Lazy.Char8 as B
46 import Data.Aeson.Encode.Pretty
47 import Data.Conduit as Conduit
48 import Data.Conduit.Parser as Parser
52 import qualified Data.Map as Map
53 import qualified Data.Text as T
54 import qualified Data.Text.IO as T
55 import qualified Data.HashMap.Strict as HashMap
58 import Language.Haskell.LSP.Messages
59 import Language.Haskell.LSP.Types.Capabilities
60 import Language.Haskell.LSP.Types
61 import Language.Haskell.LSP.Types.Lens hiding (error)
62 import Language.Haskell.LSP.VFS
63 import Language.Haskell.LSP.Test.Compat
64 import Language.Haskell.LSP.Test.Decoding
65 import Language.Haskell.LSP.Test.Exceptions
66 import System.Console.ANSI
67 import System.Directory
69 import System.Process (ProcessHandle())
72 -- | A session representing one instance of launching and connecting to a server.
74 -- You can send and receive messages to the server within 'Session' via
75 -- 'Language.Haskell.LSP.Test.message',
76 -- 'Language.Haskell.LSP.Test.sendRequest' and
77 -- 'Language.Haskell.LSP.Test.sendNotification'.
79 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
81 #if __GLASGOW_HASKELL__ >= 806
82 instance MonadFail Session where
84 lastMsg <- fromJust . lastReceivedMessage <$> get
85 liftIO $ throw (UnexpectedMessage s lastMsg)
88 -- | Stuff you can configure for a 'Session'.
89 data SessionConfig = SessionConfig
90 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
91 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
92 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False.
93 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
94 , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
97 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
98 defaultConfig :: SessionConfig
99 defaultConfig = SessionConfig 60 False False True Nothing
101 instance Default SessionConfig where
104 data SessionMessage = ServerMessage FromServerMessage
108 data SessionContext = SessionContext
111 , rootDir :: FilePath
112 , messageChan :: Chan SessionMessage
113 , requestMap :: MVar RequestMap
114 , initRsp :: MVar InitializeResponse
115 , config :: SessionConfig
116 , sessionCapabilities :: ClientCapabilities
119 class Monad m => HasReader r m where
121 asks :: (r -> b) -> m b
124 instance Monad m => HasReader r (ParserStateReader a s r m) where
125 ask = lift $ lift Reader.ask
127 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
128 ask = lift $ lift Reader.ask
130 data SessionState = SessionState
134 , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
135 , curTimeoutId :: Int
136 , overridingTimeout :: Bool
137 -- ^ The last received message from the server.
138 -- Used for providing exception information
139 , lastReceivedMessage :: Maybe FromServerMessage
142 class Monad m => HasState s m where
147 modify :: (s -> s) -> m ()
148 modify f = get >>= put . f
150 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
151 modifyM f = get >>= f >>= put
153 instance Monad m => HasState s (ParserStateReader a s r m) where
155 put = lift . State.put
157 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
160 put = lift . State.put
162 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
164 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
165 runSession context state session = runReaderT (runStateT conduit state) context
167 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
169 handler (Unexpected "ConduitParser.empty") = do
170 lastMsg <- fromJust . lastReceivedMessage <$> get
171 name <- getParserName
172 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
177 msg <- liftIO $ readChan (messageChan context)
181 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
182 watchdog = Conduit.awaitForever $ \msg -> do
183 curId <- curTimeoutId <$> get
185 ServerMessage sMsg -> yield sMsg
186 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
188 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
189 -- It also does not automatically send initialize and exit messages.
190 runSessionWithHandles :: Handle -- ^ Server in
191 -> Handle -- ^ Server out
192 -> ProcessHandle -- ^ Server process
193 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
195 -> ClientCapabilities
196 -> FilePath -- ^ Root directory
197 -> Session () -- ^ To exit the Server properly
200 runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
201 absRootDir <- canonicalizePath rootDir
203 hSetBuffering serverIn NoBuffering
204 hSetBuffering serverOut NoBuffering
205 -- This is required to make sure that we don’t get any
206 -- newline conversion or weird encoding issues.
207 hSetBinaryMode serverIn True
208 hSetBinaryMode serverOut True
210 reqMap <- newMVar newRequestMap
211 messageChan <- newChan
212 initRsp <- newEmptyMVar
214 mainThreadId <- myThreadId
216 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
217 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
218 runSession' = runSession context initState
220 errorHandler = throwTo mainThreadId :: SessionException -> IO()
221 serverListenerLauncher =
222 forkIO $ catch (serverHandler serverOut context) errorHandler
223 server = (Just serverIn, Just serverOut, Nothing, serverProc)
224 serverAndListenerFinalizer tid =
225 finally (timeout (messageTimeout config * 1000000)
226 (runSession' exitServer))
227 (cleanupProcess server >> killThread tid)
229 (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer
230 (const $ runSession' session)
233 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
234 updateStateC = awaitForever $ \msg -> do
238 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
239 updateState (NotPublishDiagnostics n) = do
240 let List diags = n ^. params . diagnostics
241 doc = n ^. params . uri
243 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
244 in s { curDiagnostics = newDiags })
246 updateState (ReqApplyWorkspaceEdit r) = do
248 allChangeParams <- case r ^. params . edit . documentChanges of
250 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
251 return $ map getParams cs
252 Nothing -> case r ^. params . edit . changes of
254 mapM_ checkIfNeedsOpened (HashMap.keys cs)
255 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
256 Nothing -> error "No changes!"
259 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
260 return $ s { vfs = newVFS }
262 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
263 mergedParams = map mergeParams groupedParams
265 -- TODO: Don't do this when replaying a session
266 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
268 -- Update VFS to new document versions
269 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
270 latestVersions = map ((^. textDocument) . last) sortedVersions
271 bumpedVersions = map (version . _Just +~ 1) latestVersions
273 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
276 update (VirtualFile oldV t mf) = VirtualFile (fromMaybe oldV v) t mf
277 newVFS = Map.adjust update (toNormalizedUri uri) oldVFS
278 in s { vfs = newVFS }
280 where checkIfNeedsOpened uri = do
281 oldVFS <- vfs <$> get
284 -- if its not open, open it
285 unless (toNormalizedUri uri `Map.member` oldVFS) $ do
286 let fp = fromJust $ uriToFilePath uri
287 contents <- liftIO $ T.readFile fp
288 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
289 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
290 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
293 newVFS <- liftIO $ openVFS (vfs s) msg
294 return $ s { vfs = newVFS }
296 getParams (TextDocumentEdit docId (List edits)) =
297 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
298 in DidChangeTextDocumentParams docId (List changeEvents)
300 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
302 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
304 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
306 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
307 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
308 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
309 updateState _ = return ()
311 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
313 h <- serverIn <$> ask
315 liftIO $ B.hPut h (addHeader $ encode msg)
317 -- | Execute a block f that will throw a 'Timeout' exception
318 -- after duration seconds. This will override the global timeout
319 -- for waiting for messages to arrive defined in 'SessionConfig'.
320 withTimeout :: Int -> Session a -> Session a
321 withTimeout duration f = do
322 chan <- asks messageChan
323 timeoutId <- curTimeoutId <$> get
324 modify $ \s -> s { overridingTimeout = True }
326 threadDelay (duration * 1000000)
327 writeChan chan (TimeoutMessage timeoutId)
329 modify $ \s -> s { curTimeoutId = timeoutId + 1,
330 overridingTimeout = False
334 data LogMsgType = LogServer | LogClient
337 -- | Logs the message if the config specified it
338 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
339 => LogMsgType -> a -> m ()
341 shouldLog <- asks $ logMessages . config
342 shouldColor <- asks $ logColor . config
343 liftIO $ when shouldLog $ do
344 when shouldColor $ setSGR [SetColor Foreground Dull color]
345 putStrLn $ arrow ++ showPretty msg
346 when shouldColor $ setSGR [Reset]
349 | t == LogServer = "<-- "
352 | t == LogServer = Magenta
355 showPretty = B.unpack . encodePretty