From e5da0e9511c679626dbe40a99e8c0de0c968dddf Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 25 May 2020 16:41:49 +0100 Subject: [PATCH] Watch files to send didChangeWatchedFiles notifications --- lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test/Session.hs | 80 ++++++++++++++++++++++-- test/Test.hs | 59 +++++++++++++---- test/dummy-server/Main.hs | 13 ++++ 4 files changed, 136 insertions(+), 17 deletions(-) diff --git a/lsp-test.cabal b/lsp-test.cabal index 34b80b9..79c8d56 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -55,6 +55,7 @@ library , Diff , directory , filepath + , fsnotify >= 0.3 && < 0.4 , Glob >= 0.9 && < 0.11 , lens , mtl diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9076a8e..a82651a 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -70,9 +70,12 @@ import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions import System.Console.ANSI import System.Directory +import System.FSNotify (watchTree, eventPath, withManager, WatchManager) +import qualified System.FSNotify as FS import System.IO import System.Process (ProcessHandle()) import System.Timeout +import System.FilePath.Glob (match, commonDirectory, compile) -- | A session representing one instance of launching and connecting to a server. -- @@ -131,6 +134,7 @@ data SessionContext = SessionContext , initRsp :: MVar InitializeResponse , config :: SessionConfig , sessionCapabilities :: ClientCapabilities + , watchManager :: WatchManager } class Monad m => HasReader r m where @@ -141,7 +145,7 @@ class Monad m => HasReader r m where instance HasReader SessionContext Session where ask = Session (lift $ lift Reader.ask) -instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where +instance Monad m => HasReader r (ConduitT a b (StateT s (ReaderT r m))) where ask = lift $ lift Reader.ask getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int @@ -167,6 +171,7 @@ data SessionState = SessionState , curDynCaps :: Map.Map T.Text Registration -- ^ The capabilities that the server has dynamically registered with us so -- far + , unwatchers :: Map.Map T.Text [IO ()] } class Monad m => HasState s m where @@ -188,7 +193,7 @@ instance Monad m => HasState s (StateT s m) where get = State.get put = State.put -instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m) +instance (Monad m, (HasState s m)) => HasState s (ConduitT a b m) where get = lift get put = lift . put @@ -220,7 +225,7 @@ runSession context state (Session session) = runReaderT (runStateT conduit state isLogNotification (ServerMessage (NotLogMessage _)) = True isLogNotification _ = False - watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog :: ConduitT SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () watchdog = Conduit.awaitForever $ \msg -> do curId <- getCurTimeoutId case msg of @@ -256,8 +261,12 @@ 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 mempty + withManager $ \watchManager -> do + let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps watchManager + initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty + -- Interesting note: turning on TypeFamilies causes type inference to + -- infer the type runSession' :: Session () -> IO ((), SessionState) + -- instead of runSession' :: Session a -> IO (a , SessionState) runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () @@ -276,7 +285,7 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro (const $ runSession' session) return result -updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC :: ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () updateStateC = awaitForever $ \msg -> do updateState msg yield msg @@ -290,12 +299,20 @@ updateState (ReqRegisterCapability req) = do modify $ \s -> s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } + -- Process the new registrations + forM_ newRegs $ \(regId, reg) -> do + when (reg ^. method == WorkspaceDidChangeWatchedFiles) $ do + processFileWatchRegistration regId reg + 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 } + -- Process the unregistrations + processFileWatchUnregistrations unRegs + updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri @@ -347,6 +364,7 @@ updateState (ReqApplyWorkspaceEdit r) = do contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + -- TODO: use 'sendMessage'? liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) modifyM $ \s -> do @@ -390,6 +408,7 @@ withTimeout duration f = do modify $ \s -> s { overridingTimeout = False } return res +-- TODO: add a shouldTimeout helper. need to add exceptions within Session data LogMsgType = LogServer | LogClient deriving Eq @@ -412,3 +431,52 @@ logMsg t msg = do | otherwise = Cyan showPretty = B.unpack . encodePretty + +-- File watching + +processFileWatchRegistration :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) + => T.Text -> Registration -> m () +processFileWatchRegistration regId reg = do + mgr <- asks watchManager + let mOpts = do + regOpts <- reg ^. registerOptions + case fromJSON regOpts of + Error _ -> Nothing + Success x -> Just x + case mOpts of + Nothing -> pure () + Just (DidChangeWatchedFilesRegistrationOptions (List ws)) -> + forM_ ws $ \(FileSystemWatcher pat' watchKind) -> do + pat <- liftIO $ canonicalizePath pat' + let glob = compile pat + -- the root-most dir before any globbing stuff happens + dir = fst $ commonDirectory glob + pred = match glob . eventPath + -- If no watchKind specified, spec defaults to all true + WatchKind wkC wkM wkD = fromMaybe (WatchKind True True True) watchKind + handle <- asks serverIn + unwatch <- liftIO $ watchTree mgr dir pred $ \event -> do + let fe = FileEvent (filePathToUri (eventPath event)) typ + typ = case event of + FS.Added _ _ _ -> FcCreated + FS.Modified _ _ _ -> FcChanged + FS.Removed _ _ _ -> FcDeleted + -- This is a bit of a guess + FS.Unknown _ _ _ -> FcChanged + matches = case typ of + FcCreated -> wkC + FcChanged -> wkM + FcDeleted -> wkD + params = DidChangeWatchedFilesParams (List [fe]) + msg = fmClientDidChangeWatchedFilesNotification params + liftIO $ when matches $ B.hPut handle (addHeader $ encode msg) + modify $ \s -> + s { unwatchers = Map.insertWith (++) regId [unwatch] (unwatchers s) } + +processFileWatchUnregistrations :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) + => [T.Text] -> m () +processFileWatchUnregistrations regIds = + forM_ regIds $ \regId -> modifyM $ \s -> do + let fs = fromMaybe [] (Map.lookup regId (unwatchers s)) + liftIO $ sequence fs + return $ s { unwatchers = Map.delete regId (unwatchers s) } diff --git a/test/Test.hs b/test/Test.hs index c4aae07..9035013 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -8,10 +8,12 @@ import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM import Data.Either +import Data.List (sortOn) import Data.Maybe import qualified Data.Text as T import Control.Applicative.Combinators import Control.Concurrent +import Control.Exception (finally) import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List) @@ -377,6 +379,40 @@ main = findServer >>= \serverExe -> hspec $ do count 0 $ loggingNotification void $ anyResponse + describe "file watching" $ + it "works" $ do + tmp <- liftIO getTemporaryDirectory + let testFile = tmp "lsp-test.watch" + testFile' = tmp "lsp-test.nowatch" + finally (runSession serverExe fullCaps "" $ do + loggingNotification -- initialized log message + + createDoc ".register.tmp" "haskell" "" + message :: Session RegisterCapabilityRequest + + liftIO $ writeFile testFile "Hello" -- >> hFlush h + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- this shouldn't trigger a watch files thingy + liftIO $ writeFile testFile' "Hello" + doc <- createDoc "blah" "haskell" "" + + let testNoLog = do + void $ sendRequest TextDocumentHover $ + TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + testNoLog + + -- unwatch .watch in tmp + createDoc ".unregister.tmp" "haskell" "" + message :: Session UnregisterCapabilityRequest + + -- modifying shouldn't return anything + liftIO $ writeFile testFile "Hello" + testNoLog) (mapM_ removeFile [testFile, testFile']) + mkRange :: Int -> Int -> Int -> Int -> Range mkRange sl sc el ec = Range (Position sl sc) (Position el ec) @@ -394,23 +430,24 @@ docChangesCaps = def { _workspace = Just workspaceCaps } editCaps = WorkspaceEditClientCapabilities (Just True) -findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) +findExeRecursive :: FilePath -> FilePath -> IO [FilePath] findExeRecursive exe dir = do - me <- listToMaybe <$> findExecutablesInDirectories [dir] exe - case me of - Just e -> return (Just e) - Nothing -> do + exes <- findExecutablesInDirectories [dir] exe subdirs <- (fmap (dir )) <$> listDirectory dir >>= filterM doesDirectoryExist - foldM (\acc subdir -> case acc of - Just y -> pure $ Just y - Nothing -> findExeRecursive exe subdir) - Nothing - subdirs + exes' <- concat <$> mapM (findExeRecursive exe) subdirs + return $ exes ++ exes' + +newestExe :: [FilePath] -> IO (Maybe FilePath) +newestExe exes = do + pairs <- zip exes <$> mapM getModificationTime exes + case sortOn snd pairs of + (e,_):_ -> return $ Just e + _ -> return Nothing -- | So we can find the dummy-server with cabal run -- since it doesnt put build tools on the path (only cabal test) findServer = do let serverName = "dummy-server" e <- findExecutable serverName - e' <- findExeRecursive serverName "dist-newstyle" + e' <- findExeRecursive serverName "dist-newstyle" >>= newestExe pure $ fromJust $ e <|> e' diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs index aa73677..52fc4bc 100644 --- a/test/dummy-server/Main.hs +++ b/test/dummy-server/Main.hs @@ -76,6 +76,15 @@ handlers lfvar = def DidChangeWatchedFilesRegistrationOptions $ List [ FileSystemWatcher (curDir "*.watch") (Just (WatchKind True True True)) ] ] + when (".register.tmp" `isSuffixOf` fp) $ do + tmpDir <- getTemporaryDirectory + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ + RegistrationParams $ List $ + [ Registration "2" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher (tmpDir "*.watch") (Just (WatchKind True True True)) ] + ] -- also act as an unregisterer for workspace/didChangeWatchedFiles when (".unregister" `isSuffixOf` fp) $ do @@ -86,6 +95,10 @@ handlers lfvar = def reqId <- readMVar lfvar >>= getNextReqId send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ] + when (".unregister.tmp" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ + UnregistrationParams $ List [ Unregistration "2" "workspace/didChangeWatchedFiles" ] , executeCommandHandler = pure $ \req -> do send $ RspExecuteCommand $ makeResponseMessage req Null reqId <- readMVar lfvar >>= getNextReqId -- 2.30.2