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