-{-# 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
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.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 pid -> do
+
+ events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
let clientEvents = filter isClientMsg events
serverEvents = filter isServerMsg events
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
+ (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
+ def
+ fullCaps
+ sessionDir
+ (sendMessages clientMsgs reqSema rspSema)
+ takeMVar passSema
+ killThread sessionThread
where
isClientMsg (FromClient _ _) = True
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
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
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)
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