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