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())
75 -- | A session representing one instance of launching and connecting to a server.
77 -- You can send and receive messages to the server within 'Session' via
78 -- 'Language.Haskell.LSP.Test.message',
79 -- 'Language.Haskell.LSP.Test.sendRequest' and
80 -- 'Language.Haskell.LSP.Test.sendNotification'.
82 newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
83 deriving (Functor, Applicative, Monad, MonadIO, Alternative)
85 #if __GLASGOW_HASKELL__ >= 806
86 instance MonadFail Session where
88 lastMsg <- fromJust . lastReceivedMessage <$> get
89 liftIO $ throw (UnexpectedMessage s lastMsg)
92 -- | Stuff you can configure for a 'Session'.
93 data SessionConfig = SessionConfig
94 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
95 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
96 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False.
97 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
98 , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
101 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
102 defaultConfig :: SessionConfig
103 defaultConfig = SessionConfig 60 False False True Nothing
105 instance Default SessionConfig where
108 data SessionMessage = ServerMessage FromServerMessage
112 data SessionContext = SessionContext
115 , rootDir :: FilePath
116 , messageChan :: Chan SessionMessage
117 , requestMap :: MVar RequestMap
118 , initRsp :: MVar InitializeResponse
119 , config :: SessionConfig
120 , sessionCapabilities :: ClientCapabilities
123 class Monad m => HasReader r m where
125 asks :: (r -> b) -> m b
128 instance HasReader SessionContext Session where
129 ask = Session (lift $ lift Reader.ask)
131 instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
132 ask = lift $ lift Reader.ask
134 data SessionState = SessionState
138 , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
139 , curTimeoutId :: Int
140 , overridingTimeout :: Bool
141 -- ^ The last received message from the server.
142 -- Used for providing exception information
143 , lastReceivedMessage :: Maybe FromServerMessage
146 class Monad m => HasState s m where
151 modify :: (s -> s) -> m ()
152 modify f = get >>= put . f
154 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
155 modifyM f = get >>= f >>= put
157 instance HasState SessionState Session where
158 get = Session (lift State.get)
159 put = Session . lift . State.put
161 instance Monad m => HasState s (ConduitM a b (StateT s m))
164 put = lift . State.put
166 instance Monad m => HasState s (ConduitParser a (StateT s m))
169 put = lift . State.put
171 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
172 runSession context state (Session session) = runReaderT (runStateT conduit state) context
174 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
176 handler (Unexpected "ConduitParser.empty") = do
177 lastMsg <- fromJust . lastReceivedMessage <$> get
178 name <- getParserName
179 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
184 msg <- liftIO $ readChan (messageChan context)
188 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
189 watchdog = Conduit.awaitForever $ \msg -> do
190 curId <- curTimeoutId <$> get
192 ServerMessage sMsg -> yield sMsg
193 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
195 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
196 -- It also does not automatically send initialize and exit messages.
197 runSessionWithHandles :: Handle -- ^ Server in
198 -> Handle -- ^ Server out
199 -> ProcessHandle -- ^ Server process
200 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
202 -> ClientCapabilities
203 -> FilePath -- ^ Root directory
204 -> Session () -- ^ To exit the Server properly
207 runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
208 absRootDir <- canonicalizePath rootDir
210 hSetBuffering serverIn NoBuffering
211 hSetBuffering serverOut NoBuffering
212 -- This is required to make sure that we don’t get any
213 -- newline conversion or weird encoding issues.
214 hSetBinaryMode serverIn True
215 hSetBinaryMode serverOut True
217 reqMap <- newMVar newRequestMap
218 messageChan <- newChan
219 initRsp <- newEmptyMVar
221 mainThreadId <- myThreadId
223 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
224 initState tmp_dir = SessionState (IdInt 0) (VFS mempty tmp_dir)
225 mempty 0 False Nothing
226 runSession' ses = withSystemTempDirectory "lsp-test" $ \tmp_dir ->
227 runSession context (initState tmp_dir) ses
229 errorHandler = throwTo mainThreadId :: SessionException -> IO()
230 serverListenerLauncher =
231 forkIO $ catch (serverHandler serverOut context) errorHandler
232 server = (Just serverIn, Just serverOut, Nothing, serverProc)
233 serverAndListenerFinalizer tid =
234 finally (timeout (messageTimeout config * 1000000)
235 (runSession' exitServer))
236 (cleanupProcess server >> killThread tid)
238 (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer
239 (const $ runSession' session)
242 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
243 updateStateC = awaitForever $ \msg -> do
247 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
248 => FromServerMessage -> m ()
249 updateState (NotPublishDiagnostics n) = do
250 let List diags = n ^. params . diagnostics
251 doc = n ^. params . uri
253 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
254 in s { curDiagnostics = newDiags })
256 updateState (ReqApplyWorkspaceEdit r) = do
258 allChangeParams <- case r ^. params . edit . documentChanges of
260 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
261 return $ map getParams cs
262 Nothing -> case r ^. params . edit . changes of
264 mapM_ checkIfNeedsOpened (HashMap.keys cs)
265 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
266 Nothing -> error "No changes!"
269 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
270 return $ s { vfs = newVFS }
272 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
273 mergedParams = map mergeParams groupedParams
275 -- TODO: Don't do this when replaying a session
276 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
278 -- Update VFS to new document versions
279 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
280 latestVersions = map ((^. textDocument) . last) sortedVersions
281 bumpedVersions = map (version . _Just +~ 1) latestVersions
283 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
286 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
287 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
288 in s { vfs = newVFS }
290 where checkIfNeedsOpened uri = do
291 oldVFS <- vfs <$> get
294 -- if its not open, open it
295 unless (toNormalizedUri uri `Map.member` (vfsMap oldVFS)) $ do
296 let fp = fromJust $ uriToFilePath uri
297 contents <- liftIO $ T.readFile fp
298 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
299 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
300 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
303 newVFS <- liftIO $ openVFS (vfs s) msg
304 return $ s { vfs = newVFS }
306 getParams (TextDocumentEdit docId (List edits)) =
307 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
308 in DidChangeTextDocumentParams docId (List changeEvents)
310 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
312 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
314 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
316 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
317 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
318 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
319 updateState _ = return ()
321 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
323 h <- serverIn <$> ask
325 liftIO $ B.hPut h (addHeader $ encode msg)
327 -- | Execute a block f that will throw a 'Timeout' exception
328 -- after duration seconds. This will override the global timeout
329 -- for waiting for messages to arrive defined in 'SessionConfig'.
330 withTimeout :: Int -> Session a -> Session a
331 withTimeout duration f = do
332 chan <- asks messageChan
333 timeoutId <- curTimeoutId <$> get
334 modify $ \s -> s { overridingTimeout = True }
336 threadDelay (duration * 1000000)
337 writeChan chan (TimeoutMessage timeoutId)
339 modify $ \s -> s { curTimeoutId = timeoutId + 1,
340 overridingTimeout = False
344 data LogMsgType = LogServer | LogClient
347 -- | Logs the message if the config specified it
348 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
349 => LogMsgType -> a -> m ()
351 shouldLog <- asks $ logMessages . config
352 shouldColor <- asks $ logColor . config
353 liftIO $ when shouldLog $ do
354 when shouldColor $ setSGR [SetColor Foreground Dull color]
355 putStrLn $ arrow ++ showPretty msg
356 when shouldColor $ setSGR [Reset]
359 | t == LogServer = "<-- "
362 | t == LogServer = Magenta
365 showPretty = B.unpack . encodePretty