From: Luke Lau Date: Thu, 14 May 2020 19:16:44 +0000 (+0100) Subject: Handle [un]registerCapability and workspace/didChangeWatchedFiles X-Git-Tag: 0.11.0.0~5 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=71f5ececdaa02c87b026c40d70fb55c4a0d05044 Handle [un]registerCapability and workspace/didChangeWatchedFiles Part of the work towards #63. The session will now keep track of the capabilities that are registered and unregister them when requests come in from the server. openDoc' has been removed and replaced with createDoc. createDoc will send out workspace/didChangeWatchedFiles notifications whenever the server registers for it. --- diff --git a/lsp-test.cabal b/lsp-test.cabal index 17f78b0..2274b25 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.10.3.0 +version: 0.11.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -7,7 +7,9 @@ description: @Language.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from . - It's currently used for testing in . + To see examples of it in action, check out , + and + . homepage: https://github.com/bubba/lsp-test#readme license: BSD3 license-file: LICENSE @@ -53,6 +55,7 @@ library , Diff , directory , filepath + , Glob ^>= 0.10 , lens , mtl , parser-combinators >= 1.2 @@ -83,6 +86,8 @@ executable dummy-server , data-default , aeson , unordered-containers + , directory + , filepath default-language: Haskell2010 scope: private if !flag(DummyServer) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 36841e8..761151e 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -41,8 +41,8 @@ module Language.Haskell.LSP.Test -- ** Initialization , initializeResponse -- ** Documents + , createDoc , openDoc - , openDoc' , closeDoc , changeDoc , documentContents @@ -82,6 +82,8 @@ module Language.Haskell.LSP.Test , applyEdit -- ** Code lenses , getCodeLenses + -- ** Capabilities + , getRegisteredCapabilities ) where import Control.Applicative.Combinators @@ -90,12 +92,13 @@ import Control.Monad import Control.Monad.IO.Class import Control.Exception import Control.Lens hiding ((.=), List) +import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map +import Data.List import Data.Maybe import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding @@ -114,6 +117,7 @@ import System.Environment import System.IO import System.Directory import System.FilePath +import qualified System.FilePath.Glob as Glob -- | Starts a new session. -- @@ -345,7 +349,61 @@ sendResponse = sendMessage initializeResponse :: Session InitializeResponse initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) --- | Opens a text document and sends a notification to the client. +-- | /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 +-- has registered for it__, and the file matches any patterns the server +-- registered for. +-- It /does not/ actually create a file on disk, but is useful for convincing +-- the server that one does exist. +-- +-- @since 11.0.0.0 +createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__. + -> String -- ^ The text document's language identifier, e.g. @"haskell"@. + -> T.Text -- ^ The content of the text document to create. + -> Session TextDocumentIdentifier -- ^ The identifier of the document just created. +createDoc file languageId contents = do + dynCaps <- curDynCaps <$> get + rootDir <- asks rootDir + caps <- asks sessionCapabilities + absFile <- liftIO $ canonicalizePath (rootDir file) + let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $ + Map.elems dynCaps + watchHits :: FileSystemWatcher -> Bool + watchHits (FileSystemWatcher pattern kind) = + -- If WatchKind is exlcuded, defaults to all true as per spec + fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind) + + fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs + -- If the pattern is absolute then match against the absolute fp + where relOrAbs + | isAbsolute pattern = absFile + | otherwise = file + + createHits (WatchKind create _ _) = create + + regHits :: Registration -> Bool + regHits reg = isJust $ do + opts <- reg ^. registerOptions + fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of + Success x -> Just x + Error _ -> Nothing + if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers) + then Just () + else Nothing + + clientCapsSupports = + caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just + == Just True + shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs + + when shouldSend $ + sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri file) FcCreated ] + openDoc' file languageId contents + +-- | Opens a text document that /exists on disk/, and sends a +-- textDocument/didOpen notification to the server. openDoc :: FilePath -> String -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask @@ -354,6 +412,7 @@ openDoc file languageId = do openDoc' file languageId contents -- | This is a variant of `openDoc` that takes the file content as an argument. +-- Use this is the file exists /outside/ of the current workspace. openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask @@ -363,13 +422,13 @@ openDoc' file languageId contents = do sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) pure $ TextDocumentIdentifier uri --- | Closes a text document and sends a notification to the client. +-- | Closes a text document and sends a textDocument/didOpen notification to the server. closeDoc :: TextDocumentIdentifier -> Session () closeDoc docId = do let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) sendNotification TextDocumentDidClose params --- | Changes a text document and sends a notification to the client +-- | Changes a text document and sends a textDocument/didOpen notification to the server. changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () changeDoc docId changes = do verDoc <- getVersionedDoc docId @@ -611,3 +670,10 @@ getCodeLenses tId = do rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res + +-- | Returns a list of capabilities that the server has requested to /dynamically/ +-- register during the 'Session'. +-- +-- @since 0.11.0.0 +getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index ddd07a5..56e206d 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -63,6 +63,7 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding @@ -163,6 +164,9 @@ data SessionState = SessionState -- ^ The last received message from the server. -- Used for providing exception information , lastReceivedMessage :: Maybe FromServerMessage + , curDynCaps :: Map.Map T.Text Registration + -- ^ The capabilities that the server has dynamically registered with us so + -- far } class Monad m => HasState s m where @@ -253,7 +257,7 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs mempty False Nothing + initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () @@ -277,12 +281,25 @@ updateStateC = awaitForever $ \msg -> do updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () + +-- Keep track of dynamic capability registration +updateState (ReqRegisterCapability req) = do + let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations + modify $ \s -> + s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } + +updateState (ReqUnregisterCapability req) = do + let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations + modify $ \s -> + let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs + in s { curDynCaps = newCurDynCaps } + updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri - modify (\s -> + modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) - in s { curDiagnostics = newDiags }) + in s { curDiagnostics = newDiags } updateState (ReqApplyWorkspaceEdit r) = do @@ -355,7 +372,7 @@ sendMessage msg = do logMsg LogClient msg liftIO $ B.hPut h (addHeader $ encode msg) --- | Execute a block f that will throw a 'Timeout' exception +-- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception -- after duration seconds. This will override the global timeout -- for waiting for messages to arrive defined in 'SessionConfig'. withTimeout :: Int -> Session a -> Session a @@ -393,5 +410,3 @@ logMsg t msg = do | otherwise = Cyan showPretty = B.unpack . encodePretty - - diff --git a/test/Test.hs b/test/Test.hs index 36594aa..fe599e7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -17,10 +17,10 @@ import Control.Monad import Control.Lens hiding (List) import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Test.Replay import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens as LSP hiding +import Language.Haskell.LSP.Types.Lens hiding (capabilities, message, rename, applyEdit) +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Types.Capabilities as LSP import System.Directory import System.FilePath @@ -329,6 +329,56 @@ main = findServer >>= \serverExe -> hspec $ do openDoc "Format.hs" "haskell" void publishDiagnosticsNotification + describe "dynamic capabilities" $ do + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do + loggingNotification -- initialized log message + + createDoc "register" "haskell" "" + message :: Session RegisterCapabilityRequest + + doc <- createDoc "Foo.watch" "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + caps <- getRegisteredCapabilities + liftIO $ caps `shouldBe` + [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + ] + + -- now unregister it by sending a specific createDoc + createDoc "unregister" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc "Bar.watch" "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do + curDir <- liftIO $ getCurrentDirectory + + loggingNotification -- initialized log message + + createDoc "register.abs" "haskell" "" + message :: Session RegisterCapabilityRequest + + doc <- createDoc (curDir "Foo.watch") "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- now unregister it by sending a specific createDoc + createDoc "unregister.abs" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc (curDir "Bar.watch") "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + +mkRange :: Int -> Int -> Int -> Int -> Range mkRange sl sc el ec = Range (Position sl sc) (Position el ec) didChangeCaps :: ClientCapabilities diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs index a7e6439..8120b03 100644 --- a/test/dummy-server/Main.hs +++ b/test/dummy-server/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Data.Aeson import Data.Default +import Data.List (isSuffixOf) import qualified Data.HashMap.Strict as HM import Language.Haskell.LSP.Core import Language.Haskell.LSP.Control @@ -8,6 +9,8 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Control.Concurrent import Control.Monad +import System.Directory +import System.FilePath main = do lfvar <- newEmptyMVar @@ -39,11 +42,10 @@ handlers lfvar = def (mkRange 0 0 3 6) Nothing ] - , didOpenTextDocumentNotificationHandler = pure $ \noti -> - void $ forkIO $ do - threadDelay (2 * 10^6) + , didOpenTextDocumentNotificationHandler = pure $ \noti -> do let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc + Just fp = uriToFilePath uri diag = Diagnostic (mkRange 0 0 0 1) (Just DsWarning) (Just (NumberValue 42)) @@ -51,8 +53,39 @@ handlers lfvar = def "Here's a warning" Nothing Nothing + when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do + threadDelay (2 * 10^6) send $ NotPublishDiagnostics $ fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag] + + -- also act as a registerer for workspace/didChangeWatchedFiles + when ("/register" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ + RegistrationParams $ List $ + [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + ] + when ("/register.abs" `isSuffixOf` fp) $ do + curDir <- getCurrentDirectory + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ + RegistrationParams $ List $ + [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher (curDir "*.watch") (Just (WatchKind True True True)) ] + ] + + -- also act as an unregisterer for workspace/didChangeWatchedFiles + when ("/unregister" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ + UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ] + when ("/unregister.abs" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ + UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ] , executeCommandHandler = pure $ \req -> do send $ RspExecuteCommand $ makeResponseMessage req Null reqId <- readMVar lfvar >>= getNextReqId @@ -74,6 +107,8 @@ handlers lfvar = def Nothing (Just (Command "" "deleteThis" Nothing)) send $ RspCodeAction $ makeResponseMessage req caresults + , didChangeWatchedFilesNotificationHandler = pure $ \_ -> + send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles" } where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg