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