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