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