From c6a9b9b2356de2e8dca02b773edb211eb4b2d6e6 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sun, 28 Jan 2024 20:05:36 +0000 Subject: [PATCH] Register for workspace/didChangeConfiguration always The new direction of the spec seems to be that you should always do this. In any case, it doesn't hurt. `lsp-test` has some changes to adapt to the increased registration message spam, and also changes to be a more picky client, refusing to send notifications unless you _do_ register. This is good, since it forces us to handle the most annoying version of client behaviour. --- lsp-test/ChangeLog.md | 9 ++++ lsp-test/lsp-test.cabal | 1 + lsp-test/src/Language/LSP/Test.hs | 33 +++++++++--- lsp-test/src/Language/LSP/Test/Session.hs | 38 ++++++++++++-- lsp-test/test/DummyServer.hs | 4 +- lsp-test/test/Test.hs | 10 ++-- lsp/ChangeLog.md | 2 + lsp/example/Reactor.hs | 13 +++-- lsp/example/Simple.hs | 2 +- lsp/src/Language/LSP/Server/Core.hs | 61 ++++++++++++++++------- lsp/src/Language/LSP/Server/Processing.hs | 15 +++++- 11 files changed, 147 insertions(+), 41 deletions(-) diff --git a/lsp-test/ChangeLog.md b/lsp-test/ChangeLog.md index 9afd591c..cb80fe23 100644 --- a/lsp-test/ChangeLog.md +++ b/lsp-test/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for lsp-test +## Unreleased + +- `ignoreRegistrationRequests` option to ignore `client/registerCapability` requests, on + by default. +- New functions `setIgnoringRegistrationRequests` to change whether such messages are + ignored during a `Session` without having to change the `SessionConfig`. +- `lsp-test` will no longer send `workspace/didChangConfiguration` notifications unless + the server dynamically registers for them. + ## 0.16.0.1 - Support newer versions of dependencies. diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal index e6e5f3ab..e4fd193c 100644 --- a/lsp-test/lsp-test.cabal +++ b/lsp-test/lsp-test.cabal @@ -57,6 +57,7 @@ library , Diff >=0.4 && <0.6 , directory ^>=1.3 , exceptions ^>=0.10 + , extra , filepath >=1.4 && < 1.6 , Glob >=0.9 && <0.11 , lens >=5.1 && <5.3 diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs index eb06aca3..e7be5fb7 100644 --- a/lsp-test/src/Language/LSP/Test.hs +++ b/lsp-test/src/Language/LSP/Test.hs @@ -30,6 +30,7 @@ module Language.LSP.Test ( runSessionWithHandles', setIgnoringLogNotifications, setIgnoringConfigurationRequests, + setIgnoringRegistrationRequests, -- ** Config SessionConfig (..), @@ -149,8 +150,10 @@ import Control.Monad.IO.Class import Control.Monad.State (execState) import Data.Aeson hiding (Null) import Data.Aeson qualified as J +import Data.Aeson.KeyMap qualified as J import Data.Default import Data.List +import Data.List.Extra (firstJust) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set qualified as Set @@ -481,6 +484,10 @@ setIgnoringConfigurationRequests :: Bool -> Session () setIgnoringConfigurationRequests value = do modify (\ss -> ss{ignoringConfigurationRequests = value}) +setIgnoringRegistrationRequests :: Bool -> Session () +setIgnoringRegistrationRequests value = do + modify (\ss -> ss{ignoringRegistrationRequests = value}) + {- | Modify the client config. This will send a notification to the server that the config has changed. -} @@ -490,12 +497,26 @@ modifyConfig f = do let newConfig = f oldConfig modify (\ss -> ss{curLspConfig = newConfig}) - caps <- asks sessionCapabilities - let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just - -- TODO: make this configurable? - -- if they support workspace/configuration then be annoying and don't send the full config so - -- they have to request it - configToSend = if supportsConfiguration then J.Null else Object newConfig + -- We're going to be difficult and follow the new direction of the spec as much + -- as possible. That means _not_ sending didChangeConfiguration notifications + -- unless the server has registered for them + registeredCaps <- getRegisteredCapabilities + let + requestedSections :: Maybe [T.Text] + requestedSections = flip firstJust registeredCaps $ \(SomeRegistration (TRegistration _ regMethod regOpts)) -> + case regMethod of + SMethod_WorkspaceDidChangeConfiguration -> case regOpts of + Just (DidChangeConfigurationRegistrationOptions {_section = section}) -> case section of + Just (InL s) -> Just [s] + Just (InR ss) -> Just ss + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + requestedSectionKeys :: Maybe [J.Key] + requestedSectionKeys = (fmap . fmap) (fromString . T.unpack) requestedSections + let configToSend = case requestedSectionKeys of + Just ss -> Object $ J.filterWithKey (\k _ -> k `elem` ss) newConfig + Nothing -> Object newConfig sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend {- | Set the client config. This will send a notification to the server that the diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index 11a1d718..79d5170c 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -130,6 +130,9 @@ data SessionConfig = SessionConfig , ignoreConfigurationRequests :: Bool -- ^ Whether or not to ignore @workspace/configuration@ requests from the server, -- defaults to True. + , ignoreRegistrationRequests :: Bool + -- ^ Whether or not to ignore @workspace/registerCapability@ requests from the server, + -- defaults to True. , initialWorkspaceFolders :: Maybe [WorkspaceFolder] -- ^ The initial workspace folders to send in the @initialize@ request. -- Defaults to Nothing. @@ -137,7 +140,7 @@ data SessionConfig = SessionConfig -- | The configuration used in 'Language.LSP.Test.runSession'. defaultConfig :: SessionConfig -defaultConfig = SessionConfig 60 False False True mempty True True Nothing +defaultConfig = SessionConfig 60 False False True mempty True True True Nothing instance Default SessionConfig where def = defaultConfig @@ -197,6 +200,7 @@ data SessionState = SessionState , curProgressSessions :: !(Set.Set ProgressToken) , ignoringLogNotifications :: Bool , ignoringConfigurationRequests :: Bool + , ignoringRegistrationRequests :: Bool } class Monad m => HasState s m where @@ -281,8 +285,27 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi mainThreadId <- myThreadId - let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState = SessionState 0 emptyVFS mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config) + let context = SessionContext + serverIn + absRootDir + messageChan + timeoutIdVar + reqMap + initRsp + config + caps + initState = SessionState + 0 + emptyVFS + mempty + False + Nothing + mempty + (lspConfig config) + mempty + (ignoreLogNotifications config) + (ignoreConfigurationRequests config) + (ignoreRegistrationRequests config) runSession' = runSessionMonad context initState errorHandler = throwTo mainThreadId :: SessionException -> IO () @@ -335,7 +358,10 @@ updateStateC = awaitForever $ \msg -> do then (Right configs) else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing _ -> pure () - unless ((ignoringLogNotifications state && isLogNotification msg) || (ignoringConfigurationRequests state && isConfigRequest msg)) $ + unless ( + (ignoringLogNotifications state && isLogNotification msg) + || (ignoringConfigurationRequests state && isConfigRequest msg) + || (ignoringRegistrationRequests state && isRegistrationRequest msg)) $ yield msg where @@ -348,6 +374,10 @@ updateStateC = awaitForever $ \msg -> do isConfigRequest (FromServerMess SMethod_WorkspaceConfiguration _) = True isConfigRequest _ = False + isRegistrationRequest (FromServerMess SMethod_ClientRegisterCapability _) = True + isRegistrationRequest (FromServerMess SMethod_ClientUnregisterCapability _) = True + isRegistrationRequest _ = False + -- extract Uri out from DocumentChange -- didn't put this in `lsp-types` because TH was getting in the way documentChangeUri :: DocumentChange -> Uri diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index f44f4448..dbab87f4 100644 --- a/lsp-test/test/DummyServer.hs +++ b/lsp-test/test/DummyServer.hs @@ -124,7 +124,7 @@ handlers = (Just WatchKind_Create) ] Just token <- runInIO $ - registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ + registerCapability mempty SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" @@ -139,7 +139,7 @@ handlers = (Just WatchKind_Create) ] Just token <- runInIO $ - registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ + registerCapability mempty SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" diff --git a/lsp-test/test/Test.hs b/lsp-test/test/Test.hs index 295246a5..945cb8b0 100644 --- a/lsp-test/test/Test.hs +++ b/lsp-test/test/Test.hs @@ -370,16 +370,19 @@ main = hspec $ around withDummyServer $ do void publishDiagnosticsNotification describe "dynamic capabilities" $ do - it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do + let config = def{ignoreLogNotifications=False} + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout config fullCaps "." $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" + setIgnoringRegistrationRequests False message SMethod_ClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" "" msg <- message SMethod_WindowLogMessage liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" - [SomeRegistration (TRegistration _ regMethod regOpts)] <- getRegisteredCapabilities + -- the first one is the registration for workspace/didChangeConfiguration + [_, SomeRegistration (TRegistration _ regMethod regOpts)] <- getRegisteredCapabilities liftIO $ do case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of Just (Right HRefl) -> @@ -398,10 +401,11 @@ main = hspec $ around withDummyServer $ do void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "" $ do + it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout config fullCaps "" $ do loggingNotification -- initialized log message curDir <- liftIO $ getCurrentDirectory + setIgnoringRegistrationRequests False createDoc ".register.abs" "haskell" "" message SMethod_ClientRegisterCapability diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 500002b2..c75a6115 100644 --- a/lsp/ChangeLog.md +++ b/lsp/ChangeLog.md @@ -8,6 +8,8 @@ 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` + notifications, to ensure that newer clients continue to send them. ## 2.3.0.0 diff --git a/lsp/example/Reactor.hs b/lsp/example/Reactor.hs index db99fa32..ed863d6b 100644 --- a/lsp/example/Reactor.hs +++ b/lsp/example/Reactor.hs @@ -222,11 +222,14 @@ handle logger = let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do - logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info - let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing - rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right $ LSP.InL rsp) + void $ registerCapability + mempty + LSP.SMethod_TextDocumentCodeLens regOpts + $ \_req responder -> do + logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info + let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing + rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right $ LSP.InL rsp) , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri fileName = LSP.uriToFilePath doc diff --git a/lsp/example/Simple.hs b/lsp/example/Simple.hs index 1b486378..eb845cfe 100644 --- a/lsp/example/Simple.hs +++ b/lsp/example/Simple.hs @@ -21,7 +21,7 @@ handlers = Right (InL (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) - _ <- registerCapability SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do + _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] responder $ Right $ InL rsp diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 2a67539c..fc600f5f 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -17,6 +17,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} +{-# LANGUAGE StandaloneDeriving #-} module Language.LSP.Server.Core where @@ -89,7 +90,9 @@ data LspCoreLog | ConfigurationNotSupported | BadConfigurationResponse ResponseError | WrongConfigSections [J.Value] - deriving (Show) + | forall m. CantRegister (SMethod m) + +deriving instance (Show LspCoreLog) instance Pretty LspCoreLog where pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config @@ -103,6 +106,7 @@ instance Pretty LspCoreLog where ] pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections) + pretty (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a} deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) @@ -557,44 +561,63 @@ getWorkspaceFolders = do registerCapability :: forall f t (m :: Method ClientToServer t) config. MonadLsp config f => + LogAction f (WithSeverity LspCoreLog) -> SClientMethod m -> RegistrationOptions m -> Handler f m -> f (Maybe (RegistrationToken m)) -registerCapability method regOpts f = do - clientCaps <- resClientCapabilities <$> getLspEnv +registerCapability logger method regOpts f = do handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of IsClientNot -> SMethodMap.member method $ notHandlers handlers IsClientReq -> SMethodMap.member method $ reqHandlers handlers IsClientEither -> error "Cannot register capability for custom methods" - go clientCaps alreadyStaticallyRegistered + go alreadyStaticallyRegistered where -- If the server has already registered statically, don't dynamically register -- as per the spec - go _clientCaps True = pure Nothing - go clientCaps False - -- First, check to see if the client supports dynamic registration on this method - | dynamicRegistrationSupported method clientCaps = do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = L.TRegistration uuid method (Just regOpts) - params = L.RegistrationParams [toUntypedRegistration registration] - regId = RegistrationId uuid - rio <- askUnliftIO + go True = pure Nothing + go False = do + rio <- askUnliftIO + mtoken <- trySendRegistration logger method regOpts + case mtoken of + Just token@(RegistrationToken _ regId) -> do ~() <- case splitClientMethod method of IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) - in SMethodMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) - in SMethodMap.insert method pair oldRegs + in SMethodMap.insert method pair oldRegs IsClientEither -> error "Cannot register capability for custom methods" - -- TODO: handle the scenario where this returns an error - _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () + pure $ Just token + Nothing -> pure Nothing - pure (Just (RegistrationToken method regId)) - | otherwise = pure Nothing +trySendRegistration :: + forall f t (m :: Method ClientToServer t) config. + MonadLsp config f => + LogAction f (WithSeverity LspCoreLog) -> + SClientMethod m -> + RegistrationOptions m -> + f (Maybe (RegistrationToken m)) +trySendRegistration logger method regOpts = do + clientCaps <- resClientCapabilities <$> getLspEnv + -- First, check to see if the client supports dynamic registration on this method + if dynamicRegistrationSupported method clientCaps + then do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = L.TRegistration uuid method (Just regOpts) + params = L.RegistrationParams [toUntypedRegistration registration] + regId = RegistrationId uuid + + -- TODO: handle the scenario where this returns an error + _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () + + pure (Just $ RegistrationToken method regId) + else do + logger <& (CantRegister SMethod_WorkspaceDidChangeConfiguration) `WithSeverity` Warning + pure Nothing {- | Sends a @client/unregisterCapability@ request and removes the handler for that associated registration. diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index 5376048b..59aeb84b 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -70,6 +70,7 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.Server.Core import Language.LSP.VFS as VFS import System.Exit +import GHC.IO.Device (SeekMode(SeekFromEnd)) data LspProcessingLog = VfsLog VfsLog @@ -428,7 +429,7 @@ handle logger m msg = SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration] - SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg + SMethod_Initialized -> handle' logger (Just $ \_ -> initialDynamicRegistrations logger >> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg SMethod_TextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg SMethod_TextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg SMethod_TextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg @@ -531,6 +532,18 @@ shutdownRequestHandler :: Handler IO Method_Shutdown shutdownRequestHandler _req k = do k $ Right Null +initialDynamicRegistrations :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> m () +initialDynamicRegistrations logger = do + section <- LspT $ asks resConfigSection + -- We need to register for `workspace/didChangeConfiguration` dynamically in order to + -- ensure we receive notifications. See + -- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_configuration + -- https://github.com/microsoft/language-server-protocol/issues/1888 + void $ trySendRegistration + (cmap (fmap LspCore) logger) + SMethod_WorkspaceDidChangeConfiguration + (DidChangeConfigurationRegistrationOptions (Just $ InL section)) + {- | Try to find the configuration section in an object that might represent "all" the settings. The heuristic we use is to look for a property with the right name, and use that if we find it. Otherwise we fall back to the whole object.