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 , ignoreLogNotifications :: Bool
103 -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and
104 -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
109 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
110 defaultConfig :: SessionConfig
111 defaultConfig = SessionConfig 60 False False True Nothing False
113 instance Default SessionConfig where
116 data SessionMessage = ServerMessage FromServerMessage
120 data SessionContext = SessionContext
123 , rootDir :: FilePath
124 , messageChan :: Chan SessionMessage
125 , requestMap :: MVar RequestMap
126 , initRsp :: MVar InitializeResponse
127 , config :: SessionConfig
128 , sessionCapabilities :: ClientCapabilities
131 class Monad m => HasReader r m where
133 asks :: (r -> b) -> m b
136 instance HasReader SessionContext Session where
137 ask = Session (lift $ lift Reader.ask)
139 instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
140 ask = lift $ lift Reader.ask
142 data SessionState = SessionState
146 , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
147 , curTimeoutId :: Int
148 , overridingTimeout :: Bool
149 -- ^ The last received message from the server.
150 -- Used for providing exception information
151 , lastReceivedMessage :: Maybe FromServerMessage
154 class Monad m => HasState s m where
159 modify :: (s -> s) -> m ()
160 modify f = get >>= put . f
162 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
163 modifyM f = get >>= f >>= put
165 instance HasState SessionState Session where
166 get = Session (lift State.get)
167 put = Session . lift . State.put
169 instance Monad m => HasState s (ConduitM a b (StateT s m))
172 put = lift . State.put
174 instance Monad m => HasState s (ConduitParser a (StateT s m))
177 put = lift . State.put
179 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
180 runSession context state (Session session) = runReaderT (runStateT conduit state) context
182 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
184 handler (Unexpected "ConduitParser.empty") = do
185 lastMsg <- fromJust . lastReceivedMessage <$> get
186 name <- getParserName
187 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
192 msg <- liftIO $ readChan (messageChan context)
193 unless (ignoreLogNotifications (config context) && isLogNotification msg) $
197 isLogNotification (ServerMessage (NotShowMessage _)) = True
198 isLogNotification (ServerMessage (NotLogMessage _)) = True
199 isLogNotification _ = False
201 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
202 watchdog = Conduit.awaitForever $ \msg -> do
203 curId <- curTimeoutId <$> get
205 ServerMessage sMsg -> yield sMsg
206 TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout
208 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
209 -- It also does not automatically send initialize and exit messages.
210 runSessionWithHandles :: Handle -- ^ Server in
211 -> Handle -- ^ Server out
212 -> ProcessHandle -- ^ Server process
213 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
215 -> ClientCapabilities
216 -> FilePath -- ^ Root directory
217 -> Session () -- ^ To exit the Server properly
220 runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
221 absRootDir <- canonicalizePath rootDir
223 hSetBuffering serverIn NoBuffering
224 hSetBuffering serverOut NoBuffering
225 -- This is required to make sure that we don’t get any
226 -- newline conversion or weird encoding issues.
227 hSetBinaryMode serverIn True
228 hSetBinaryMode serverOut True
230 reqMap <- newMVar newRequestMap
231 messageChan <- newChan
232 initRsp <- newEmptyMVar
234 mainThreadId <- myThreadId
236 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
237 initState vfs = SessionState (IdInt 0) vfs
238 mempty 0 False Nothing
239 runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
241 errorHandler = throwTo mainThreadId :: SessionException -> IO()
242 serverListenerLauncher =
243 forkIO $ catch (serverHandler serverOut context) errorHandler
244 server = (Just serverIn, Just serverOut, Nothing, serverProc)
245 serverAndListenerFinalizer tid =
246 finally (timeout (messageTimeout config * 1000000)
247 (runSession' exitServer))
248 (cleanupProcess server >> killThread tid)
250 (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer
251 (const $ runSession' session)
254 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
255 updateStateC = awaitForever $ \msg -> do
259 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
260 => FromServerMessage -> m ()
261 updateState (NotPublishDiagnostics n) = do
262 let List diags = n ^. params . diagnostics
263 doc = n ^. params . uri
265 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
266 in s { curDiagnostics = newDiags })
268 updateState (ReqApplyWorkspaceEdit r) = do
270 allChangeParams <- case r ^. params . edit . documentChanges of
272 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
273 return $ map getParams cs
274 Nothing -> case r ^. params . edit . changes of
276 mapM_ checkIfNeedsOpened (HashMap.keys cs)
277 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
278 Nothing -> error "No changes!"
281 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
282 return $ s { vfs = newVFS }
284 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
285 mergedParams = map mergeParams groupedParams
287 -- TODO: Don't do this when replaying a session
288 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
290 -- Update VFS to new document versions
291 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
292 latestVersions = map ((^. textDocument) . last) sortedVersions
293 bumpedVersions = map (version . _Just +~ 1) latestVersions
295 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
298 update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
299 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
300 in s { vfs = newVFS }
302 where checkIfNeedsOpened uri = do
303 oldVFS <- vfs <$> get
306 -- if its not open, open it
307 unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
308 let fp = fromJust $ uriToFilePath uri
309 contents <- liftIO $ T.readFile fp
310 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
311 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
312 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
315 let (newVFS,_) = openVFS (vfs s) msg
316 return $ s { vfs = newVFS }
318 getParams (TextDocumentEdit docId (List edits)) =
319 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
320 in DidChangeTextDocumentParams docId (List changeEvents)
322 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
324 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
326 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
328 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
329 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
330 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
331 updateState _ = return ()
333 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
335 h <- serverIn <$> ask
337 liftIO $ B.hPut h (addHeader $ encode msg)
339 -- | Execute a block f that will throw a 'Timeout' exception
340 -- after duration seconds. This will override the global timeout
341 -- for waiting for messages to arrive defined in 'SessionConfig'.
342 withTimeout :: Int -> Session a -> Session a
343 withTimeout duration f = do
344 chan <- asks messageChan
345 timeoutId <- curTimeoutId <$> get
346 modify $ \s -> s { overridingTimeout = True }
348 threadDelay (duration * 1000000)
349 writeChan chan (TimeoutMessage timeoutId)
351 modify $ \s -> s { curTimeoutId = timeoutId + 1,
352 overridingTimeout = False
356 data LogMsgType = LogServer | LogClient
359 -- | Logs the message if the config specified it
360 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
361 => LogMsgType -> a -> m ()
363 shouldLog <- asks $ logMessages . config
364 shouldColor <- asks $ logColor . config
365 liftIO $ when shouldLog $ do
366 when shouldColor $ setSGR [SetColor Foreground Dull color]
367 putStrLn $ arrow ++ showPretty msg
368 when shouldColor $ setSGR [Reset]
371 | t == LogServer = "<-- "
374 | t == LogServer = Magenta
377 showPretty = B.unpack . encodePretty