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   forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
  54     sendMessages clientMsgs reqSema rspSema
  55
  56   takeMVar passVar
  57
  58   where
  59     isClientMsg (FromClient _ _) = True
  60     isClientMsg _                = False
  61
  62     isServerMsg (FromServer _ _) = True
  63     isServerMsg _                = False
  64
  65 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
  66 sendMessages [] _ _ = return ()
  67 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
  68   handleClientMessage request response notification nextMsg
  69  where
  70   -- TODO: May need to prevent premature exit notification being sent
  71   notification msg@(NotificationMessage _ Exit _) = do
  72     liftIO $ putStrLn "Will send exit notification soon"
  73     liftIO $ threadDelay 10000000
  74     sendNotification' msg
  75
  76     liftIO $ error "Done"
  77
  78   notification msg@(NotificationMessage _ m _) = do
  79     sendNotification' msg
  80
  81     liftIO $ putStrLn $ "Sent a notification " ++ show m
  82
  83     sendMessages remainingMsgs reqSema rspSema
  84
  85   request msg@(RequestMessage _ id m _) = do
  86     sendRequest' msg
  87     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
  88
  89     rsp <- liftIO $ takeMVar rspSema
  90     when (responseId id /= rsp) $
  91       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
  92
  93     sendMessages remainingMsgs reqSema rspSema
  94
  95   response msg@(ResponseMessage _ id _ _) = do
  96     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
  97     reqId <- liftIO $ takeMVar reqSema
  98     if responseId reqId /= id
  99       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 100       else do
 101         sendResponse msg
 102         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 103
 104     sendMessages remainingMsgs reqSema rspSema
 105
 106
 107 isNotification :: FromServerMessage -> Bool
 108 isNotification (NotPublishDiagnostics      _) = True
 109 isNotification (NotLogMessage              _) = True
 110 isNotification (NotShowMessage             _) = True
 111 isNotification (NotCancelRequestFromServer _) = True
 112 isNotification _                              = False
 113
 114 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
 115 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
 116 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
 117   msgBytes <- liftIO $ getNextMessage serverOut
 118   let msg = decodeFromServerMsg reqMap msgBytes
 119
 120   handleServerMessage request response notification msg
 121
 122   if shouldSkip msg
 123     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
 124     else if inRightOrder msg expectedMsgs
 125       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
 126       else liftIO $ do
 127         putStrLn "Out of order"
 128         putStrLn "Got:"
 129         print msg
 130         putStrLn "Expected one of:"
 131         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
 132         print $ head $ dropWhile isNotification expectedMsgs
 133         putMVar passVar False
 134
 135   where
 136   response :: ResponseMessage a -> Session ()
 137   response res = do
 138     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 139
 140     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 141
 142   request :: RequestMessage ServerMethod a b -> Session ()
 143   request req = do
 144     liftIO
 145       $  putStrLn
 146       $  "Got request for id "
 147       ++ show (req ^. id)
 148       ++ " "
 149       ++ show (req ^. method)
 150
 151     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 152
 153   notification :: NotificationMessage ServerMethod a -> Session ()
 154   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
 155
 156
 157
 158 -- TODO: QuickCheck tests?
 159 -- | Checks wether or not the message appears in the right order
 160 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 161 -- given N2, notification order doesn't matter.
 162 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 163 -- given REQ1
 164 -- @ N1 N3 N4 N5 REQ2 RES1 @
 165 -- given RES1
 166 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 167 -- Order of requests and responses matter
 168 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 169
 170 inRightOrder _ [] = error "Why is this empty"
 171
 172 inRightOrder received (expected : msgs)
 173   | received == expected    = True
 174   | isNotification expected = inRightOrder received msgs
 175   | otherwise               = False
 176
 177 -- | Ignore logging notifications since they vary from session to session
 178 shouldSkip :: FromServerMessage -> Bool
 179 shouldSkip (NotLogMessage  _) = True
 180 shouldSkip (NotShowMessage _) = True
 181 shouldSkip (ReqShowMessage _) = True
 182 shouldSkip _                  = False