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           Language.Haskell.LSP.Capture
  13 import           Language.Haskell.LSP.Messages
  14 import           Language.Haskell.LSP.Types hiding (error)
  15 import           Data.Aeson
  16 import           Data.List
  17 import           Data.Maybe
  18 import           Control.Lens
  19 import           Control.Monad
  20 import           System.IO
  21 import           System.FilePath
  22 import           Language.Haskell.LSP.Test
  23 import           Language.Haskell.LSP.Test.Files
  24 import           Language.Haskell.LSP.Test.Decoding
  25 import           Language.Haskell.LSP.Test.Messages
  26
  27
  28 -- | Replays a captured client output and
  29 -- makes sure it matches up with an expected response.
  30 -- The session directory should have a captured session file in it
  31 -- named "session.log".
  32 replaySession :: FilePath -- ^ The recorded session directory.
  33               -> IO Bool
  34 replaySession sessionDir = do
  35
  36   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
  37
  38   -- decode session
  39   let unswappedEvents = map (fromJust . decode) entries
  40
  41   events <- swapFiles sessionDir unswappedEvents
  42
  43   let clientEvents = filter isClientMsg events
  44       serverEvents = filter isServerMsg events
  45       clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
  46       serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
  47       requestMap = getRequestMap clientMsgs
  48
  49   reqSema <- newEmptyMVar
  50   rspSema <- newEmptyMVar
  51   passVar <- newEmptyMVar :: IO (MVar Bool)
  52
  53   threadId <- forkIO $
  54     runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
  55                           sessionDir
  56                           (sendMessages clientMsgs reqSema rspSema)
  57
  58   result <- takeMVar passVar
  59   killThread threadId
  60   return result
  61
  62   where
  63     isClientMsg (FromClient _ _) = True
  64     isClientMsg _                = False
  65
  66     isServerMsg (FromServer _ _) = True
  67     isServerMsg _                = False
  68
  69 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
  70 sendMessages [] _ _ = return ()
  71 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
  72   handleClientMessage request response notification nextMsg
  73  where
  74   -- TODO: May need to prevent premature exit notification being sent
  75   notification msg@(NotificationMessage _ Exit _) = do
  76     liftIO $ putStrLn "Will send exit notification soon"
  77     liftIO $ threadDelay 10000000
  78     sendNotification' msg
  79
  80     liftIO $ error "Done"
  81
  82   notification msg@(NotificationMessage _ m _) = do
  83     sendNotification' msg
  84
  85     liftIO $ putStrLn $ "Sent a notification " ++ show m
  86
  87     sendMessages remainingMsgs reqSema rspSema
  88
  89   request msg@(RequestMessage _ id m _) = do
  90     sendRequest' msg
  91     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
  92
  93     rsp <- liftIO $ takeMVar rspSema
  94     when (responseId id /= rsp) $
  95       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
  96
  97     sendMessages remainingMsgs reqSema rspSema
  98
  99   response msg@(ResponseMessage _ id _ _) = do
 100     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 101     reqId <- liftIO $ takeMVar reqSema
 102     if responseId reqId /= id
 103       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 104       else do
 105         sendResponse msg
 106         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 107
 108     sendMessages remainingMsgs reqSema rspSema
 109
 110
 111 isNotification :: FromServerMessage -> Bool
 112 isNotification (NotPublishDiagnostics      _) = True
 113 isNotification (NotLogMessage              _) = True
 114 isNotification (NotShowMessage             _) = True
 115 isNotification (NotCancelRequestFromServer _) = True
 116 isNotification _                              = False
 117
 118 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
 119 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
 120 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
 121   msgBytes <- liftIO $ getNextMessage serverOut
 122   let msg = decodeFromServerMsg reqMap msgBytes
 123
 124   handleServerMessage request response notification msg
 125
 126   if shouldSkip msg
 127     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
 128     else if inRightOrder msg expectedMsgs
 129       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
 130       else liftIO $ do
 131         putStrLn "Out of order"
 132         putStrLn "Got:"
 133         print msg
 134         putStrLn "Expected one of:"
 135         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
 136         print $ head $ dropWhile isNotification expectedMsgs
 137         putMVar passVar False
 138
 139   where
 140   response :: ResponseMessage a -> Session ()
 141   response res = do
 142     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 143
 144     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 145
 146   request :: RequestMessage ServerMethod a b -> Session ()
 147   request req = do
 148     liftIO
 149       $  putStrLn
 150       $  "Got request for id "
 151       ++ show (req ^. id)
 152       ++ " "
 153       ++ show (req ^. method)
 154
 155     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 156
 157   notification :: NotificationMessage ServerMethod a -> Session ()
 158   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
 159
 160
 161
 162 -- TODO: QuickCheck tests?
 163 -- | Checks wether or not the message appears in the right order
 164 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 165 -- given N2, notification order doesn't matter.
 166 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 167 -- given REQ1
 168 -- @ N1 N3 N4 N5 REQ2 RES1 @
 169 -- given RES1
 170 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 171 -- Order of requests and responses matter
 172 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 173
 174 inRightOrder _ [] = error "Why is this empty"
 175
 176 inRightOrder received (expected : msgs)
 177   | received == expected    = True
 178   | isNotification expected = inRightOrder received msgs
 179   | otherwise               = False
 180
 181 -- | Ignore logging notifications since they vary from session to session
 182 shouldSkip :: FromServerMessage -> Bool
 183 shouldSkip (NotLogMessage  _) = True
 184 shouldSkip (NotShowMessage _) = True
 185 shouldSkip (ReqShowMessage _) = True
 186 shouldSkip _                  = False