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