X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=ac55e9e749008c575f8a5c50dafbbec70b15040d;hp=c9507b5ffd02c7dc2dcb6f7ba770a4b0207162a7;hb=f0a961503e19c2d281c3d6319df1096f5bf6cfcf;hpb=bf56f6dd8c0b0fc34770135819caa54a6410b1df diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index c9507b5..ac55e9e 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -- | A testing tool for replaying captured client logs back to a server, -- and validating that the server output matches up with another log. module Language.Haskell.LSP.Test.Replay @@ -12,35 +9,45 @@ import Prelude hiding (id) import Control.Concurrent import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as T import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens as LSP hiding (error) import Data.Aeson +import Data.Default 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.IO import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Files -import Language.Haskell.LSP.Test.Parsing - +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Server +import Language.Haskell.LSP.Test.Session -- | Replays a captured client output and -- makes sure it matches up with an expected response. -- The session directory should have a captured session file in it -- named "session.log". -replaySession :: FilePath -- ^ The recorded session directory. - -> IO Bool -replaySession sessionDir = do +replaySession :: String -- ^ The command to run the server. + -> FilePath -- ^ The recorded session directory. + -> IO () +replaySession serverExe sessionDir = do entries <- B.lines <$> B.readFile (sessionDir "session.log") -- decode session let unswappedEvents = map (fromJust . decode) entries - events <- swapFiles sessionDir unswappedEvents + withServer serverExe False $ \serverIn serverOut serverProc -> do + + pid <- getProcessID serverProc + events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events serverEvents = filter isServerMsg events @@ -48,15 +55,21 @@ replaySession sessionDir = do serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents requestMap = getRequestMap clientMsgs - reqSema <- newEmptyMVar rspSema <- newEmptyMVar - passVar <- newEmptyMVar :: IO (MVar Bool) - - forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $ - sendMessages clientMsgs reqSema rspSema - - takeMVar passVar + passSema <- newEmptyMVar + mainThread <- myThreadId + + sessionThread <- liftIO $ forkIO $ + runSessionWithHandles serverIn serverOut serverProc + (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) + def + fullCaps + sessionDir + (return ()) -- No finalizer cleanup + (sendMessages clientMsgs reqSema rspSema) + takeMVar passSema + killThread sessionThread where isClientMsg (FromClient _ _) = True @@ -68,60 +81,25 @@ replaySession sessionDir = do sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () sendMessages [] _ _ = return () sendMessages (nextMsg:remainingMsgs) reqSema rspSema = - case nextMsg of - ReqInitialize m -> request m - ReqShutdown m -> request m - ReqHover m -> request m - ReqCompletion m -> request m - ReqCompletionItemResolve m -> request m - ReqSignatureHelp m -> request m - ReqDefinition m -> request m - ReqFindReferences m -> request m - ReqDocumentHighlights m -> request m - ReqDocumentSymbols m -> request m - ReqWorkspaceSymbols m -> request m - ReqCodeAction m -> request m - ReqCodeLens m -> request m - ReqCodeLensResolve m -> request m - ReqDocumentFormatting m -> request m - ReqDocumentRangeFormatting m -> request m - ReqDocumentOnTypeFormatting m -> request m - ReqRename m -> request m - ReqExecuteCommand m -> request m - ReqDocumentLink m -> request m - ReqDocumentLinkResolve m -> request m - ReqWillSaveWaitUntil m -> request m - RspApplyWorkspaceEdit m -> response m - RspFromClient m -> response m - NotInitialized m -> notification m - NotExit m -> notification m - NotCancelRequestFromClient m -> notification m - NotDidChangeConfiguration m -> notification m - NotDidOpenTextDocument m -> notification m - NotDidChangeTextDocument m -> notification m - NotDidCloseTextDocument m -> notification m - NotWillSaveTextDocument m -> notification m - NotDidSaveTextDocument m -> notification m - NotDidChangeWatchedFiles m -> notification m - UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m + handleClientMessage request response notification nextMsg where -- TODO: May need to prevent premature exit notification being sent notification msg@(NotificationMessage _ Exit _) = do liftIO $ putStrLn "Will send exit notification soon" liftIO $ threadDelay 10000000 - sendNotification' msg + sendMessage msg liftIO $ error "Done" notification msg@(NotificationMessage _ m _) = do - sendNotification' msg + sendMessage msg liftIO $ putStrLn $ "Sent a notification " ++ show m sendMessages remainingMsgs reqSema rspSema request msg@(RequestMessage _ id m _) = do - sendRequest' msg + sendRequestMessage msg liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" rsp <- liftIO $ takeMVar rspSema @@ -136,11 +114,20 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = if responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do - sendResponse' msg + sendResponse msg liftIO $ putStrLn $ "Sent response to request id " ++ show id sendMessages remainingMsgs reqSema rspSema +sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () +sendRequestMessage req = do + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method) + + sendMessage req + isNotification :: FromServerMessage -> Bool isNotification (NotPublishDiagnostics _) = True @@ -149,79 +136,51 @@ isNotification (NotShowMessage _) = True isNotification (NotCancelRequestFromServer _) = True 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 +listenServer :: [FromServerMessage] + -> RequestMap + -> MVar LspId + -> MVar LspIdRsp + -> MVar () + -> ThreadId + -> Handle + -> SessionContext + -> IO () +listenServer [] _ _ _ passSema _ _ _ = putMVar passSema () +listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do + + msgBytes <- getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes - case msg of - ReqRegisterCapability m -> request m - ReqApplyWorkspaceEdit m -> request m - ReqShowMessage m -> request m - ReqUnregisterCapability m -> request m - RspInitialize m -> response m - RspShutdown m -> response m - RspHover m -> response m - RspCompletion m -> response m - RspCompletionItemResolve m -> response m - RspSignatureHelp m -> response m - RspDefinition m -> response m - RspFindReferences m -> response m - RspDocumentHighlights m -> response m - RspDocumentSymbols m -> response m - RspWorkspaceSymbols m -> response m - RspCodeAction m -> response m - RspCodeLens m -> response m - RspCodeLensResolve m -> response m - RspDocumentFormatting m -> response m - RspDocumentRangeFormatting m -> response m - RspDocumentOnTypeFormatting m -> response m - RspRename m -> response m - RspExecuteCommand m -> response m - RspError m -> response m - RspDocumentLink m -> response m - RspDocumentLinkResolve m -> response m - RspWillSaveWaitUntil m -> response m - NotPublishDiagnostics m -> notification m - NotLogMessage m -> notification m - NotShowMessage m -> notification m - NotTelemetry m -> notification m - NotCancelRequestFromServer m -> notification m + handleServerMessage request response notification msg if shouldSkip msg - then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut + then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx else if inRightOrder msg expectedMsgs - then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut - else liftIO $ do - putStrLn "Out of order" - putStrLn "Got:" - print msg - putStrLn "Expected one of:" - mapM_ print $ takeWhile (not . isNotification) expectedMsgs - print $ head $ dropWhile (not . isNotification) expectedMsgs - putMVar passVar False + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx + else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs + ++ [head $ dropWhile isNotification expectedMsgs] + exc = ReplayOutOfOrder msg remainingMsgs + in liftIO $ throwTo mainThreadId exc where - response :: Show a => ResponseMessage a -> Session () + response :: ResponseMessage a -> IO () response res = do - liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) + putStrLn $ "Got response for id " ++ show (res ^. id) - liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request + putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () + request :: RequestMessage ServerMethod a b -> IO () request req = do - liftIO - $ putStrLn + putStrLn $ "Got request for id " ++ show (req ^. id) ++ " " ++ show (req ^. method) - liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response + putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification :: Show a => NotificationMessage ServerMethod a -> Session () - notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + notification :: NotificationMessage ServerMethod a -> IO () + notification n = putStrLn $ "Got notification " ++ show (n ^. method) @@ -250,3 +209,27 @@ shouldSkip (NotLogMessage _) = True shouldSkip (NotShowMessage _) = True shouldSkip (ReqShowMessage _) = True shouldSkip _ = False + +-- | Swaps out any commands uniqued with process IDs to match the specified process ID +swapCommands :: Int -> [Event] -> [Event] +swapCommands _ [] = [] + +swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs + where swapped = params . command .~ newCmd $ req + newCmd = swapPid pid (req ^. params . command) + +swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs + where swapped = case newCommands of + Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp + Nothing -> rsp + oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands + newCommands = fmap (fmap (swapPid pid)) oldCommands + +swapCommands pid (x:xs) = x:swapCommands pid xs + +hasPid :: T.Text -> Bool +hasPid = (>= 2) . T.length . T.filter (':' ==) +swapPid :: Int -> T.Text -> T.Text +swapPid pid t + | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t + | otherwise = t