lsp 2.7.0.1 → 2.8.0.0
raw patch · 10 files changed
+508/−137 lines, 10 filesdep +websocketsdep ~containersdep ~lsp-typesnew-uploader
Dependencies added: websockets
Dependency ranges changed: containers, lsp-types
Files
- ChangeLog.md +20/−7
- example/Reactor.hs +1/−1
- lsp.cabal +6/−5
- src/Language/LSP/Diagnostics.hs +12/−2
- src/Language/LSP/Server.hs +1/−0
- src/Language/LSP/Server/Control.hs +268/−76
- src/Language/LSP/Server/Core.hs +97/−25
- src/Language/LSP/Server/Processing.hs +35/−7
- src/Language/LSP/VFS.hs +65/−11
- test/VspSpec.hs +3/−3
ChangeLog.md view
@@ -1,5 +1,18 @@ # Revision history for lsp +## 2.8.0.0 -- 2026-02-14++- Fix link to swarm LSP server+- Add support for FileOperationOptions+- Replace forkIO with async for server listener+- Graceful server exit+- Add support for setting up language servers to use websockets+- Allow flushing diagnostics by source and uri+- Track closed files in the VFS+- Track the languageId in Virtual File+- Treat undefined and null initialization options the same way+- Relax dependency version bounds+ ## 2.7.0.1 -- 2024-12-31 - Relax dependency version bounds@@ -24,13 +37,13 @@ ## 2.4.0.0 -- Server-created progress now will not send reports until and unless the client +- Server-created progress now will not send reports until and unless the client confirms the progress token creation.-- Progress helper functions now can take a progress token provided by the client, +- Progress helper functions now can take a progress token provided by the client, so client-initiated progress can now be supported properly. - The server options now allow the user to say whether the server should advertise support for client-initiated progress or not.-- The server now dynamically registers for `workspace/didChangeConfiguration` +- The server now dynamically registers for `workspace/didChangeConfiguration` notifications, to ensure that newer clients continue to send them. - Removed `getCompletionPrefix` from the `VFS` module. This is specific to completing Haskell identifiers and doesn't belong here. It has already been moved to `ghcide`@@ -52,13 +65,13 @@ - `parseConfig` will now be called on the object corresponding to the configuration section, not the whole object. - New callback for when configuration changes, to allow servers to react.-- The logging of messages sent by the protocol has been disabled, as this can prove +- The logging of messages sent by the protocol has been disabled, as this can prove troublesome for servers that log these to the client: https://github.com/haskell/lsp/issues/447 ## 2.1.0.0 * Fix handling of optional methods.-* `staticHandlers` now takes the client capabilities as an argument. +* `staticHandlers` now takes the client capabilities as an argument. These are static across the lifecycle of the server, so this allows a server to decide at construction e.g. whether to provide handlers for resolve methods depending on whether the client supports it.@@ -235,10 +248,10 @@ `LanguageContextEnv` needed to run an `LspT`, as well as anything else your monad needs. ```haskell-type +type ServerDefinition { ... , doInitialize = \env _req -> pure $ Right env-, interpretHandler = \env -> Iso +, interpretHandler = \env -> Iso (runLspT env) -- how to convert from IO ~> m liftIO -- how to convert from m ~> IO }
example/Reactor.hs view
@@ -246,7 +246,7 @@ logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info mdoc <- getVirtualFile doc case mdoc of- Just (VirtualFile _version str _) -> do+ Just (VirtualFile _version str _ _) -> do logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info Nothing -> do logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info
lsp.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp-version: 2.7.0.1+version: 2.8.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to@@ -18,7 +18,7 @@ copyright: Alan Zimmerman, 2016-2021 category: Development build-type: Simple-extra-source-files:+extra-doc-files: ChangeLog.md README.md @@ -59,7 +59,7 @@ , base >=4.11 && <5 , bytestring >=0.10 && <0.13 , co-log-core ^>=0.3- , containers >=0.6 && < 0.8+ , containers >=0.6 && < 0.9 , data-default >=0.7 && < 0.9 , directory ^>=1.3 , exceptions ^>=0.10@@ -68,10 +68,10 @@ , hashable >=1.4 && < 1.6 , lens >=5.1 && <5.4 , lens-aeson ^>=1.2- , lsp-types ^>=2.3+ , lsp-types ^>=2.4 , mtl >=2.2 && <2.4 , prettyprinter ^>=1.7- , sorted-list ^>=0.2.1+ , sorted-list >=0.2.1 && < 0.4 , stm ^>=2.5 , text >=1 && <2.2 , text-rope >=0.2 && <0.4@@ -79,6 +79,7 @@ , unliftio ^>=0.2 , unliftio-core ^>=0.2 , unordered-containers ^>=0.2+ , websockets ^>=0.13 executable lsp-demo-reactor-server import: warnings
src/Language/LSP/Diagnostics.hs view
@@ -11,6 +11,7 @@ StoreItem (..), partitionBySource, flushBySource,+ flushBySourceAndUri, updateDiagnostics, getDiagnosticParamsFor, @@ -41,8 +42,10 @@ type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem -data StoreItem- = StoreItem (Maybe J.Int32) DiagnosticsBySource+data StoreItem = StoreItem+ { documentVersion :: Maybe J.Int32+ , diagnostics :: DiagnosticsBySource+ } deriving (Show, Eq) type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic)@@ -59,6 +62,13 @@ flushBySource store (Just source) = HM.map remove store where remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags)++flushBySourceAndUri :: DiagnosticStore -> Maybe Text -> J.NormalizedUri -> DiagnosticStore+flushBySourceAndUri store msource uri = HM.mapWithKey remove store+ where+ remove k item+ | k == uri = item{diagnostics = Map.delete msource $ diagnostics item}+ | otherwise = item -- ---------------------------------------------------------------------
src/Language/LSP/Server.hs view
@@ -50,6 +50,7 @@ -- * Diagnostics publishDiagnostics, flushDiagnosticsBySource,+ flushDiagnosticsBySourceAndUri, -- * Progress withProgress,
src/Language/LSP/Server/Control.hs view
@@ -1,18 +1,36 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} module Language.LSP.Server.Control ( -- * Running- runServer, runServerWith,- runServerWithHandles,+ runServerWithConfig,+ ServerConfig (..), LspServerLog (..),++ -- ** Using standard 'IO' 'Handle's+ runServer,++ -- ** Using 'Handle's+ runServerWithHandles,+ prependHeader,+ parseHeaders,++ -- ** Using websockets+ WebsocketConfig (..),+ withWebsocket,+ withWebsocketRunServer, ) where import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) import Colog.Core qualified as L import Control.Applicative ((<|>)) import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM.TChan+import Control.Exception (catchJust, finally, throwIO) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM@@ -31,20 +49,26 @@ import Language.LSP.Server.Core import Language.LSP.Server.Processing qualified as Processing import Language.LSP.VFS+import Network.WebSockets qualified as WS import Prettyprinter import System.IO+import System.IO.Error (isResourceVanishedError) data LspServerLog = LspProcessingLog Processing.LspProcessingLog | DecodeInitializeError String | HeaderParseFail [String] String | EOF+ | BrokenPipeWhileSending TL.Text -- truncated outgoing message (including header) | Starting+ | ServerStopped | ParsedMsg T.Text | SendMsg TL.Text+ | WebsocketLog WebsocketLog deriving (Show) instance Pretty LspServerLog where+ pretty ServerStopped = "Server stopped" pretty (LspProcessingLog l) = pretty l pretty (DecodeInitializeError err) = vsep@@ -57,9 +81,15 @@ , pretty (intercalate " > " ctxs) <> ": " <+> pretty err ] pretty EOF = "Got EOF"- pretty Starting = "Starting server"+ pretty (BrokenPipeWhileSending msg) =+ vsep+ [ "Broken pipe while sending (client likely closed output handle):"+ , indent 2 (pretty msg)+ ]+ pretty Starting = "Server starting" pretty (ParsedMsg msg) = "---> " <> pretty msg pretty (SendMsg msg) = "<--2-- " <> pretty msg+ pretty (WebsocketLog msg) = "Websocket:" <+> pretty msg -- --------------------------------------------------------------------- @@ -71,19 +101,21 @@ runServer :: forall config. ServerDefinition config -> IO Int runServer = runServerWithHandles- ioLogger- lspLogger+ defaultIOLogger+ defaultLspLogger stdin stdout++defaultIOLogger :: LogAction IO (WithSeverity LspServerLog)+defaultIOLogger = L.cmap (show . prettyMsg) L.logStringStderr where prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l)- ioLogger :: LogAction IO (WithSeverity LspServerLog)- ioLogger = L.cmap (show . prettyMsg) L.logStringStderr- lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)- lspLogger =- let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger- in clientLogger <> L.hoistLogAction liftIO ioLogger +defaultLspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)+defaultLspLogger =+ let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger+ in clientLogger <> L.hoistLogAction liftIO defaultIOLogger+ {- | Starts a language server over the specified handles. This function will return once the @exit@ notification is received. -}@@ -108,14 +140,23 @@ let clientIn = BS.hGetSome hin defaultChunkSize - clientOut out = do- BSL.hPut hout out- hFlush hout+ clientOut out =+ catchJust+ (\e -> if isResourceVanishedError e then Just e else Nothing)+ (BSL.hPut hout out >> hFlush hout)+ ( \e -> do+ let txt = TL.toStrict $ TL.take 400 $ TL.decodeUtf8 out -- limit size+ ioLogger <& BrokenPipeWhileSending (TL.fromStrict txt) `WithSeverity` Error+ throwIO e+ ) runServerWith ioLogger logger clientIn clientOut serverDefinition {- | Starts listening and sending requests and responses using the specified I/O.++ Assumes that the client sends (and wants to receive) the Content-Length+ header. If you do not want this to be the case, use 'runServerWithConfig' -} runServerWith :: -- | The logger to use outside the main body of the server where we can't assume the ability to send messages.@@ -123,22 +164,43 @@ -- | The logger to use once the server has started and can successfully send messages. LogAction (LspM config) (WithSeverity LspServerLog) -> -- | Client input.- IO BS.ByteString ->+ IO BS.StrictByteString -> -- | Function to provide output to.- (BSL.ByteString -> IO ()) ->+ (BSL.LazyByteString -> IO ()) -> ServerDefinition config -> IO Int -- exit code-runServerWith ioLogger logger clientIn clientOut serverDefinition = do- ioLogger <& Starting `WithSeverity` Info-- cout <- atomically newTChan :: IO (TChan J.Value)- _rhpid <- forkIO $ sendServer ioLogger cout clientOut+runServerWith ioLogger lspLogger inwards outwards =+ runServerWithConfig ServerConfig{prepareOutwards = prependHeader, parseInwards = parseHeaders, ..} - let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg+-- --------------------------------------------------------------------- - ioLoop ioLogger logger clientIn serverDefinition emptyVFS sendMsg+data ServerConfig config = ServerConfig+ { ioLogger :: LogAction IO (WithSeverity LspServerLog)+ -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages.+ , lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)+ -- ^ The logger to use once the server has started and can successfully send messages.+ , inwards :: IO BS.StrictByteString+ -- ^ Client input.+ , outwards :: BSL.LazyByteString -> IO ()+ -- ^ Function to provide output to.+ , prepareOutwards :: BSL.LazyByteString -> BSL.LazyByteString+ -- ^ how to prepare an outgoing response for sending. This can be used, to e.g. prepend the Content-Length header, c.f. 'prependHeader'+ , parseInwards :: Attoparsec.Parser BS.StrictByteString+ -- ^ how to parse the input. This can be used to consume the Content-Length and Content-Type headers, c.f. 'parseHeaders'+ } - return 1+runServerWithConfig ::+ ServerConfig config ->+ ServerDefinition config ->+ IO Int+runServerWithConfig ServerConfig{..} serverDefinition = do+ ioLogger <& Starting `WithSeverity` Info+ cout <- atomically newTChan :: IO (TChan FromServerMessage)+ withAsync (sendServer ioLogger cout outwards prepareOutwards) $ \sendServerAsync -> do+ let sendMsg = atomically . writeTChan cout+ res <- ioLoop ioLogger lspLogger inwards parseInwards serverDefinition emptyVFS sendMsg (wait sendServerAsync)+ ioLogger <& ServerStopped `WithSeverity` Info+ return res -- --------------------------------------------------------------------- @@ -146,62 +208,50 @@ forall config. LogAction IO (WithSeverity LspServerLog) -> LogAction (LspM config) (WithSeverity LspServerLog) ->- IO BS.ByteString ->+ IO BS.StrictByteString ->+ Attoparsec.Parser BS.StrictByteString -> ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) ->- IO ()-ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do+ IO () ->+ IO Int+ioLoop ioLogger logger clientIn parser serverDefinition vfs sendMsg waitSenderFinish = do minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of- Nothing -> pure ()+ Nothing -> pure 1 Just (msg, remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of- Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error+ Left err -> do+ ioLogger <& DecodeInitializeError err `WithSeverity` Error+ return 1 Right initialize -> do- mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg initialize+ mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg waitSenderFinish initialize case mInitResp of- Nothing -> pure ()+ Nothing -> pure 1 Just env -> runLspT env $ loop (parse parser remainder) where pioLogger = L.cmap (fmap LspProcessingLog) ioLogger pLogger = L.cmap (fmap LspProcessingLog) logger - loop :: Result BS.ByteString -> LspM config () loop = go where go r = do- res <- parseOne logger clientIn r- case res of- Nothing -> pure ()- Just (msg, remainder) -> do- Processing.processMessage pLogger $ BSL.fromStrict msg- go (parse parser remainder)-- parser = do- try contentType <|> return ()- len <- contentLength- try contentType <|> return ()- _ <- string _ONE_CRLF- Attoparsec.take len-- contentLength = do- _ <- string "Content-Length: "- len <- decimal- _ <- string _ONE_CRLF- return len-- contentType = do- _ <- string "Content-Type: "- skipWhile (/= '\r')- _ <- string _ONE_CRLF- return ()+ b <- isExiting+ if b+ then pure 0+ else do+ res <- parseOne logger clientIn r+ case res of+ Nothing -> pure 1+ Just (msg, remainder) -> do+ Processing.processMessage pLogger $ BSL.fromStrict msg+ go (parse parser remainder) parseOne :: MonadIO m => LogAction m (WithSeverity LspServerLog) ->- IO BS.ByteString ->- Result BS.ByteString ->+ IO BS.StrictByteString ->+ Result BS.StrictByteString -> m (Maybe (BS.ByteString, BS.ByteString)) parseOne logger clientIn = go where@@ -210,11 +260,7 @@ pure Nothing go (Partial c) = do bs <- liftIO clientIn- if BS.null bs- then do- logger <& EOF `WithSeverity` Error- pure Nothing- else go (c bs)+ go (c bs) go (Done remainder msg) = do -- TODO: figure out how to re-enable -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447@@ -223,30 +269,176 @@ -- --------------------------------------------------------------------- +data WebsocketLog+ = WebsocketShutDown+ | WebsocketNewConnection+ | WebsocketConnectionClosed+ | WebsocketPing+ | WebsocketStarted+ | WebsocketIncomingRequest+ | WebsocketOutgoingResponse+ deriving stock (Show)++instance Pretty WebsocketLog where+ pretty l = case l of+ WebsocketPing -> "Ping"+ WebsocketStarted -> "Started Server, waiting for connections"+ WebsocketShutDown -> "Shut down server"+ WebsocketNewConnection -> "New connection established"+ WebsocketIncomingRequest -> "Received request"+ WebsocketConnectionClosed -> "Closed connection to client"+ WebsocketOutgoingResponse -> "Sent response"++-- | 'host' and 'port' of the websocket server to set up+data WebsocketConfig = WebsocketConfig+ { host :: !String+ -- ^ the host of the websocket server, e.g. @"localhost"@+ , port :: !Int+ -- ^ the port of the websocket server, e.g. @8080@+ }++-- | Set up a websocket server, then call call the continuation (in our case this corresponds to the language server) after accepting a connection+withWebsocket ::+ -- | The logger+ LogAction IO (WithSeverity LspServerLog) ->+ -- | The configuration of the websocket server+ WebsocketConfig ->+ -- | invoke the lsp server, passing communication functions+ (IO BS.StrictByteString -> (BSL.LazyByteString -> IO ()) -> IO r) ->+ IO ()+withWebsocket logger conf startLspServer = do+ let wsLogger = L.cmap (fmap WebsocketLog) logger++ WS.runServer (host conf) (port conf) $ \pending -> do+ conn <- WS.acceptRequest pending+ wsLogger <& WebsocketNewConnection `WithSeverity` Debug++ outChan <- newChan+ inChan <- newChan++ let inwards = readChan inChan+ outwards = writeChan outChan++ WS.withPingThread conn 30 (wsLogger <& WebsocketPing `WithSeverity` Debug) $ do+ withAsync (startLspServer inwards outwards) $ \lspAsync ->+ ( do+ link lspAsync++ race_+ ( forever $ do+ msg <- readChan outChan+ wsLogger <& WebsocketOutgoingResponse `WithSeverity` Debug+ WS.sendTextData conn msg+ )+ ( forever $ do+ msg <- WS.receiveData conn+ wsLogger <& WebsocketIncomingRequest `WithSeverity` Debug+ writeChan inChan msg+ -- NOTE: since the parser assumes to consume messages+ -- incrementally,we need to somehow signal that the+ -- content has terminated - we do this by sending the+ -- empty string (instead of parsing exactly the content+ -- length, like in the stdio case)+ writeChan inChan ""+ )+ )+ `finally` do+ wsLogger <& WebsocketConnectionClosed `WithSeverity` Debug++{- | Given a 'WebsocketConfig', wait for connections using a websocket server.+The continuation passed is called for every new connection and can be used+to initialize state that is specific to that respective connection.++This combines 'withWebsocket' and 'runServerWithConfig'.+-}+withWebsocketRunServer ::+ -- | Configuration for the websocket+ WebsocketConfig ->+ -- | How to set up a new 'ServerDefinition' for a specific configuration. z+ -- This is passed as CPS'd 'IO' to allow for setting (- and cleaning) up+ -- a server per websocket connection+ ((ServerDefinition config -> IO Int) -> IO Int) ->+ -- | The 'IO' logger+ LogAction IO (WithSeverity LspServerLog) ->+ -- | The logger that logs in 'LspM' to the client+ LogAction (LspM config) (WithSeverity LspServerLog) ->+ IO ()+withWebsocketRunServer wsConf withLspDefinition ioLogger lspLogger =+ withWebsocket ioLogger wsConf $ \inwards outwards -> do+ withLspDefinition $ \lspDefinition ->+ runServerWithConfig+ ServerConfig+ { ioLogger+ , lspLogger+ , inwards+ , outwards+ , -- NOTE: if you run the language server on websockets, you do not+ -- need to prepend headers to requests and responses, because+ -- the chunking is already handled by the websocket, i.e. there's+ -- no situation where the client or the server has to rely on input/+ -- output chunking+ prepareOutwards = id+ , parseInwards = Attoparsec.takeByteString+ }+ lspDefinition++-- ---------------------------------------------------------------------+ -- | Simple server to make sure all output is serialised-sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()-sendServer _logger msgChan clientOut = do- forever $ do+sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan FromServerMessage -> (BSL.LazyByteString -> IO ()) -> (BSL.LazyByteString -> BSL.LazyByteString) -> IO ()+sendServer _logger msgChan clientOut prepareMessage = go+ where+ go = do msg <- atomically $ readTChan msgChan -- We need to make sure we only send over the content of the message, -- and no other tags/wrapper stuff let str = J.encode msg-- let out =- BSL.concat- [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)- , BSL.fromStrict _TWO_CRLF- , str- ]+ let out = prepareMessage str clientOut out+ -- close the client sender when we send out the shutdown request's response+ case msg of+ FromServerRsp SMethod_Shutdown _ -> pure ()+ _ -> go -- TODO: figure out how to re-enable -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 -- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug -_ONE_CRLF :: BS.ByteString+-- | prepend a Content-Length header to the given message+prependHeader :: BSL.LazyByteString -> BSL.LazyByteString+prependHeader str =+ BSL.concat+ [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)+ , BSL.fromStrict _TWO_CRLF+ , str+ ]++{- | parse Content-Length and Content-Type headers and then consume+ input with length of the Content-Length+-}+parseHeaders :: Attoparsec.Parser BS.StrictByteString+parseHeaders = do+ try contentType <|> return ()+ len <- contentLength+ try contentType <|> return ()+ _ <- string _ONE_CRLF+ Attoparsec.take len+ where+ contentLength = do+ _ <- string "Content-Length: "+ len <- decimal+ _ <- string _ONE_CRLF+ return len++ contentType = do+ _ <- string "Content-Type: "+ skipWhile (/= '\r')+ _ <- string _ONE_CRLF+ return ()++_ONE_CRLF :: BS.StrictByteString _ONE_CRLF = "\r\n"-_TWO_CRLF :: BS.ByteString+_TWO_CRLF :: BS.StrictByteString _TWO_CRLF = "\r\n\r\n"
src/Language/LSP/Server/Core.hs view
@@ -21,7 +21,7 @@ ) import Control.Concurrent.Extra as C import Control.Concurrent.STM-import Control.Lens (at, (^.), (^?), _Just)+import Control.Lens (ix, (^.), (^?), _Just) import Control.Monad import Control.Monad.Catch ( MonadCatch,@@ -137,6 +137,9 @@ -- ^ The delay before starting a progress reporting session, in microseconds , resProgressUpdateDelay :: Int -- ^ The delay between sending progress updates, in microseconds+ , resWaitSender :: !(IO ())+ -- ^ An IO action that waits for the sender thread to finish sending all pending messages.+ -- This is used to ensure all responses are sent before the server exits. See Note [Shutdown] } -- ---------------------------------------------------------------------@@ -211,9 +214,9 @@ , resRegistrationsReq :: !(TVar (RegistrationMap Request)) , resLspId :: !(TVar Int32) , resShutdown :: !(C.Barrier ())- -- ^ Has the server received 'shutdown'? Can be used to conveniently trigger e.g. thread termination,- -- but if you need a cleanup action to terminate before exiting, then you should install a full- -- 'shutdown' handler+ -- ^ Barrier signaled when the server receives the 'shutdown' request. See Note [Shutdown]+ , resExit :: !(C.Barrier ())+ -- ^ Barrier signaled when the server receives the 'exit' notification. See Note [Shutdown] } type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)@@ -294,6 +297,18 @@ -- ^ The delay before starting a progress reporting session, in microseconds , optProgressUpdateDelay :: Int -- ^ The delay between sending progress updates, in microseconds+ , optWorkspaceDidCreateFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidCreateFiles' request, in case the language server supports it+ , optWorkspaceWillCreateFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillCreateFiles' notification, in case the language server supports it+ , optWorkspaceDidRenameFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidRenameFiles' request, in case the language server supports it+ , optWorkspaceWillRenameFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillRenameFiles' notification, in case the language server supports it+ , optWorkspaceDidDeleteFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidDeleteFiles' request, in case the language server supports it+ , optWorkspaceWillDeleteFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillDeleteFiles' notification, in case the language server supports it } instance Default Options where@@ -312,6 +327,12 @@ -- See Note [Delayed progress reporting] 0 0+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing defaultOptions :: Options defaultOptions = def@@ -322,7 +343,8 @@ it is parameterized over a config type variable representing the type for the specific configuration data the language server needs to use. -}-data ServerDefinition config = forall m a.+data ServerDefinition config+ = forall m a. ServerDefinition { defaultConfig :: config -- ^ The default value we initialize the config variable to.@@ -432,7 +454,7 @@ getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) getVirtualFile uri = do dat <- vfsData <$> getsState resVFS- pure $ dat ^. vfsMap . at uri+ pure $ dat ^? vfsMap . ix uri . _Open {-# INLINE getVirtualFile #-} getVirtualFiles :: MonadLsp config m => m VFS@@ -470,7 +492,7 @@ let uri = doc ^. L.uri mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of- Just (VirtualFile lspver _ _) -> lspver+ Just (VirtualFile lspver _ _ _) -> lspver Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) {-# INLINE getVersionedTextDoc #-}@@ -655,6 +677,29 @@ -- --------------------------------------------------------------------- +{- | Remove all diagnostics from a particular uri and source, and send the updates to+ the client.+-}+flushDiagnosticsBySourceAndUri ::+ MonadLsp config m =>+ -- | Max number of diagnostics to send+ Int ->+ Maybe Text ->+ NormalizedUri ->+ m ()+flushDiagnosticsBySourceAndUri maxDiagnosticCount msource uri = join $ stateState resDiagnostics $ \oldDiags ->+ let !newDiags = flushBySourceAndUri oldDiags msource uri+ -- Send the updated diagnostics to the client+ act = forM_ (HM.keys newDiags) $ \uri' -> do+ let mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri'+ case mdp of+ Nothing -> return ()+ Just params -> do+ sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params+ in (act, newDiags)++-- ---------------------------------------------------------------------+ {- | The changes in a workspace edit should be applied from the end of the file toward the start. Sort them into this order. -}@@ -730,6 +775,17 @@ Just _ -> True Nothing -> False +{- | Check if the server has received the 'exit' notification.+See Note [Shutdown]+-}+isExiting :: (m ~ LspM config) => m Bool+isExiting = do+ b <- resExit . resState <$> getLspEnv+ r <- liftIO $ C.waitBarrierMaybe b+ pure $ case r of+ Just () -> True+ Nothing -> False+ -- | Blocks until the server receives a 'shutdown' request. waitShuttingDown :: (m ~ LspM config) => m () waitShuttingDown = do@@ -775,13 +831,13 @@ many clients seem to follow the sensible approach laid out here: https://github.com/microsoft/language-server-protocol/issues/972#issuecomment-626668243 -To make this work, we try to be tolerant by using the following strategy.-When we receive a configuration object from any of the sources above, we first-check to see if it has a field corresponding to our configuration section. If it-does, then we assume that it our config and try to parse it. If it does not, we-try to parse the entire config object. This hopefully lets us handle a variety-of sensible cases where the client sends us mostly our config, either wrapped-in our section or not.+To make this work, we try to be tolerant by using the following strategy. When+we receive a configuration object from any of the sources above, we first check+to see if it has a field corresponding to our configuration section. If it does,+then we assume that it is our config and try to parse it. If it does not parse,+we try to parse the entire config object. This hopefully lets us handle a+variety of sensible cases where the client sends us mostly our config, either+wrapped in our section or not. -} {- Note [Client- versus server-initiated progress]@@ -819,18 +875,34 @@ -} {- Note [Shutdown]-The 'shutdown' request basically tells the server to clean up and stop doing things.-In particular, it allows us to ignore or reject all further messages apart from 'exit'.+~~~~~~~~~~~~~~~~~~+The LSP protocol has a two-phase shutdown sequence: -We also provide a `Barrier` that indicates whether or not we are shutdown, this can-be convenient, e.g. you can race a thread against `waitBarrier` to have it automatically-be cancelled when we receive `shutdown`.+1. `shutdown` request: ask the server to stop doing work and finish+ any in-flight operations.+2. `exit` notification: tell the server to terminate the process. -Shutdown is a request, and the client won't send `exit` until a server responds, so if you-want to be sure that some cleanup happens, you need to ensure we don't respond to `shutdown`-until it's done. The best way to do this is just to install a specific `shutdown` handler.+We expose two `Barrier`s to track this state: -After the `shutdown` request, we don't handle any more requests and notifications other than-`exit`. We also don't handle any more responses to requests we have sent but just throw the-responses away.+- `resShutdown`: signalled when we receive the `shutdown` request.+ Use `isShuttingDown` to check this.+- `resExit`: signalled when we receive the `exit` notification.+ Use `isExiting` to check this.++Shutdown is itself a request, and we assume the client will not send+`exit` before `shutdown`. If you want to be sure that some cleanup has+run before the server exits, make that cleanup part of your customize+`shutdown` handler.++We use a dedicated sender thread to serialise all messages that go to+the client. That thread is set up to stop sending messages after the+`shutdown` response has been sent.++While handling the `shutdown` request we call `resWaitSender` to wait+for the sender thread to flush and finish. Otherwise, we might get a+"broken pipe" error from trying to send messages after the client has+closed our output handle.++After the `shutdown` request has been processed, we do not handle any+more requests or notifications except for `exit`. -}
src/Language/LSP/Server/Processing.hs view
@@ -33,6 +33,7 @@ Null, Options, )+import Data.Aeson qualified as J import Data.Aeson.Lens () import Data.Aeson.Types hiding ( Error,@@ -58,7 +59,6 @@ import Language.LSP.Server.Core import Language.LSP.VFS as VFS import Prettyprinter-import System.Exit data LspProcessingLog = VfsLog VfsLog@@ -118,9 +118,11 @@ ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) ->+ -- | Action that waits for the sender thread to finish. We use it to set 'LanguageContextEnv.resWaitSender', See Note [Shutdown].+ IO () -> TMessage Method_Initialize -> IO (Maybe (LanguageContextEnv config))-initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do+initializeRequestHandler logger ServerDefinition{..} vfs sendFunc waitSender req = do let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do sendResp $ makeResponseError (req ^. L.id) err@@ -145,6 +147,9 @@ configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) initialConfig <- case configObject of+ -- Treat non-existing "initializationOptions" and `"initializationOptions": null` the same way.+ Nothing -> pure defaultConfig+ Just J.Null -> pure defaultConfig Just o -> case parseConfig defaultConfig o of Right newConfig -> do liftIO $ logger <& LspCore (NewConfig o) `WithSeverity` Debug@@ -153,7 +158,6 @@ -- Warn not error here, since initializationOptions is pretty unspecified liftIO $ logger <& LspCore (ConfigurationParseError o err) `WithSeverity` Warning pure defaultConfig- Nothing -> pure defaultConfig stateVars <- liftIO $ do resVFS <- newTVarIO (VFSData vfs mempty)@@ -169,6 +173,7 @@ resRegistrationsReq <- newTVarIO mempty resLspId <- newTVarIO 0 resShutdown <- C.newBarrier+ resExit <- C.newBarrier pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up@@ -184,6 +189,7 @@ rootDir (optProgressStartDelay options) (optProgressUpdateDelay options)+ waitSender configChanger config = forward interpreter (onConfigChange config) handlers = transmuteHandlers interpreter (staticHandlers clientCaps) interpreter = interpretHandler initializationResult@@ -410,12 +416,23 @@ Just x -> Just (InL x) Nothing -> Nothing - workspace = WorkspaceOptions{_workspaceFolders = workspaceFolder, _fileOperations = Nothing}+ workspace = WorkspaceOptions{_workspaceFolders = workspaceFolder, _fileOperations = Just fileOperations}+ workspaceFolder = supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) + fileOperations =+ FileOperationOptions+ { _didCreate = join $ supported' SMethod_WorkspaceDidCreateFiles $ optWorkspaceDidCreateFileOperationRegistrationOptions o+ , _willCreate = join $ supported' SMethod_WorkspaceWillCreateFiles $ optWorkspaceWillCreateFileOperationRegistrationOptions o+ , _didRename = join $ supported' SMethod_WorkspaceDidRenameFiles $ optWorkspaceDidRenameFileOperationRegistrationOptions o+ , _willRename = join $ supported' SMethod_WorkspaceWillRenameFiles $ optWorkspaceWillRenameFileOperationRegistrationOptions o+ , _didDelete = join $ supported' SMethod_WorkspaceDidDeleteFiles $ optWorkspaceDidDeleteFileOperationRegistrationOptions o+ , _willDelete = join $ supported' SMethod_WorkspaceWillDeleteFiles $ optWorkspaceWillDeleteFileOperationRegistrationOptions o+ }+ diagnosticProvider = supported' SMethod_TextDocumentDiagnostic $ InL $@@ -437,6 +454,13 @@ SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration] SMethod_Initialized -> handle' logger (Just $ \_ -> initialDynamicRegistrations logger >> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg+ SMethod_Exit -> handle' logger (Just $ \_ -> signalExit) m msg+ where+ signalExit :: LspM config ()+ signalExit = do+ logger <& Exiting `WithSeverity` Info+ b <- resExit . resState <$> getLspEnv+ liftIO $ signalBarrier b () SMethod_Shutdown -> handle' logger (Just $ \_ -> signalShutdown) m msg where -- See Note [Shutdown]@@ -494,6 +518,10 @@ -- See Note [Shutdown] IsClientReq | shutdown, not (allowedMethod m) -> requestDuringShutdown msg IsClientReq -> case pickHandler dynReqHandlers reqHandlers of+ Just h | SMethod_Shutdown <- m -> do+ waitSender <- resWaitSender <$> getLspEnv+ liftIO $ h msg (runLspT env . sendResponse msg)+ liftIO waitSender Just h -> liftIO $ h msg (runLspT env . sendResponse msg) Nothing | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (runLspT env . sendResponse msg)@@ -554,9 +582,9 @@ liftIO cancelAction exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Method_Exit-exitNotificationHandler logger _ = do- logger <& Exiting `WithSeverity` Info- liftIO exitSuccess+exitNotificationHandler _logger _ = do+ -- default exit handler do nothing+ return () -- | Default Shutdown handler shutdownRequestHandler :: Handler IO Method_Shutdown
src/Language/LSP/VFS.hs view
@@ -18,11 +18,19 @@ VFS (..), vfsMap, VirtualFile (..),+ ClosedVirtualFile (..),+ VirtualFileEntry (..), lsp_version, file_version, file_text,+ language_id,+ _Open,+ _Closed, virtualFileText, virtualFileVersion,+ virtualFileLanguageKind,+ closedVirtualFileLanguageKind,+ virtualFileEntryLanguageKind, VfsLog (..), -- * Managing the VFS@@ -92,16 +100,36 @@ -- remains in the map. , _file_text :: !Rope -- ^ The full contents of the document+ , _language_id :: !(Maybe J.LanguageKind)+ -- ^ The text document's language identifier+ -- This is a Maybe, since when we use the VFS as a client+ -- we don't have this information, since server sends WorkspaceEdit+ -- notifications without a language kind.+ -- When using the VFS in a server, this should always be Just. } deriving (Show) +{- | Represents a closed file in the VFS+We are keeping track of this in order to be able to get information+on virtual files after they were closed.+-}+data ClosedVirtualFile = ClosedVirtualFile+ { _language_id :: !(Maybe J.LanguageKind)+ -- ^ see 'VirtualFile._language_id'+ }+ deriving (Show)++data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile+ deriving (Show)+ data VFS = VFS- { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)+ { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFileEntry) } deriving (Show) data VfsLog = SplitInsideCodePoint Utf16.Position Rope+ | ApplyChangeToClosedFile J.NormalizedUri | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri@@ -113,6 +141,7 @@ instance Pretty VfsLog where pretty (SplitInsideCodePoint pos r) = "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r+ pretty (ApplyChangeToClosedFile uri) = "VFS: trying to apply a change to a closed file" <+> pretty uri pretty (URINotFound uri) = "VFS: don't know about URI" <+> pretty uri pretty (Opening uri) = "VFS: opening" <+> pretty uri pretty (Closing uri) = "VFS: closing" <+> pretty uri@@ -122,7 +151,9 @@ pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> pretty uri makeFieldsNoPrefix ''VirtualFile+makeFieldsNoPrefix ''ClosedVirtualFile makeFieldsNoPrefix ''VFS+makePrisms ''VirtualFileEntry --- @@ -132,6 +163,22 @@ virtualFileVersion :: VirtualFile -> Int32 virtualFileVersion vf = _lsp_version vf +virtualFileLanguageKind :: VirtualFile -> Maybe J.LanguageKind+virtualFileLanguageKind vf = vf ^. language_id++closedVirtualFileLanguageKind :: ClosedVirtualFile -> Maybe J.LanguageKind+closedVirtualFileLanguageKind vf = vf ^. language_id++virtualFileEntryLanguageKind :: VirtualFileEntry -> Maybe J.LanguageKind+virtualFileEntryLanguageKind (Open vf) = virtualFileLanguageKind vf+virtualFileEntryLanguageKind (Closed vf) = closedVirtualFileLanguageKind vf++toClosedVirtualFile :: VirtualFile -> ClosedVirtualFile+toClosedVirtualFile vf =+ ClosedVirtualFile+ { _language_id = virtualFileLanguageKind vf+ }+ --- emptyVFS :: VFS@@ -142,10 +189,10 @@ -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS' openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidOpen -> m () openVFS logger msg = do- let J.TextDocumentItem (J.toNormalizedUri -> uri) _ version text = msg ^. J.params . J.textDocument- vfile = VirtualFile version 0 (Rope.fromText text)+ let J.TextDocumentItem (J.toNormalizedUri -> uri) languageId version text = msg ^. J.params . J.textDocument+ vfile = VirtualFile version 0 (Rope.fromText text) (Just languageId) logger <& Opening uri `WithSeverity` Debug- vfsMap . at uri .= Just vfile+ vfsMap . at uri .= (Just $ Open vfile) -- --------------------------------------------------------------------- @@ -158,9 +205,10 @@ J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid vfs <- get case vfs ^. vfsMap . at uri of- Just (VirtualFile _ file_ver contents) -> do+ Just (Open (VirtualFile _ file_ver contents kind)) -> do contents' <- applyChanges logger contents changes- vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents')+ vfsMap . at uri .= Just (Open (VirtualFile version (file_ver + 1) contents' kind))+ Just (Closed (ClosedVirtualFile _)) -> logger <& ApplyChangeToClosedFile uri `WithSeverity` Warning Nothing -> logger <& URINotFound uri `WithSeverity` Warning -- ---------------------------------------------------------------------@@ -171,7 +219,7 @@ %= Map.insertWith (\new old -> if shouldOverwrite then new else old) uri- (VirtualFile 0 0 mempty)+ (Open (VirtualFile 0 0 mempty Nothing)) where shouldOverwrite :: Bool shouldOverwrite = case options of@@ -281,7 +329,7 @@ -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath-virtualFileName prefix uri (VirtualFile _ file_ver _) =+virtualFileName prefix uri (VirtualFile _ file_ver _ _) = let uri_raw = J.fromNormalizedUri uri basename = maybe "" takeFileName (J.uriToFilePath uri_raw) -- Given a length and a version number, pad the version number to@@ -298,7 +346,8 @@ persistFileVFS logger dir vfs uri = case vfs ^. vfsMap . at uri of Nothing -> Nothing- Just vf ->+ (Just (Closed _)) -> Nothing+ (Just (Open vf)) -> let tfn = virtualFileName dir uri vf action = do exists <- liftIO $ doesFileExist tfn@@ -319,7 +368,12 @@ closeVFS logger msg = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (J.toNormalizedUri -> uri)) = msg ^. J.params logger <& Closing uri `WithSeverity` Debug- vfsMap . at uri .= Nothing+ vfsMap . ix uri+ %= ( \mf ->+ case mf of+ Open f -> Closed $ toClosedVirtualFile f+ Closed f -> Closed f+ ) -- --------------------------------------------------------------------- @@ -463,7 +517,7 @@ CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text-rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r+rangeLinesFromVfs (VirtualFile _ _ ropetext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r where (_, s1) = Rope.splitAtLine (fromIntegral lf) ropetext (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1
test/VspSpec.hs view
@@ -29,7 +29,7 @@ -- --------------------------------------------------------------------- vfsFromText :: T.Text -> VirtualFile-vfsFromText text = VirtualFile 0 0 (Rope.fromText text)+vfsFromText text = VirtualFile 0 0 (Rope.fromText text) $ Just J.LanguageKind_Haskell -- --------------------------------------------------------------------- @@ -243,7 +243,7 @@ [ "a𐐀b" , "a𐐀b" ]- vfile = VirtualFile 0 0 (fromString orig)+ vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0) positionToCodePointPosition vfile (J.Position 1 1) `shouldBe` Just (CodePointPosition 1 1)@@ -265,7 +265,7 @@ [ "a𐐀b" , "a𐐀b" ]- vfile = VirtualFile 0 0 (fromString orig)+ vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0) codePointPositionToPosition vfile (CodePointPosition 1 1) `shouldBe` Just (J.Position 1 1)