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 = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
  44       serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
  45       requestMap = getRequestMap clientEvents
  46
  47
  48   reqSema <- newEmptyMVar
  49   rspSema <- newEmptyMVar
  50   passVar <- newEmptyMVar :: IO (MVar Bool)
  51
  52   forkIO $ runSessionWithHandler (listenServer serverEvents requestMap reqSema rspSema passVar) sessionDir $
  53     sendMessages clientEvents reqSema rspSema
  54
  55   takeMVar passVar
  56
  57   where
  58     isClientMsg (FromClient _ _) = True
  59     isClientMsg _                = False
  60
  61     isServerMsg (FromServer _ _) = True
  62     isServerMsg _                = False
  63
  64 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
  65 sendMessages [] _ _ = return ()
  66 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
  67   case nextMsg of
  68     ReqInitialize               m -> request m
  69     ReqShutdown                 m -> request m
  70     ReqHover                    m -> request m
  71     ReqCompletion               m -> request m
  72     ReqCompletionItemResolve    m -> request m
  73     ReqSignatureHelp            m -> request m
  74     ReqDefinition               m -> request m
  75     ReqFindReferences           m -> request m
  76     ReqDocumentHighlights       m -> request m
  77     ReqDocumentSymbols          m -> request m
  78     ReqWorkspaceSymbols         m -> request m
  79     ReqCodeAction               m -> request m
  80     ReqCodeLens                 m -> request m
  81     ReqCodeLensResolve          m -> request m
  82     ReqDocumentFormatting       m -> request m
  83     ReqDocumentRangeFormatting  m -> request m
  84     ReqDocumentOnTypeFormatting m -> request m
  85     ReqRename                   m -> request m
  86     ReqExecuteCommand           m -> request m
  87     ReqDocumentLink             m -> request m
  88     ReqDocumentLinkResolve      m -> request m
  89     ReqWillSaveWaitUntil        m -> request m
  90     RspApplyWorkspaceEdit       m -> response m
  91     RspFromClient               m -> response m
  92     NotInitialized              m -> notification m
  93     NotExit                     m -> notification m
  94     NotCancelRequestFromClient  m -> notification m
  95     NotDidChangeConfiguration   m -> notification m
  96     NotDidOpenTextDocument      m -> notification m
  97     NotDidChangeTextDocument    m -> notification m
  98     NotDidCloseTextDocument     m -> notification m
  99     NotWillSaveTextDocument     m -> notification m
 100     NotDidSaveTextDocument      m -> notification m
 101     NotDidChangeWatchedFiles    m -> notification m
 102     UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m
 103  where
 104   -- TODO: May need to prevent premature exit notification being sent
 105   notification msg@(NotificationMessage _ Exit _) = do
 106     liftIO $ putStrLn "Will send exit notification soon"
 107     liftIO $ threadDelay 10000000
 108     sendNotification' msg
 109
 110     liftIO $ error "Done"
 111
 112   notification msg@(NotificationMessage _ m _) = do
 113     sendNotification' msg
 114
 115     liftIO $ putStrLn $ "Sent a notification " ++ show m
 116
 117     sendMessages remainingMsgs reqSema rspSema
 118
 119   request msg@(RequestMessage _ id m _) = do
 120     liftIO $ print $ addHeader $ encode msg
 121
 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 inRightOrder msg expectedMsgs
 191     then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
 192     else liftIO $ do
 193       putStrLn "Out of order"
 194       putStrLn "Got:"
 195       print msg
 196       putStrLn "Expected one of:"
 197       mapM_ print $ takeWhile (not . isNotification) expectedMsgs
 198       print $ head $ dropWhile (not . isNotification) expectedMsgs
 199       putMVar passVar False
 200
 201   where
 202   response :: Show a => ResponseMessage a -> Session ()
 203   response res = do
 204     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 205
 206     liftIO $ print res
 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 $ print req
 220
 221     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 222
 223   notification :: Show a => NotificationMessage ServerMethod a -> Session ()
 224   notification n = do
 225     liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
 226     liftIO $ print n
 227
 228     liftIO
 229       $  putStrLn
 230       $  show (length (filter isNotification expectedMsgs) - 1)
 231       ++ " notifications remaining"
 232
 233
 234
 235 -- TODO: QuickCheck tests?
 236 -- | Checks wether or not the message appears in the right order
 237 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 238 -- given N2, notification order doesn't matter.
 239 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 240 -- given REQ1
 241 -- @ N1 N3 N4 N5 REQ2 RES1 @
 242 -- given RES1
 243 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 244 -- Order of requests and responses matter
 245 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 246
 247 inRightOrder _ [] = error "Why is this empty"
 248 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 249
 250 inRightOrder received (expected : msgs)
 251   | received == expected    = True
 252   | isNotification expected = inRightOrder received msgs
 253   | otherwise               = False