Always try to register for didChangeConfiguration (#548)

michaelpj · web-flow · commit 13cba17ede98 · 2024-02-04T22:30:45.000Z
* 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.

* Add bound on extra

* fix
diff --git 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
@@ -56,6 +56,7 @@ library
     , Diff                >=0.4   && <0.6
     , directory           ^>=1.3
     , exceptions          ^>=0.10
+    , extra               ^>=1.7
     , filepath            >=1.4 && < 1.6
     , Glob                >=0.9   && <0.11
     , lens                >=5.1   && <5.3
@@ -101,6 +102,7 @@ test-suite tests
     , containers
     , data-default
     , directory
+    , extra
     , filepath
     , hspec
     , lens
diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs
@@ -25,6 +25,7 @@ module Language.LSP.Test (
   runSessionWithHandles',
   setIgnoringLogNotifications,
   setIgnoringConfigurationRequests,
+  setIgnoringRegistrationRequests,
 
   -- ** Config
   SessionConfig (..),
@@ -144,8 +145,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
@@ -476,6 +479,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.
 -}
@@ -485,12 +492,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
@@ -123,14 +123,17 @@ 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 @client/registerCapability@ and @client/unregisterCapability@ 
+  -- requests from the server, defaults to True.
   , initialWorkspaceFolders :: Maybe [WorkspaceFolder]
   -- ^ The initial workspace folders to send in the @initialize@ request.
   -- Defaults to Nothing.
   }
 
 -- | 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
@@ -190,6 +193,7 @@ data SessionState = SessionState
   , curProgressSessions :: !(Set.Set ProgressToken)
   , ignoringLogNotifications :: Bool
   , ignoringConfigurationRequests :: Bool
+  , ignoringRegistrationRequests :: Bool
   }
 
 class Monad m => HasState s m where
@@ -274,8 +278,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 ()
@@ -328,7 +351,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
@@ -341,6 +367,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
@@ -123,7 +123,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"
@@ -138,7 +138,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
@@ -12,11 +12,11 @@ import Data.Aeson
 import Data.Aeson qualified as J
 import Data.Default
 import Data.Either
+import Data.List.Extra
 import Data.Map.Strict qualified as M
 import Data.Maybe
 import Data.Proxy
 import Data.Text qualified as T
-import Data.Type.Equality
 import DummyServer
 import Language.LSP.Protocol.Lens qualified as L
 import Language.LSP.Protocol.Message
@@ -368,25 +368,31 @@ 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
-      liftIO $ do
-        case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of
-          Just (Right HRefl) ->
-            regOpts
-              `shouldBe` ( Just $
-                            DidChangeWatchedFilesRegistrationOptions
-                              [FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create)]
-                         )
-          _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
+      -- Look for the registration, we might have one for didChangeConfiguration in there too
+      registeredCaps <- getRegisteredCapabilities
+      let
+        regOpts :: Maybe DidChangeWatchedFilesRegistrationOptions
+        regOpts = flip firstJust registeredCaps $ \(SomeRegistration (TRegistration _ regMethod regOpts)) ->
+          case regMethod of
+            SMethod_WorkspaceDidChangeWatchedFiles -> regOpts
+            _ -> Nothing
+      liftIO $
+        regOpts
+          `shouldBe` ( Just $
+                        DidChangeWatchedFilesRegistrationOptions
+                          [FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create)]
+                     )
 
       -- now unregister it by sending a specific createDoc
       createDoc ".unregister" "haskell" ""
@@ -396,10 +402,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
@@ -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
@@ -218,11 +218,16 @@ 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
@@ -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
@@ -82,7 +82,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
@@ -96,6 +98,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)
@@ -550,30 +553,27 @@ 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))
@@ -583,11 +583,33 @@ registerCapability method regOpts f = do
              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
