diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Revision history for lsp-test +## 0.16.0.0 + +- 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. diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs --- a/bench/SimpleBench.hs +++ b/bench/SimpleBench.hs @@ -32,8 +32,10 @@ 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 diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -32,8 +32,10 @@ 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 @@ 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 diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.15.0.1 +version: 0.16.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -59,7 +59,8 @@ , filepath , Glob >=0.9 && <0.11 , lens - , lsp ^>=2.1 + , lens-aeson + , lsp ^>=2.2 , lsp-types ^>=2.0 , mtl <2.4 , parser-combinators >=1.2 @@ -102,7 +103,7 @@ , filepath , hspec , lens - , lsp ^>=2.1 + , lsp ^>=2.2 , lsp-test , mtl <2.4 , parser-combinators diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -29,6 +29,8 @@ , runSessionWithConfigCustomProcess , runSessionWithHandles , runSessionWithHandles' + , setIgnoringLogNotifications + , setIgnoringConfigurationRequests -- ** Config , SessionConfig(..) , defaultConfig @@ -49,6 +51,11 @@ -- ** Initialization , initializeResponse + -- ** Config + , modifyConfig + , setConfig + , modifyConfigSection + , setConfigSection -- ** Documents , createDoc , openDoc @@ -121,6 +128,7 @@ 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 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 @@ 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 @@ 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 @@ -400,6 +406,45 @@ -- so if you need to test it use this. 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 diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -20,6 +20,8 @@ , anyNotification , anyMessage , loggingNotification + , configurationRequest + , loggingOrConfiguration , publishDiagnosticsNotification ) where @@ -206,6 +208,16 @@ shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True 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. diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.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.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 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 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,12 +116,18 @@ -- ^ 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. @@ -125,7 +135,7 @@ -- | 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 @@ , 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 @@ 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 @@ 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 @@ 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 diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -7,8 +7,10 @@ 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 @@ (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 @@ , 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 $ diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -8,6 +8,7 @@ import DummyServer import Test.Hspec import Data.Aeson +import qualified Data.Aeson as J import Data.Default import qualified Data.Map.Strict as M import Data.Either @@ -103,14 +104,12 @@ describe "SessionException" $ do it "throw on time out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do - skipMany loggingNotification _ <- message SMethod_WorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException it "don't throw when no time out" $ \(hin, hout) -> runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do - loggingNotification liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" return () @@ -119,7 +118,7 @@ it "throws when there's an unexpected message" $ \(hin, hout) -> let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False - in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector + in runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) -> let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False @@ -131,6 +130,29 @@ in runSessionWithHandles hin hout def fullCaps "." sesh `shouldThrow` selector + describe "config" $ do + it "updates config correctly" $ \(hin, hout) -> + runSessionWithHandles hin hout (def { ignoreConfigurationRequests = False }) fullCaps "." $ do + configurationRequest -- initialized configuration request + let requestConfig = do + resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null + case resp ^? L.result . _Right of + Just val -> case fromJSON @Int val of + J.Success v -> pure v + J.Error err -> fail err + Nothing -> fail "no result" + + c <- requestConfig + -- from the server definition + liftIO $ c `shouldBe` 1 + setConfigSection "dummy" (toJSON @Int 2) + -- ensure the configuration change has happened + configurationRequest + c <- requestConfig + liftIO $ c `shouldBe` 2 + + pure () + describe "text document VFS" $ do it "sends back didChange notifications (documentChanges)" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do @@ -213,8 +235,6 @@ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - skipMany loggingNotification - Right (mainSymbol:_) <- getDocumentSymbols doc liftIO $ do @@ -324,21 +344,21 @@ in sesh `shouldThrow` anyException describe "satisfy" $ - it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" let pred (FromServerMess SMethod_WindowLogMessage _) = True pred _ = False void $ satisfy pred describe "satisfyMaybe" $ do - it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do -- Wait for window/logMessage "initialized" from the server. let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String pred _ = Nothing :: Maybe String result <- satisfyMaybe pred liftIO $ result `shouldBe` "match" - it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but @@ -354,9 +374,8 @@ describe "dynamic capabilities" $ do - it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do loggingNotification -- initialized log message - createDoc ".register" "haskell" "" message SMethod_ClientRegisterCapability @@ -378,13 +397,11 @@ createDoc "Bar.watch" "haskell" "" void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing - count 0 $ loggingNotification void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "" $ do - curDir <- liftIO $ getCurrentDirectory - + it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "" $ do loggingNotification -- initialized log message + curDir <- liftIO $ getCurrentDirectory createDoc ".register.abs" "haskell" "" message SMethod_ClientRegisterCapability @@ -399,7 +416,6 @@ createDoc (curDir "Bar.watch") "haskell" "" void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing - count 0 $ loggingNotification void $ anyResponse describe "call hierarchy" $ do