src/Language/Haskell/LSP/Test/Replay.hs

   1 -- | A testing tool for replaying captured client logs back to a server,
   2 -- and validating that the server output matches up with another log.
   3 module Language.Haskell.LSP.Test.Replay
   4   ( replaySession
   5   )
   6 where
   7
   8 import           Prelude hiding (id)
   9 import           Control.Concurrent
  10 import           Control.Monad.IO.Class
  11 import qualified Data.ByteString.Lazy.Char8    as B
  12 import qualified Data.Text                     as T
  13 import           Language.Haskell.LSP.Capture
  14 import           Language.Haskell.LSP.Messages
  15 import           Language.Haskell.LSP.Types
  16 import           Language.Haskell.LSP.Types.Lens as LSP hiding (error)
  17 import           Data.Aeson
  18 import           Data.Default
  19 import           Data.List
  20 import           Data.Maybe
  21 import           Control.Lens hiding (List)
  22 import           Control.Monad
  23 import           System.FilePath
  24 import           System.IO
  25 import           Language.Haskell.LSP.Test
  26 import           Language.Haskell.LSP.Test.Files
  27 import           Language.Haskell.LSP.Test.Decoding
  28 import           Language.Haskell.LSP.Test.Messages
  29 import           Language.Haskell.LSP.Test.Server
  30 import           Language.Haskell.LSP.Test.Session
  31
  32 -- | Replays a captured client output and
  33 -- makes sure it matches up with an expected response.
  34 -- The session directory should have a captured session file in it
  35 -- named "session.log".
  36 replaySession :: String -- ^ The command to run the server.
  37               -> FilePath -- ^ The recorded session directory.
  38               -> IO ()
  39 replaySession serverExe sessionDir = do
  40
  41   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
  42
  43   -- decode session
  44   let unswappedEvents = map (fromJust . decode) entries
  45
  46   withServer serverExe False $ \serverIn serverOut pid -> do
  47
  48     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
  49
  50     let clientEvents = filter isClientMsg events
  51         serverEvents = filter isServerMsg events
  52         clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
  53         serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
  54         requestMap = getRequestMap clientMsgs
  55
  56     reqSema <- newEmptyMVar
  57     rspSema <- newEmptyMVar
  58     passSema <- newEmptyMVar
  59     mainThread <- myThreadId
  60
  61     sessionThread <- liftIO $ forkIO $
  62       runSessionWithHandles serverIn
  63                             serverOut
  64                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
  65                             def
  66                             fullCaps
  67                             sessionDir
  68                             (sendMessages clientMsgs reqSema rspSema)
  69     takeMVar passSema
  70     killThread sessionThread
  71
  72   where
  73     isClientMsg (FromClient _ _) = True
  74     isClientMsg _                = False
  75
  76     isServerMsg (FromServer _ _) = True
  77     isServerMsg _                = False
  78
  79 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
  80 sendMessages [] _ _ = return ()
  81 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
  82   handleClientMessage request response notification nextMsg
  83  where
  84   -- TODO: May need to prevent premature exit notification being sent
  85   notification msg@(NotificationMessage _ Exit _) = do
  86     liftIO $ putStrLn "Will send exit notification soon"
  87     liftIO $ threadDelay 10000000
  88     sendMessage msg
  89
  90     liftIO $ error "Done"
  91
  92   notification msg@(NotificationMessage _ m _) = do
  93     sendMessage msg
  94
  95     liftIO $ putStrLn $ "Sent a notification " ++ show m
  96
  97     sendMessages remainingMsgs reqSema rspSema
  98
  99   request msg@(RequestMessage _ id m _) = do
 100     sendRequestMessage msg
 101     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 102
 103     rsp <- liftIO $ takeMVar rspSema
 104     when (responseId id /= rsp) $
 105       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
 106
 107     sendMessages remainingMsgs reqSema rspSema
 108
 109   response msg@(ResponseMessage _ id _ _) = do
 110     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 111     reqId <- liftIO $ takeMVar reqSema
 112     if responseId reqId /= id
 113       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 114       else do
 115         sendResponse msg
 116         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 117
 118     sendMessages remainingMsgs reqSema rspSema
 119
 120 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 121 sendRequestMessage req = do
 122   -- Update the request map
 123   reqMap <- requestMap <$> ask
 124   liftIO $ modifyMVar_ reqMap $
 125     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 126
 127   sendMessage req
 128
 129
 130 isNotification :: FromServerMessage -> Bool
 131 isNotification (NotPublishDiagnostics      _) = True
 132 isNotification (NotLogMessage              _) = True
 133 isNotification (NotShowMessage             _) = True
 134 isNotification (NotCancelRequestFromServer _) = True
 135 isNotification _                              = False
 136
 137 listenServer :: [FromServerMessage]
 138              -> RequestMap
 139              -> MVar LspId
 140              -> MVar LspIdRsp
 141              -> MVar ()
 142              -> ThreadId
 143              -> Handle
 144              -> SessionContext
 145              -> IO ()
 146 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
 147 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
 148
 149   msgBytes <- getNextMessage serverOut
 150   let msg = decodeFromServerMsg reqMap msgBytes
 151
 152   handleServerMessage request response notification msg
 153
 154   if shouldSkip msg
 155     then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
 156     else if inRightOrder msg expectedMsgs
 157       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
 158       else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
 159                 ++ [head $ dropWhile isNotification expectedMsgs]
 160                exc = ReplayOutOfOrder msg remainingMsgs
 161             in liftIO $ throwTo mainThreadId exc
 162
 163   where
 164   response :: ResponseMessage a -> IO ()
 165   response res = do
 166     putStrLn $ "Got response for id " ++ show (res ^. id)
 167
 168     putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 169
 170   request :: RequestMessage ServerMethod a b -> IO ()
 171   request req = do
 172     putStrLn
 173       $  "Got request for id "
 174       ++ show (req ^. id)
 175       ++ " "
 176       ++ show (req ^. method)
 177
 178     putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 179
 180   notification :: NotificationMessage ServerMethod a -> IO ()
 181   notification n = putStrLn $ "Got notification " ++ show (n ^. method)
 182
 183
 184
 185 -- TODO: QuickCheck tests?
 186 -- | Checks wether or not the message appears in the right order
 187 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 188 -- given N2, notification order doesn't matter.
 189 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 190 -- given REQ1
 191 -- @ N1 N3 N4 N5 REQ2 RES1 @
 192 -- given RES1
 193 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 194 -- Order of requests and responses matter
 195 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 196
 197 inRightOrder _ [] = error "Why is this empty"
 198
 199 inRightOrder received (expected : msgs)
 200   | received == expected               = True
 201   | isNotification expected            = inRightOrder received msgs
 202   | otherwise                          = False
 203
 204 -- | Ignore logging notifications since they vary from session to session
 205 shouldSkip :: FromServerMessage -> Bool
 206 shouldSkip (NotLogMessage  _) = True
 207 shouldSkip (NotShowMessage _) = True
 208 shouldSkip (ReqShowMessage _) = True
 209 shouldSkip _                  = False
 210
 211 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
 212 swapCommands :: Int -> [Event] -> [Event]
 213 swapCommands _ [] = []
 214
 215 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) =  FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
 216   where swapped = params . command .~ newCmd $ req
 217         newCmd = swapPid pid (req ^. params . command)
 218
 219 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
 220   where swapped = case newCommands of
 221           Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
 222           Nothing -> rsp
 223         oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
 224         newCommands = fmap (fmap (swapPid pid)) oldCommands
 225
 226 swapCommands pid (x:xs) = x:swapCommands pid xs
 227
 228 hasPid :: T.Text -> Bool
 229 hasPid = (>= 2) . T.length . T.filter (':' ==)
 230 swapPid :: Int -> T.Text -> T.Text
 231 swapPid pid t
 232   | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t
 233   | otherwise = t