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