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 vfs = SessionState (IdInt 0) vfs
225 mempty 0 False Nothing
226 runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
228 errorHandler = throwTo mainThreadId :: SessionException -> IO()
229 serverListenerLauncher =
230 forkIO $ catch (serverHandler serverOut context) errorHandler
231 server = (Just serverIn, Just serverOut, Nothing, serverProc)
232 serverAndListenerFinalizer tid =
233 finally (timeout (messageTimeout config * 1000000)
234 (runSession' exitServer))
235 (cleanupProcess server >> killThread tid)
237 (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer
238 (const $ runSession' session)
241 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
242 updateStateC = awaitForever $ \msg -> do
246 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
247 => FromServerMessage -> m ()
248 updateState (NotPublishDiagnostics n) = do
249 let List diags = n ^. params . diagnostics
250 doc = n ^. params . uri
252 let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
253 in s { curDiagnostics = newDiags })
255 updateState (ReqApplyWorkspaceEdit r) = do
257 allChangeParams <- case r ^. params . edit . documentChanges of
259 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
260 return $ map getParams cs
261 Nothing -> case r ^. params . edit . changes of
263 mapM_ checkIfNeedsOpened (HashMap.keys cs)
264 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
265 Nothing -> error "No changes!"
268 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
269 return $ s { vfs = newVFS }
271 let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
272 mergedParams = map mergeParams groupedParams
274 -- TODO: Don't do this when replaying a session
275 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
277 -- Update VFS to new document versions
278 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
279 latestVersions = map ((^. textDocument) . last) sortedVersions
280 bumpedVersions = map (version . _Just +~ 1) latestVersions
282 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
285 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
286 newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
287 in s { vfs = newVFS }
289 where checkIfNeedsOpened uri = do
290 oldVFS <- vfs <$> get
293 -- if its not open, open it
294 unless (toNormalizedUri uri `Map.member` (vfsMap oldVFS)) $ do
295 let fp = fromJust $ uriToFilePath uri
296 contents <- liftIO $ T.readFile fp
297 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
298 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
299 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
302 let (newVFS,_) = openVFS (vfs s) msg
303 return $ s { vfs = newVFS }
305 getParams (TextDocumentEdit docId (List edits)) =
306 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
307 in DidChangeTextDocumentParams docId (List changeEvents)
309 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
311 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
313 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
315 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
316 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
317 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
318 updateState _ = return ()
320 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
322 h <- serverIn <$> ask
324 liftIO $ B.hPut h (addHeader $ encode msg)
326 -- | Execute a block f that will throw a 'Timeout' exception
327 -- after duration seconds. This will override the global timeout
328 -- for waiting for messages to arrive defined in 'SessionConfig'.
329 withTimeout :: Int -> Session a -> Session a
330 withTimeout duration f = do
331 chan <- asks messageChan
332 timeoutId <- curTimeoutId <$> get
333 modify $ \s -> s { overridingTimeout = True }
335 threadDelay (duration * 1000000)
336 writeChan chan (TimeoutMessage timeoutId)
338 modify $ \s -> s { curTimeoutId = timeoutId + 1,
339 overridingTimeout = False
343 data LogMsgType = LogServer | LogClient
346 -- | Logs the message if the config specified it
347 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
348 => LogMsgType -> a -> m ()
350 shouldLog <- asks $ logMessages . config
351 shouldColor <- asks $ logColor . config
352 liftIO $ when shouldLog $ do
353 when shouldColor $ setSGR [SetColor Foreground Dull color]
354 putStrLn $ arrow ++ showPretty msg
355 when shouldColor $ setSGR [Reset]
358 | t == LogServer = "<-- "
361 | t == LogServer = Magenta
364 showPretty = B.unpack . encodePretty