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