diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 } diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -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 diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -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 diff --git a/src/Language/LSP/Diagnostics.hs b/src/Language/LSP/Diagnostics.hs --- a/src/Language/LSP/Diagnostics.hs +++ b/src/Language/LSP/Diagnostics.hs @@ -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 -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs --- a/src/Language/LSP/Server.hs +++ b/src/Language/LSP/Server.hs @@ -50,6 +50,7 @@ -- * Diagnostics publishDiagnostics, flushDiagnosticsBySource, + flushDiagnosticsBySourceAndUri, -- * Progress withProgress, diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs --- a/src/Language/LSP/Server/Control.hs +++ b/src/Language/LSP/Server/Control.hs @@ -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" diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -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`. -} diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -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 diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs --- a/src/Language/LSP/VFS.hs +++ b/src/Language/LSP/VFS.hs @@ -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 diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -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)