src/Language/Haskell/LSP/Test/Recorded.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 -- | A testing tool for replaying recorded client logs back to a server,
   5 -- and validating that the server output matches up with another log.
   6 module Language.Haskell.LSP.Test.Recorded
   7   ( replaySession
   8   )
   9 where
  10
  11 import           Prelude hiding (id)
  12 import           Control.Concurrent
  13 import           Control.Monad.IO.Class
  14 import qualified Data.ByteString.Lazy.Char8    as B
  15 import           Language.Haskell.LSP.Capture
  16 import           Language.Haskell.LSP.Messages
  17 import           Language.Haskell.LSP.Types hiding (error)
  18 import           Data.Aeson
  19 import           Data.List
  20 import           Data.Maybe
  21 import           Control.Lens
  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.Parsing
  28
  29
  30 -- | Replays a recorded client output and
  31 -- makes sure it matches up with an expected response.
  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
  50   reqSema <- newEmptyMVar
  51   rspSema <- newEmptyMVar
  52   passVar <- newEmptyMVar :: IO (MVar Bool)
  53
  54   forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) 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   case nextMsg of
  70     ReqInitialize               m -> request m
  71     ReqShutdown                 m -> request m
  72     ReqHover                    m -> request m
  73     ReqCompletion               m -> request m
  74     ReqCompletionItemResolve    m -> request m
  75     ReqSignatureHelp            m -> request m
  76     ReqDefinition               m -> request m
  77     ReqFindReferences           m -> request m
  78     ReqDocumentHighlights       m -> request m
  79     ReqDocumentSymbols          m -> request m
  80     ReqWorkspaceSymbols         m -> request m
  81     ReqCodeAction               m -> request m
  82     ReqCodeLens                 m -> request m
  83     ReqCodeLensResolve          m -> request m
  84     ReqDocumentFormatting       m -> request m
  85     ReqDocumentRangeFormatting  m -> request m
  86     ReqDocumentOnTypeFormatting m -> request m
  87     ReqRename                   m -> request m
  88     ReqExecuteCommand           m -> request m
  89     ReqDocumentLink             m -> request m
  90     ReqDocumentLinkResolve      m -> request m
  91     ReqWillSaveWaitUntil        m -> request m
  92     RspApplyWorkspaceEdit       m -> response m
  93     RspFromClient               m -> response m
  94     NotInitialized              m -> notification m
  95     NotExit                     m -> notification m
  96     NotCancelRequestFromClient  m -> notification m
  97     NotDidChangeConfiguration   m -> notification m
  98     NotDidOpenTextDocument      m -> notification m
  99     NotDidChangeTextDocument    m -> notification m
 100     NotDidCloseTextDocument     m -> notification m
 101     NotWillSaveTextDocument     m -> notification m
 102     NotDidSaveTextDocument      m -> notification m
 103     NotDidChangeWatchedFiles    m -> notification m
 104     UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m
 105  where
 106   -- TODO: May need to prevent premature exit notification being sent
 107   notification msg@(NotificationMessage _ Exit _) = do
 108     liftIO $ putStrLn "Will send exit notification soon"
 109     liftIO $ threadDelay 10000000
 110     sendNotification' msg
 111
 112     liftIO $ error "Done"
 113
 114   notification msg@(NotificationMessage _ m _) = do
 115     sendNotification' msg
 116
 117     liftIO $ putStrLn $ "Sent a notification " ++ show m
 118
 119     sendMessages remainingMsgs reqSema rspSema
 120
 121   request msg@(RequestMessage _ id m _) = do
 122     sendRequest' msg
 123     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 124
 125     rsp <- liftIO $ takeMVar rspSema
 126     when (responseId id /= rsp) $
 127       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
 128
 129     sendMessages remainingMsgs reqSema rspSema
 130
 131   response msg@(ResponseMessage _ id _ _) = do
 132     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 133     reqId <- liftIO $ takeMVar reqSema
 134     if responseId reqId /= id
 135       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 136       else do
 137         sendResponse' msg
 138         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 139
 140     sendMessages remainingMsgs reqSema rspSema
 141
 142
 143 isNotification :: FromServerMessage -> Bool
 144 isNotification (NotPublishDiagnostics      _) = True
 145 isNotification (NotLogMessage              _) = True
 146 isNotification (NotShowMessage             _) = True
 147 isNotification (NotCancelRequestFromServer _) = True
 148 isNotification _                              = False
 149
 150 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
 151 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
 152 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
 153   msgBytes <- liftIO $ getNextMessage serverOut
 154   let msg = decodeFromServerMsg reqMap msgBytes
 155
 156   case msg of
 157     ReqRegisterCapability       m -> request m
 158     ReqApplyWorkspaceEdit       m -> request m
 159     ReqShowMessage              m -> request m
 160     ReqUnregisterCapability     m -> request m
 161     RspInitialize               m -> response m
 162     RspShutdown                 m -> response m
 163     RspHover                    m -> response m
 164     RspCompletion               m -> response m
 165     RspCompletionItemResolve    m -> response m
 166     RspSignatureHelp            m -> response m
 167     RspDefinition               m -> response m
 168     RspFindReferences           m -> response m
 169     RspDocumentHighlights       m -> response m
 170     RspDocumentSymbols          m -> response m
 171     RspWorkspaceSymbols         m -> response m
 172     RspCodeAction               m -> response m
 173     RspCodeLens                 m -> response m
 174     RspCodeLensResolve          m -> response m
 175     RspDocumentFormatting       m -> response m
 176     RspDocumentRangeFormatting  m -> response m
 177     RspDocumentOnTypeFormatting m -> response m
 178     RspRename                   m -> response m
 179     RspExecuteCommand           m -> response m
 180     RspError                    m -> response m
 181     RspDocumentLink             m -> response m
 182     RspDocumentLinkResolve      m -> response m
 183     RspWillSaveWaitUntil        m -> response m
 184     NotPublishDiagnostics       m -> notification m
 185     NotLogMessage               m -> notification m
 186     NotShowMessage              m -> notification m
 187     NotTelemetry                m -> notification m
 188     NotCancelRequestFromServer  m -> notification m
 189
 190   if shouldSkip msg
 191     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
 192     else if inRightOrder msg expectedMsgs
 193       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
 194       else liftIO $ do
 195         putStrLn "Out of order"
 196         putStrLn "Got:"
 197         print msg
 198         putStrLn "Expected one of:"
 199         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
 200         print $ head $ dropWhile (not . isNotification) expectedMsgs
 201         putMVar passVar False
 202
 203   where
 204   response :: Show a => ResponseMessage a -> Session ()
 205   response res = do
 206     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 207
 208     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 209
 210   request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
 211   request req = do
 212     liftIO
 213       $  putStrLn
 214       $  "Got request for id "
 215       ++ show (req ^. id)
 216       ++ " "
 217       ++ show (req ^. method)
 218
 219     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 220
 221   notification :: Show a => NotificationMessage ServerMethod a -> Session ()
 222   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
 223
 224
 225
 226 -- TODO: QuickCheck tests?
 227 -- | Checks wether or not the message appears in the right order
 228 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 229 -- given N2, notification order doesn't matter.
 230 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 231 -- given REQ1
 232 -- @ N1 N3 N4 N5 REQ2 RES1 @
 233 -- given RES1
 234 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 235 -- Order of requests and responses matter
 236 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 237
 238 inRightOrder _ [] = error "Why is this empty"
 239
 240 inRightOrder received (expected : msgs)
 241   | received == expected    = True
 242   | isNotification expected = inRightOrder received msgs
 243   | otherwise               = False
 244
 245 -- | Ignore logging notifications since they vary from session to session
 246 shouldSkip :: FromServerMessage -> Bool
 247 shouldSkip (NotLogMessage  _) = True
 248 shouldSkip (NotShowMessage _) = True
 249 shouldSkip (ReqShowMessage _) = True
 250 shouldSkip _                  = False