Merge pull request #512 from haskell/mpj/configuration

Fully support use of workspace/configuration

Author: michaelpj

lsp-test/ChangeLog.md

@@ -1,5 +1,18 @@
 # Revision history for lsp-test
 
+## Unreleased
+
+- The client configuration is now _mandatory_ and is an `Object` rather than a `Value`.
+- `lsp-test` now responds to `workspace/configuration` requests.
+- `lsp-test` does _not_ send a `workspace/didChangeConfiguration` request on startup.
+- New functions for modifying the client configuration and notifying the server.
+- `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.
+- `ignoreConfigurationRequests` option to ignore `workspace/configuration` requests, also on
+  by default.
+- New functions `setIgnoringLogNotifications` and `setIgnoringConfigurationRequests` to change
+  whether such messages are ignored during a `Session` without having to change the `SessionConfig`.
+
 ## 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/func-test/func-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/lsp-test.cabal

@@ -29,6 +29,8 @@ module Language.LSP.Test
   , runSessionWithConfigCustomProcess
   , runSessionWithHandles
   , runSessionWithHandles'
+  , setIgnoringLogNotifications
+  , setIgnoringConfigurationRequests
   -- ** Config
   , SessionConfig(..)
   , defaultConfig
@@ -49,6 +51,11 @@ module Language.LSP.Test
 
   -- ** Initialization
   , initializeResponse
+  -- ** Config
+  , modifyConfig
+  , setConfig
+  , modifyConfigSection
+  , setConfigSection
   -- ** Documents
   , createDoc
   , openDoc
@@ -121,6 +128,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
@@ -143,6 +151,7 @@ import System.Process (ProcessHandle, CreateProcess)
 import qualified System.FilePath.Glob as Glob
 import Control.Monad.State (execState)
 import Data.Traversable (for)
+import Data.String (fromString)
 
 -- | Starts a new session.
 --
@@ -224,7 +233,8 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
                                           Nothing
                                           (InL $ filePathToUri absRootDir)
                                           caps
-                                          (lspConfig config')
+                                          -- TODO: make this configurable?
+                                          (Just $ Object $ lspConfig config')
                                           (Just TraceValues_Off)
                                           (fmap InL $ initialWorkspaceFolders config)
   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
@@ -243,10 +253,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 +407,45 @@ sendResponse = sendMessage
 initializeResponse :: Session (TResponseMessage Method_Initialize)
 initializeResponse = ask >>= (liftIO . readMVar) . initRsp
 
+setIgnoringLogNotifications :: Bool -> Session ()
+setIgnoringLogNotifications value = do
+  modify (\ss -> ss { ignoringLogNotifications = value })
+
+setIgnoringConfigurationRequests :: Bool -> Session ()
+setIgnoringConfigurationRequests value = do
+  modify (\ss -> ss { ignoringConfigurationRequests = value })
+
+-- | Modify the client config. This will send a notification to the server that the
+-- config has changed.
+modifyConfig :: (Object -> Object) -> Session ()
+modifyConfig f = do
+  oldConfig <- curLspConfig <$> get
+  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
+  sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend
+
+-- | Set the client config. This will send a notification to the server that the
+-- config has changed.
+setConfig :: Object -> Session ()
+setConfig newConfig = modifyConfig (const newConfig)
+
+-- | Modify a client config section (if already present, otherwise does nothing).
+-- This will send a notification to the server that the config has changed.
+modifyConfigSection :: String -> (Value -> Value) -> Session ()
+modifyConfigSection section f = modifyConfig (\o -> o & ix (fromString section) %~ f)
+
+-- | Set a client config section. This will send a notification to the server that the
+-- config has changed.
+setConfigSection :: String -> Value -> Session ()
+setConfigSection section settings = modifyConfig (\o -> o & at(fromString section) ?~ settings)
+
 -- | /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.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/Parsing.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Language.LSP.Test.Session
   ( Session(..)
@@ -41,10 +42,10 @@ import Control.Concurrent hiding (yield)
 import Control.Exception
 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
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.Except
 #if __GLASGOW_HASKELL__ == 806
 import Control.Monad.Fail
 #endif
@@ -55,6 +56,7 @@ import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Aeson hiding (Error, Null)
 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 +86,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 +116,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      :: Object
+  -- ^ The initial LSP config as JSON object, defaults to the empty object.
+  -- 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 mempty True True Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -181,7 +191,10 @@ data SessionState = SessionState
   , curDynCaps :: !(Map.Map T.Text SomeRegistration)
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
+  , curLspConfig :: Object
   , curProgressSessions :: !(Set.Set ProgressToken)
+  , ignoringLogNotifications :: Bool
+  , ignoringConfigurationRequests :: Bool
   }
 
 class Monad m => HasState s m where
@@ -227,15 +240,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 +280,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 (ignoreLogNotifications config) (ignoreConfigurationRequests config)
       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
@@ -302,17 +309,42 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
 
 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 updateStateC = awaitForever $ \msg -> do
+  state <- get @SessionState
   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
+      let o = curLspConfig state
+      -- check for each requested section whether we have it
+      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
+
+      -- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error
+      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
+    _ -> pure ()
+  unless ((ignoringLogNotifications state && isLogNotification msg) || (ignoringConfigurationRequests state && 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