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