From 5170a20560a68b8fcaed83ecaf6146d84a147992 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 14 Jun 2018 10:36:34 -0400 Subject: [PATCH] Swap out UUIDs based on process ID Start processing ReqApplyWorkspaceEdit Split out into more modules --- haskell-lsp-test.cabal | 6 +- src/Language/Haskell/LSP/Test.hs | 84 +++++++++++---------- src/Language/Haskell/LSP/Test/Parsing.hs | 53 ------------- src/Language/Haskell/LSP/Test/Replay.hs | 38 ++++++++-- src/Language/Haskell/LSP/Test/Server.hs | 25 +++++++ src/Language/Haskell/LSP/Test/Session.hs | 94 ++++++++++++++++++++++++ test/data/renamePass/session.log | 2 +- 7 files changed, 202 insertions(+), 100 deletions(-) create mode 100644 src/Language/Haskell/LSP/Test/Server.hs create mode 100644 src/Language/Haskell/LSP/Test/Session.hs diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index cc2eb6f..5907d74 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -32,8 +32,10 @@ library , lens , parser-combinators , process + , random , text , transformers + , uuid , unordered-containers if os(windows) build-depends: win32 @@ -42,8 +44,10 @@ library other-modules: Language.Haskell.LSP.Test.Compat Language.Haskell.LSP.Test.Decoding Language.Haskell.LSP.Test.Files - Language.Haskell.LSP.Test.Parsing Language.Haskell.LSP.Test.Messages + Language.Haskell.LSP.Test.Parsing + Language.Haskell.LSP.Test.Server + Language.Haskell.LSP.Test.Session ghc-options: -W test-suite tests diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 4f3094f..4f82498 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -15,7 +15,7 @@ module Language.Haskell.LSP.Test ( -- * Sessions runSession - , runSessionWithHandler + , runSessionWithHandles , Session -- * Sending , sendRequest @@ -65,21 +65,27 @@ import Control.Applicative.Combinators import Control.Monad import Control.Monad.IO.Class import Control.Concurrent -import Control.Lens hiding ((.=)) +import Control.Lens hiding ((.=), List) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Default -import System.Process +import Data.Foldable +import qualified Data.HashMap.Strict as HashMap +import Data.List import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP (error, id) +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Parsing +import Language.Haskell.LSP.Test.Session +import Language.Haskell.LSP.Test.Server import System.IO import System.Directory import System.FilePath -import Language.Haskell.LSP.Test.Decoding -import Language.Haskell.LSP.Test.Parsing -- | Starts a new session. runSession :: String -- ^ The command to run the server. @@ -97,7 +103,7 @@ runSession serverExe rootDir session = do def (Just TraceOff) - runSessionWithHandler listenServer serverExe rootDir $ do + withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do -- Wrap the session around initialize and shutdown calls sendRequest Initialize initializeParams @@ -108,7 +114,6 @@ runSession serverExe rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams -- Run the actual test @@ -118,38 +123,6 @@ runSession serverExe rootDir session = do return result --- | An internal version of 'runSession' that allows for a custom handler to listen to the server. --- It also does not automatically send initialize and exit messages. -runSessionWithHandler :: (Handle -> Session ()) - -> String - -> FilePath - -> Session a - -> IO a -runSessionWithHandler serverHandler serverExe rootDir session = do - absRootDir <- canonicalizePath rootDir - - let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } - (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc - - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - - reqMap <- newMVar newRequestMap - messageChan <- newChan - meaninglessChan <- newChan - initRsp <- newEmptyMVar - - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp - initState = SessionState (IdInt 9) - - threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) - (result, _) <- runSession' messageChan context initState session - - terminateProcess serverProc - killThread threadId - - return result - -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores listenServer :: Handle -> Session () @@ -159,10 +132,41 @@ listenServer serverOut = do context <- ask reqMap <- liftIO $ readMVar $ requestMap context - liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes + let msg = decodeFromServerMsg reqMap msgBytes + processTextChanges msg + liftIO $ writeChan (messageChan context) msg listenServer serverOut +processTextChanges :: FromServerMessage -> Session () +processTextChanges (ReqApplyWorkspaceEdit r) = do + List changeParams <- case r ^. params . edit . documentChanges of + Just cs -> mapM applyTextDocumentEdit cs + Nothing -> case r ^. params . edit . changes of + Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs)) + Nothing -> return (List []) + + let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams + mergedParams = map mergeParams groupedParams + + forM_ mergedParams (sendNotification TextDocumentDidChange) + + where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do + oldVFS <- vfs <$> get + let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits + params = DidChangeTextDocumentParams docId (List changeEvents) + newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params) + modify (\s -> s { vfs = newVFS }) + liftIO $ print newVFS + return params + + applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits) + + mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams + mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) + in DidChangeTextDocumentParams (head params ^. textDocument) (List events) +processTextChanges _ = return () + -- | Sends a request to the server. -- -- @ diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 8c05590..693c62e 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -5,51 +5,13 @@ module Language.Haskell.LSP.Test.Parsing where import Control.Applicative -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit hiding (await) import Data.Conduit.Parser import Data.Maybe import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types hiding (error) -import Language.Haskell.LSP.Test.Compat -import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Messages -import System.IO - -data SessionContext = SessionContext - { - serverIn :: Handle, - rootDir :: FilePath, - messageChan :: Chan FromServerMessage, - requestMap :: MVar RequestMap, - initRsp :: MVar InitializeResponse - } - -newtype SessionState = SessionState - { - curReqId :: LspId - } - -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) - --- | A session representing one instance of launching and connecting to a server. --- --- You can send and receive messages to the server within 'Session' via 'getMessage', --- 'sendRequest' and 'sendNotification'. --- --- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification --- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO -- | Matches if the message is a notification. anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage @@ -113,18 +75,3 @@ satisfy pred = do then return x else empty -runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession' chan context state session = runReaderT (runStateT conduit state) context - where conduit = runConduit $ chanSource chan .| runConduitParser session - -get :: Monad m => ParserStateReader a s r m s -get = lift Control.Monad.Trans.State.get - -put :: Monad m => s -> ParserStateReader a s r m () -put = lift . Control.Monad.Trans.State.put - -modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . Control.Monad.Trans.State.modify - -ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Control.Monad.Trans.Reader.ask diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 9d7f136..7def859 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -7,22 +7,27 @@ where import Prelude hiding (id) import Control.Concurrent +import Control.Exception import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as T +import Data.UUID import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types hiding (error) import Data.Aeson import Data.List import Data.Maybe -import Control.Lens +import Control.Lens hiding (List) import Control.Monad import System.IO import System.FilePath +import System.Random import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Server -- | Replays a captured client output and @@ -39,7 +44,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - events <- swapFiles sessionDir unswappedEvents + withServer serverExe $ \serverIn serverOut pid -> do + + events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events serverEvents = filter isServerMsg events @@ -52,8 +59,9 @@ replaySession serverExe sessionDir = do passVar <- newEmptyMVar :: IO (MVar Bool) threadId <- forkIO $ - runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) - serverExe + runSessionWithHandles serverIn + serverOut + (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir (sendMessages clientMsgs reqSema rspSema) @@ -120,7 +128,11 @@ isNotification _ = False listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session () listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do - msgBytes <- liftIO $ getNextMessage serverOut + + let handler :: IOException -> IO B.ByteString + handler _ = putMVar passVar False >> return B.empty + + msgBytes <- liftIO $ catch (getNextMessage serverOut) handler let msg = decodeFromServerMsg reqMap msgBytes handleServerMessage request response notification msg @@ -186,3 +198,19 @@ shouldSkip (NotLogMessage _) = True shouldSkip (NotShowMessage _) = True shouldSkip (ReqShowMessage _) = True shouldSkip _ = False + +-- | Swaps out the expected UUIDs to match the current process ID +swapUUIDs :: Int -> [Event] -> [Event] +swapUUIDs _ [] = [] +swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs + where swapped = case newCommands of + Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp + Nothing -> rsp + oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands + newCommands = fmap (fmap swap) oldCommands + swap cmd + | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd + | otherwise = cmd + uuid = toText $ fst $ random $ mkStdGen pid + isUuid = isJust . fromText . T.takeWhile (/= ':') +swapUUIDs pid (x:xs) = x:swapUUIDs pid xs \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs new file mode 100644 index 0000000..65011fd --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -0,0 +1,25 @@ +module Language.Haskell.LSP.Test.Server where + +import Control.Concurrent +import Control.Monad +import Data.Maybe +import System.IO +import System.Process + +withServer :: String -> (Handle -> Handle -> Int -> IO a) -> IO a +withServer serverExe f = do + let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc + + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering serverErr NoBuffering + errSinkThread <- forkIO $ forever $ hGetLine serverErr + + pid <- fromIntegral . fromJust <$> getPid serverProc + + result <- f serverIn serverOut pid + + killThread errSinkThread + terminateProcess serverProc + return result \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs new file mode 100644 index 0000000..3707dfd --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -0,0 +1,94 @@ +module Language.Haskell.LSP.Test.Session where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Data.Conduit +import Data.Conduit.Parser +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Test.Compat +import Language.Haskell.LSP.Test.Decoding +import System.Directory +import System.IO + +data SessionContext = SessionContext + { + serverIn :: Handle + , rootDir :: FilePath + , messageChan :: Chan FromServerMessage + , requestMap :: MVar RequestMap + , initRsp :: MVar InitializeResponse + } + +data SessionState = SessionState + { + curReqId :: LspId + , vfs :: VFS + } + +type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) + +-- | A session representing one instance of launching and connecting to a server. +-- +-- You can send and receive messages to the server within 'Session' via 'getMessage', +-- 'sendRequest' and 'sendNotification'. +-- +-- @ +-- runSession \"path\/to\/root\/dir\" $ do +-- docItem <- getDocItem "Desktop/simple.hs" "haskell" +-- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) +-- diagnostics <- getMessage :: Session PublishDiagnosticsNotification +-- @ +type Session = ParserStateReader FromServerMessage SessionState SessionContext IO + + +runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession' chan context state session = runReaderT (runStateT conduit state) context + where conduit = runConduit $ chanSource chan .| runConduitParser session + +get :: Monad m => ParserStateReader a s r m s +get = lift Control.Monad.Trans.State.get + +put :: Monad m => s -> ParserStateReader a s r m () +put = lift . Control.Monad.Trans.State.put + +modify :: Monad m => (s -> s) -> ParserStateReader a s r m () +modify = lift . Control.Monad.Trans.State.modify + +ask :: Monad m => ParserStateReader a s r m r +ask = lift $ lift Control.Monad.Trans.Reader.ask + + + +-- | An internal version of 'runSession' that allows for a custom handler to listen to the server. +-- It also does not automatically send initialize and exit messages. +runSessionWithHandles :: Handle -- ^ Server in + -> Handle -- ^ Server out + -> (Handle -> Session ()) -- ^ Server listener + -> FilePath + -> Session a + -> IO a +runSessionWithHandles serverIn serverOut serverHandler rootDir session = do + absRootDir <- canonicalizePath rootDir + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering + + reqMap <- newMVar newRequestMap + messageChan <- newChan + meaninglessChan <- newChan + initRsp <- newEmptyMVar + + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp + initState = SessionState (IdInt 9) mempty + + threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) + (result, _) <- runSession' messageChan context initState session + + killThread threadId + + return result \ No newline at end of file diff --git a/test/data/renamePass/session.log b/test/data/renamePass/session.log index 1542063..36b6c2a 100644 --- a/test/data/renamePass/session.log +++ b/test/data/renamePass/session.log @@ -1,5 +1,5 @@ {"tag":"FromClient","contents":["2018-06-03T04:08:38.856591Z",{"tag":"ReqInitialize","contents":{"jsonrpc":"2.0","params":{"rootUri":"file:///Users/luke","processId":7558,"rootPath":"/Users/luke","capabilities":{"textDocument":{"completion":{"completionItem":{"snippetSupport":false}}}},"trace":"off"},"method":"initialize","id":9}}]} -{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["applyrefact:applyOne","hare:demote"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]} +{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["57b3244d-e5fe-47fe-9ca8-f4b15f444541:applyrefact:applyOne","57b3244d-e5fe-47fe-9ca8-f4b15f444541:hare:demote"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.325465Z",{"tag":"NotInitialized","contents":{"jsonrpc":"2.0","params":{},"method":"initialized"}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.325807Z",{"tag":"NotDidChangeConfiguration","contents":{"jsonrpc":"2.0","params":{"settings":{}},"method":"workspace/didChangeConfiguration"}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.326177Z",{"tag":"NotDidOpenTextDocument","contents":{"jsonrpc":"2.0","params":{"textDocument":{"languageId":"haskell","text":"module Main where\n\nmain :: IO ()\nmain = do\n let initialList = []\n interactWithUser initialList\n\ntype Item = String\ntype Items = [Item]\n\ndata Command = Quit\n | DisplayItems\n | AddItem String\n | RemoveItem Int\n | Help\n\ntype Error = String\n\nparseCommand :: String -> Either Error Command\nparseCommand line = case words line of\n [\"quit\"] -> Right Quit\n [\"items\"] -> Right DisplayItems\n \"add\" : item -> Right $ AddItem $ unwords item\n \"remove\" : i -> Right $ RemoveItem $ read $ unwords i\n [\"help\"] -> Right Help\n _ -> Left \"Unknown command\"\n\naddItem :: Item -> Items -> Items\naddItem = (:)\n\ndisplayItems :: Items -> String\ndisplayItems = unlines . map (\"- \" ++)\n\nremoveItem :: Int -> Items -> Either Error Items\nremoveItem i items\n | i < 0 || i >= length items = Left \"Out of range\"\n | otherwise = Right result\n where (front, back) = splitAt (i + 1) items\n result = init front ++ back\n\ninteractWithUser :: Items -> IO ()\ninteractWithUser items = do\n line <- getLine\n case parseCommand line of\n Right DisplayItems -> do\n putStrLn $ displayItems items\n interactWithUser items\n\n Right (AddItem item) -> do\n let newItems = addItem item items\n putStrLn \"Added\"\n interactWithUser newItems\n\n Right (RemoveItem i) ->\n case removeItem i items of\n Right newItems -> do\n putStrLn $ \"Removed \" ++ items !! i\n interactWithUser newItems\n Left err -> do\n putStrLn err\n interactWithUser items\n\n\n Right Quit -> return ()\n\n Right Help -> do\n putStrLn \"Commands:\"\n putStrLn \"help\"\n putStrLn \"items\"\n putStrLn \"add\"\n putStrLn \"quit\"\n interactWithUser items\n\n Left err -> do\n putStrLn $ \"Error: \" ++ err\n interactWithUser items\n","uri":"file:///Users/luke/Desktop/simple.hs","version":0}},"method":"textDocument/didOpen"}}]} -- 2.30.2