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
32 import Control.Applicative
33 import Control.Concurrent hiding (yield)
34 import Control.Exception
35 import Control.Lens hiding (List)
37 import Control.Monad.IO.Class
38 import Control.Monad.Except
39 #if __GLASGOW_HASKELL__ == 806
40 import Control.Monad.Fail
42 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
43 import qualified Control.Monad.Trans.Reader as Reader (ask)
44 import Control.Monad.Trans.State (StateT, runStateT)
45 import qualified Control.Monad.Trans.State as State
46 import qualified Data.ByteString.Lazy.Char8 as B
48 import Data.Aeson.Encode.Pretty
49 import Data.Conduit as Conduit
50 import Data.Conduit.Parser as Parser
54 import qualified Data.Map as Map
55 import qualified Data.Text as T
56 import qualified Data.Text.IO as T
57 import qualified Data.HashMap.Strict as HashMap
60 import Language.Haskell.LSP.Messages
61 import Language.Haskell.LSP.Types.Capabilities
62 import Language.Haskell.LSP.Types
63 import Language.Haskell.LSP.Types.Lens hiding (error)
64 import Language.Haskell.LSP.VFS
65 import Language.Haskell.LSP.Test.Compat
66 import Language.Haskell.LSP.Test.Decoding
67 import Language.Haskell.LSP.Test.Exceptions
68 import System.Console.ANSI
69 import System.Directory
71 import System.Process (ProcessHandle())
74 -- | A session representing one instance of launching and connecting to a server.
76 -- You can send and receive messages to the server within 'Session' via
77 -- 'Language.Haskell.LSP.Test.message',
78 -- 'Language.Haskell.LSP.Test.sendRequest' and
79 -- 'Language.Haskell.LSP.Test.sendNotification'.
81 newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
82 deriving (Functor, Applicative, Monad, MonadIO, Alternative)
84 #if __GLASGOW_HASKELL__ >= 806
85 instance MonadFail Session where
87 lastMsg <- fromJust . lastReceivedMessage <$> get
88 liftIO $ throw (UnexpectedMessage s lastMsg)
91 -- | Stuff you can configure for a 'Session'.
92 data SessionConfig = SessionConfig
93 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
95 -- ^ Redirect the server's stderr to this stdout, defaults to False.
96 -- Can be overriden with @LSP_TEST_LOG_STDERR@.
98 -- ^ Trace the messages sent and received to stdout, defaults to False.
99 -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
100 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
101 , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
102 -- ^ Whether or not to ignore 'ShowMessageNotification' and 'LogMessageNotification', defaults to False.
104 , ignoreLogNotifications :: Bool
107 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
108 defaultConfig :: SessionConfig
109 defaultConfig = SessionConfig 60 False False True Nothing False
111 instance Default SessionConfig where
114 data SessionMessage = ServerMessage FromServerMessage
118 data SessionContext = SessionContext
121 , rootDir :: FilePath
122 , messageChan :: Chan SessionMessage
123 , requestMap :: MVar RequestMap
124 , initRsp :: MVar InitializeResponse
125 , config :: SessionConfig
126 , sessionCapabilities :: ClientCapabilities
129 class Monad m => HasReader r m where
131 asks :: (r -> b) -> m b
134 instance HasReader SessionContext Session where
135 ask = Session (lift $ lift Reader.ask)
137 instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
138 ask = lift $ lift Reader.ask
140 data SessionState = SessionState
144 , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
145 , curTimeoutId :: Int
146 , overridingTimeout :: Bool
147 -- ^ The last received message from the server.
148 -- Used for providing exception information
149 , lastReceivedMessage :: Maybe FromServerMessage
152 class Monad m => HasState s m where
157 modify :: (s -> s) -> m ()
158 modify f = get >>= put . f
160 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
161 modifyM f = get >>= f >>= put
163 instance HasState SessionState Session where
164 get = Session (lift State.get)
165 put = Session . lift . State.put
167 instance Monad m => HasState s (ConduitM a b (StateT s m))
170 put = lift . State.put
172 instance Monad m => HasState s (ConduitParser a (StateT s m))
175 put = lift . State.put
177 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
178 runSession context state (Session session) = runReaderT (runStateT conduit state) context
180 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
182 handler (Unexpected "ConduitParser.empty") = do
183 lastMsg <- fromJust . lastReceivedMessage <$> get
184 name <- getParserName
185 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
190 msg <- liftIO $ readChan (messageChan context)
191 unless (ignoreLogNotifications (config context) && isLogNotification msg) $
195 isLogNotification (ServerMessage (NotShowMessage _)) = True
196 isLogNotification (ServerMessage (NotLogMessage _)) = True
197 isLogNotification _ = False
199 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
200 watchdog = Conduit.awaitForever $ \msg -> do
201 curId <- curTimeoutId <$> get
203 ServerMessage sMsg -> yield sMsg
204 TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout
206 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
207 -- It also does not automatically send initialize and exit messages.
208 runSessionWithHandles :: Handle -- ^ Server in
209 -> Handle -- ^ Server out
210 -> ProcessHandle -- ^ Server process
211 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
213 -> ClientCapabilities
214 -> FilePath -- ^ Root directory
215 -> Session () -- ^ To exit the Server properly
218 runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
219 absRootDir <- canonicalizePath rootDir
221 hSetBuffering serverIn NoBuffering
222 hSetBuffering serverOut NoBuffering
223 -- This is required to make sure that we don’t get any
224 -- newline conversion or weird encoding issues.
225 hSetBinaryMode serverIn True
226 hSetBinaryMode serverOut True
228 reqMap <- newMVar newRequestMap
229 messageChan <- newChan
230 initRsp <- newEmptyMVar
232 mainThreadId <- myThreadId
234 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
235 initState vfs = SessionState (IdInt 0) vfs
236 mempty 0 False Nothing
237 runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
239 errorHandler = throwTo mainThreadId :: SessionException -> IO()
240 serverListenerLauncher =
241 forkIO $ catch (serverHandler serverOut context) errorHandler
242 server = (Just serverIn, Just serverOut, Nothing, serverProc)
243 serverAndListenerFinalizer tid =
244 finally (timeout (messageTimeout config * 1000000)
245 (runSession' exitServer))
246 (cleanupProcess server >> killThread tid)
248 (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer
249 (const $ runSession' session)
252 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
253 updateStateC = awaitForever $ \msg -> do
257 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
258 => FromServerMessage -> m ()
259 updateState (NotPublishDiagnostics n) = do
260 let List diags = n ^. params . diagnostics
261 doc = n ^. params . uri
263 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
264 in s { curDiagnostics = newDiags })
266 updateState (ReqApplyWorkspaceEdit r) = do
268 allChangeParams <- case r ^. params . edit . documentChanges of
270 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
271 return $ map getParams cs
272 Nothing -> case r ^. params . edit . changes of
274 mapM_ checkIfNeedsOpened (HashMap.keys cs)
275 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
276 Nothing -> error "No changes!"
279 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
280 return $ s { vfs = newVFS }
282 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
283 mergedParams = map mergeParams groupedParams
285 -- TODO: Don't do this when replaying a session
286 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
288 -- Update VFS to new document versions
289 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
290 latestVersions = map ((^. textDocument) . last) sortedVersions
291 bumpedVersions = map (version . _Just +~ 1) latestVersions
293 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
296 update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
297 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
298 in s { vfs = newVFS }
300 where checkIfNeedsOpened uri = do
301 oldVFS <- vfs <$> get
304 -- if its not open, open it
305 unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
306 let fp = fromJust $ uriToFilePath uri
307 contents <- liftIO $ T.readFile fp
308 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
309 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
310 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
313 let (newVFS,_) = openVFS (vfs s) msg
314 return $ s { vfs = newVFS }
316 getParams (TextDocumentEdit docId (List edits)) =
317 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
318 in DidChangeTextDocumentParams docId (List changeEvents)
320 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
322 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
324 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
326 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
327 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
328 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
329 updateState _ = return ()
331 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
333 h <- serverIn <$> ask
335 liftIO $ B.hPut h (addHeader $ encode msg)
337 -- | Execute a block f that will throw a 'Timeout' exception
338 -- after duration seconds. This will override the global timeout
339 -- for waiting for messages to arrive defined in 'SessionConfig'.
340 withTimeout :: Int -> Session a -> Session a
341 withTimeout duration f = do
342 chan <- asks messageChan
343 timeoutId <- curTimeoutId <$> get
344 modify $ \s -> s { overridingTimeout = True }
346 threadDelay (duration * 1000000)
347 writeChan chan (TimeoutMessage timeoutId)
349 modify $ \s -> s { curTimeoutId = timeoutId + 1,
350 overridingTimeout = False
354 data LogMsgType = LogServer | LogClient
357 -- | Logs the message if the config specified it
358 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
359 => LogMsgType -> a -> m ()
361 shouldLog <- asks $ logMessages . config
362 shouldColor <- asks $ logColor . config
363 liftIO $ when shouldLog $ do
364 when shouldColor $ setSGR [SetColor Foreground Dull color]
365 putStrLn $ arrow ++ showPretty msg
366 when shouldColor $ setSGR [Reset]
369 | t == LogServer = "<-- "
372 | t == LogServer = Magenta
375 showPretty = B.unpack . encodePretty