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 17f78b03185517dcec4034a641e6d7eade4ee80b..2274b25aeb28d1d74c582dad116230bcdd648256 100644 (file)
--- 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
   <haskell-lsp https://hackage.haskell.org/package/haskell-lsp>.
-  It's currently used for testing in <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>.
+  To see examples of it in action, check out <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>,
+  <https://github.com/haskell/haskell-language-server haskell-language-server> and
+  <https://github.com/digital-asset/ghcide ghcide>.
 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 36841e8be6173406c4347a434d4bf7560e799c8c..761151e8ac9f282d9b8652f4b70a0ee29fbf4cbe 100644 (file)
--- 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 ddd07a5da6693cc3ccc27bd0845df8cd7b58734d..56e206d8bc8d1681cc4b5b3440fdae1a9b1db1c3 100644 (file)
--- 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 36594aa5df2968e50e826634471fd70a18cdb83a..fe599e7448a07031c9ce37e252faffa86e01bb2c 100644 (file)
--- 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 a7e6439078ead5af4db0275c3863bc610294d5e1..8120b030431c1bb0ce6b977f7a750755bb9dabda 100644 (file)
--- 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