Fully support use of workspace/configuration

`lsp` will now rely primarily on `workspace/configuration` to get
configuration from the client. See `Note [LSP configuration]` for
details.

`lsp-test` also now handles `workspace/configuration` properly.

lsp-test/ChangeLog.md

@@ -1,5 +1,16 @@
 # Revision history for lsp-test
 
+## Unreleased
+
+- Many changes relating to LSP client configuration
+    - `lsp-test` now responds to `workspace/configuration` requests.
+    - New function `setConfig` for setting the client configuration and notifying the server.
+    - `lsp-test` does not send a `workspace/didChangeConfiguration` request on startup.
+    - New `SessionConfig` option to ignore `workspace/configuration` requests, as they
+      are often not useful in sessions. This is on by default.
+- `ignoreLogNotifications` is now on by default. Experience shows the norm is to ignore these
+  and it is simpler to turn this on only when they are required.
+
 ## 0.15.0.1
 
 * Adds helper functions to resolve code lens, code actions, and completion items.

lsp-test/bench/SimpleBench.hs

@@ -32,8 +32,10 @@ handlers = mconcat
 
 server :: ServerDefinition ()
 server = ServerDefinition
-  { onConfigurationChange = const $ const $ Right ()
+  { parseConfig = const $ const $ Right ()
+  , onConfigChange = const  $ pure ()
   , defaultConfig = ()
+  , configSection = "demo"
   , doInitialize = \env _req -> pure $ Right env
   , staticHandlers = \_caps -> handlers
   , interpretHandler = \env -> Iso (runLspT env) liftIO

lsp-test/func-test/FuncTest.hs

@@ -32,8 +32,10 @@ main = hspec $ do
       killVar <- newEmptyMVar
 
       let definition = ServerDefinition
-            { onConfigurationChange = const $ const $ Right ()
+            { parseConfig = const $ const $ Right ()
+            , onConfigChange = const $ pure ()
             , defaultConfig = ()
+            , configSection = "demo"
             , doInitialize = \env _req -> pure $ Right env
             , staticHandlers = \_caps -> handlers killVar
             , interpretHandler = \env -> Iso (runLspT env) liftIO
@@ -79,8 +81,10 @@ main = hspec $ do
           wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"
 
           definition = ServerDefinition
-            { onConfigurationChange = const $ const $ Right ()
+            { parseConfig = const $ const $ Right ()
+            , onConfigChange = const $ pure ()
             , defaultConfig = ()
+            , configSection = "demo"
             , doInitialize = \env _req -> pure $ Right env
             , staticHandlers = \_caps -> handlers
             , interpretHandler = \env -> Iso (runLspT env) liftIO

lsp-test/lsp-test.cabal

@@ -59,6 +59,7 @@ library
     , filepath
     , Glob                  >=0.9   && <0.11
     , lens
+    , lens-aeson
     , lsp                   ^>=2.1
     , lsp-types             ^>=2.0
     , mtl                   <2.4

lsp-test/src/Language/LSP/Test.hs

@@ -49,6 +49,8 @@ module Language.LSP.Test
 
   -- ** Initialization
   , initializeResponse
+  -- ** Config
+  , setConfig
   -- ** Documents
   , createDoc
   , openDoc
@@ -121,6 +123,7 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson hiding (Null)
+import qualified Data.Aeson as J
 import Data.Default
 import Data.List
 import Data.Maybe
@@ -224,7 +227,8 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
                                           Nothing
                                           (InL $ filePathToUri absRootDir)
                                           caps
-                                          (lspConfig config')
+                                          -- TODO: make this configurable?
+                                          (Just $ lspConfig config')
                                           (Just TraceValues_Off)
                                           (fmap InL $ initialWorkspaceFolders config)
   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
@@ -243,10 +247,6 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
     liftIO $ putMVar initRspVar initRspMsg
     sendNotification SMethod_Initialized InitializedParams
 
-    case lspConfig config of
-      Just cfg -> sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
-      Nothing -> return ()
-
     -- ... relay them back to the user Session so they can match on them!
     -- As long as they are allowed.
     forM_ inBetween checkLegalBetweenMessage
@@ -401,6 +401,20 @@ sendResponse = sendMessage
 initializeResponse :: Session (TResponseMessage Method_Initialize)
 initializeResponse = ask >>= (liftIO . readMVar) . initRsp
 
+-- | Set the client config. This will send a notification to the server that the
+-- config has changed.
+setConfig :: Value
+          -> Session ()
+setConfig newConfig = do
+  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 newConfig
+  sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend
+
 -- | /Creates/ a new text document. This is different from 'openDoc'
 -- as it sends a workspace/didChangeWatchedFiles notification letting the server
 -- know that a file was created within the workspace, __provided that the server

lsp-test/src/Language/LSP/Test/Parsing.hs

@@ -20,6 +20,8 @@ module Language.LSP.Test.Parsing
   , anyNotification
   , anyMessage
   , loggingNotification
+  , configurationRequest
+  , loggingOrConfiguration
   , publishDiagnosticsNotification
   ) where
 
@@ -207,6 +209,16 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip
     shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True
     shouldSkip _ = False
 
+-- | Matches if the message is a configuration request from the server.
+configurationRequest :: Session FromServerMessage
+configurationRequest = named "Configuration request" $ satisfy shouldSkip
+  where
+    shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True
+    shouldSkip _ = False
+
+loggingOrConfiguration :: Session FromServerMessage
+loggingOrConfiguration = loggingNotification <|> configurationRequest
+
 -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
 -- (textDocument/publishDiagnostics) notification.
 publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics)

lsp-test/src/Language/LSP/Test/Session.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Language.LSP.Test.Session
   ( Session(..)
@@ -43,8 +44,6 @@ import Control.Lens hiding (List, Empty)
 import Control.Monad
 import Control.Monad.Catch (MonadThrow)
 import Control.Monad.Except
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
 #if __GLASGOW_HASKELL__ == 806
 import Control.Monad.Fail
 #endif
@@ -54,7 +53,9 @@ import Control.Monad.Trans.State (StateT, runStateT, execState)
 import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Aeson hiding (Error, Null)
+import qualified Data.Aeson as J
 import Data.Aeson.Encode.Pretty
+import Data.Aeson.Lens ()
 import Data.Conduit as Conduit
 import Data.Conduit.Parser as Parser
 import Data.Default
@@ -84,6 +85,8 @@ import System.Timeout ( timeout )
 import Data.IORef
 import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))
 import Data.Row
+import Data.String (fromString)
+import Data.Either (partitionEithers)
 
 -- | A session representing one instance of launching and connecting to a server.
 --
@@ -112,20 +115,26 @@ data SessionConfig = SessionConfig
   -- ^ Trace the messages sent and received to stdout, defaults to False.
   -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
   , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
-  , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
+  , lspConfig      :: Value
+  -- ^ The initial LSP config as JSON value, defaults to Null.
+  -- This should include the config section for the server if it has one, i.e. if
+  -- the server has a 'mylang' config section, then the config should be an object
+  -- with a 'mylang' key whose value is the actual config for the server. You
+  -- can also include other config sections if your server may request those.
   , ignoreLogNotifications :: Bool
-  -- ^ Whether or not to ignore 'Language.LSP.Types.ShowMessageNotification' and
-  -- 'Language.LSP.Types.LogMessageNotification', defaults to False.
-  --
-  -- @since 0.9.0.0
+  -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications 
+  -- from the server, defaults to True.
+  , ignoreConfigurationRequests :: Bool
+  -- ^ Whether or not to ignore @workspace/configuration@ 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 Nothing False Nothing
+defaultConfig = SessionConfig 60 False False True J.Null True True Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -179,6 +188,7 @@ data SessionState = SessionState
   -- Used for providing exception information
   , lastReceivedMessage :: !(Maybe FromServerMessage)
   , curDynCaps :: !(Map.Map T.Text SomeRegistration)
+  , curLspConfig :: Value
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
   , curProgressSessions :: !(Set.Set ProgressToken)
@@ -227,15 +237,9 @@ runSessionMonad context state (Session session) = runReaderT (runStateT conduit
 
     chanSource = do
       msg <- liftIO $ readChan (messageChan context)
-      unless (ignoreLogNotifications (config context) && isLogNotification msg) $
-        yield msg
+      yield msg
       chanSource
 
-    isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowMessage _)) = True
-    isLogNotification (ServerMessage (FromServerMess SMethod_WindowLogMessage _)) = True
-    isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowDocument _)) = True
-    isLogNotification _ = False
-
     watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
     watchdog = Conduit.awaitForever $ \msg -> do
       curId <- getCurTimeoutId
@@ -273,7 +277,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
   mainThreadId <- myThreadId
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
-      initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty
+      initState vfs = SessionState 0 vfs mempty False Nothing mempty (lspConfig config) mempty
       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
@@ -302,17 +306,44 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
 
 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 updateStateC = awaitForever $ \msg -> do
+  context <- ask @SessionContext
   updateState msg
-  respond msg
-  yield msg
-  where
-    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()
-    respond (FromServerMess SMethod_WindowWorkDoneProgressCreate req) =
+  case msg of
+    FromServerMess SMethod_WindowWorkDoneProgressCreate req ->
       sendMessage $ TResponseMessage "2.0" (Just $ req ^. L.id) (Right Null)
-    respond (FromServerMess SMethod_WorkspaceApplyEdit r) = do
+    FromServerMess SMethod_WorkspaceApplyEdit r -> do
       sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right $ ApplyWorkspaceEditResult True Nothing Nothing)
-    respond _ = pure ()
+    FromServerMess SMethod_WorkspaceConfiguration r -> do
+      let requestedSections = mapMaybe (\i -> i ^? L.section . _Just) $ r ^. L.params . L.items
+      c <- curLspConfig <$> get @SessionState
+      case c of
+        Object o -> do
+          let configsOrErrs = (flip fmap) requestedSections $ \section ->
+                case o ^. at (fromString $ T.unpack section) of
+                  Just config -> Right config
+                  Nothing -> Left section
+
+          let (errs, configs) = partitionEithers configsOrErrs
+
+          if null errs
+          then sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right configs)
+          else sendMessage @_ @(TResponseError Method_WorkspaceConfiguration) $
+            TResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing
+
+        _ -> sendMessage @_ @(TResponseError Method_WorkspaceConfiguration) $ TResponseError (InL LSPErrorCodes_RequestFailed) "No configuration" Nothing
+    _ -> pure ()
+  unless ((ignoreLogNotifications (config context) && isLogNotification msg) || (ignoreConfigurationRequests (config context) && isConfigRequest msg)) $
+    yield msg
+
+  where
+
+    isLogNotification (FromServerMess SMethod_WindowShowMessage _) = True
+    isLogNotification (FromServerMess SMethod_WindowLogMessage _) = True
+    isLogNotification (FromServerMess SMethod_WindowShowDocument _) = True
+    isLogNotification _ = False
 
+    isConfigRequest (FromServerMess SMethod_WorkspaceConfiguration _) = True
+    isConfigRequest _ = False
 
 -- extract Uri out from DocumentChange
 -- didn't put this in `lsp-types` because TH was getting in the way

lsp-test/test/DummyServer.hs

@@ -7,8 +7,10 @@ module DummyServer where
 import Control.Monad
 import Control.Monad.Reader
 import Data.Aeson hiding (defaultOptions, Null)
+import qualified Data.Aeson as J
 import qualified Data.Map.Strict as M
 import Data.List (isSuffixOf)
+import qualified Data.Text as T
 import Data.String
 import UnliftIO.Concurrent
 import Language.LSP.Server
@@ -27,10 +29,15 @@ withDummyServer f = do
   (houtRead, houtWrite) <- createPipe
 
   handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
-  let definition = ServerDefinition
+  let
+    definition = ServerDefinition
         { doInitialize = \env _req -> pure $ Right env
-        , defaultConfig = ()
-        , onConfigurationChange = const $ pure $ Right ()
+        , defaultConfig = 1 :: Int
+        , configSection = "dummy"
+        , parseConfig = \_old new -> case fromJSON new of
+            J.Success v -> Right v
+            J.Error err -> Left $ T.pack err
+        , onConfigChange = const $ pure ()
         , staticHandlers = \_caps -> handlers
         , interpretHandler = \env ->
             Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO
@@ -48,13 +55,18 @@ data HandlerEnv = HandlerEnv
   , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)
   }
 
-handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
+handlers :: Handlers (ReaderT HandlerEnv (LspM Int))
 handlers =
   mconcat
     [ notificationHandler SMethod_Initialized $
         \_noti ->
           sendNotification SMethod_WindowLogMessage $
             LogMessageParams MessageType_Log "initialized"
+
+    , requestHandler (SMethod_CustomMethod (Proxy @"getConfig")) $ \_req resp -> do
+        config <- getConfig
+        resp $ Right $ toJSON config
+
     , requestHandler SMethod_TextDocumentHover $
         \_req responder ->
           responder $