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   ( replay
   8   )
   9 where
  10
  11 import           Control.Concurrent
  12 import           Control.Monad.Trans.Class
  13 import           Control.Monad.Trans.Reader
  14 import           Data.Default
  15 import qualified Data.ByteString.Lazy.Char8    as B
  16 import           Data.List
  17 import           Language.Haskell.LSP.Capture
  18 import           Language.Haskell.LSP.Messages
  19 import           Language.Haskell.LSP.Core
  20 import qualified Language.Haskell.LSP.Types    as LSP
  21 import           Data.Aeson
  22 import           Data.Maybe
  23 import           Control.Lens
  24 import           Control.Monad
  25 import           System.IO
  26 import           System.Directory
  27 import           System.Process
  28 import           Language.Haskell.LSP.Test.Files
  29 import           Language.Haskell.LSP.Test.Parsing
  30
  31 -- | Replays a recorded client output and
  32 -- makes sure it matches up with an expected response.
  33 replay
  34   :: FilePath -- ^ The recorded session file.
  35   -> FilePath -- ^ The root directory of the project
  36   -> IO Bool
  37 replay sessionFp curRootDir = do
  38
  39   -- need to keep hold of current directory since haskell-lsp changes it
  40   prevDir <- getCurrentDirectory
  41
  42   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  43     (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in  = CreatePipe , std_out = CreatePipe }
  44
  45   hSetBuffering serverIn  NoBuffering
  46   hSetBuffering serverOut NoBuffering
  47
  48   -- whether to send the next request
  49   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  50   -- whether to send the next response
  51   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  52   let semas = (reqSema, rspSema)
  53
  54   didPass      <- newEmptyMVar
  55
  56   entries <- B.lines <$> B.readFile sessionFp
  57
  58   -- decode session
  59   let unswappedEvents = map (fromJust . decode) entries
  60
  61   events <- swapFiles curRootDir unswappedEvents
  62
  63   let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
  64       serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
  65
  66   -- listen to server
  67   forkIO $ runReaderT (listenServer serverEvents serverOut semas) didPass
  68
  69   forM_ clientEvents (processClient serverIn)
  70
  71   print events
  72
  73   result <- takeMVar didPass
  74   terminateProcess serverProc
  75
  76   -- restore directory
  77   setCurrentDirectory prevDir
  78
  79   return result
  80   where
  81     isClientMsg (FromClient _ _) = True
  82     isClientMsg _ = False
  83
  84     isServerMsg (FromServer _ _) = True
  85     isServerMsg _ = False
  86
  87 processEvent :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> Event -> IO ()
  88 processEvent serverH rspSema reqSema (FromClient _ msg) = processClient serverH rspSema reqSema msg
  89 processEvent _ _ _ (FromServer _ msg) = processServer msg
  90
  91 processClient
  92   :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
  93 processClient serverH rspSema reqSema msg = case msg of
  94   ReqInitialize               m -> request m
  95   ReqShutdown                 m -> request m
  96   ReqHover                    m -> request m
  97   ReqCompletion               m -> request m
  98   ReqCompletionItemResolve    m -> request m
  99   ReqSignatureHelp            m -> request m
 100   ReqDefinition               m -> request m
 101   ReqFindReferences           m -> request m
 102   ReqDocumentHighlights       m -> request m
 103   ReqDocumentSymbols          m -> request m
 104   ReqWorkspaceSymbols         m -> request m
 105   ReqCodeAction               m -> request m
 106   ReqCodeLens                 m -> request m
 107   ReqCodeLensResolve          m -> request m
 108   ReqDocumentFormatting       m -> request m
 109   ReqDocumentRangeFormatting  m -> request m
 110   ReqDocumentOnTypeFormatting m -> request m
 111   ReqRename                   m -> request m
 112   ReqExecuteCommand           m -> request m
 113   ReqDocumentLink             m -> request m
 114   ReqDocumentLinkResolve      m -> request m
 115   ReqWillSaveWaitUntil        m -> request m
 116  where
 117   -- TODO: May need to prevent premature exit notification being sent
 118   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 119     putStrLn "Will send exit notification soon"
 120     threadDelay 10000000
 121     B.hPut serverH $ addHeader (encode msg)
 122   notification msg@(LSP.NotificationMessage _ m _) = do
 123     B.hPut serverH $ addHeader (encode msg)
 124
 125     putStrLn $ "Sent a notification " ++ show m
 126
 127   request msg@(LSP.RequestMessage _ id m _) = do
 128
 129     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 130
 131     B.hPut serverH $ addHeader (encode msg)
 132     putStrLn
 133       $  "Sent a request id "
 134       ++ show id
 135       ++ ": "
 136       ++ show m
 137       ++ "\nWaiting for a response"
 138
 139     rspId <- takeMVar reqSema
 140     when (LSP.responseId id /= rspId)
 141       $  error
 142       $  "Expected id "
 143       ++ show id
 144       ++ ", got "
 145       ++ show rspId
 146
 147   response msg@(LSP.ResponseMessage _ id _ _) = do
 148     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 149     reqId <- takeMVar rspSema
 150     if LSP.responseId reqId /= id
 151       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 152       else do
 153         B.hPut serverH $ addHeader (encode msg)
 154         putStrLn $ "Sent response to request id " ++ show id
 155
 156 -- | The internal monad for tests that can fail or pass,
 157 -- ending execution early.
 158 type Session = ReaderT (MVar Bool) IO
 159
 160 -- TODO: Make return type polymoprhic more like error
 161 failSession :: String -> Session ()
 162 failSession reason = do
 163   lift $ putStrLn reason
 164   passVar <- ask
 165   lift $ putMVar passVar False
 166
 167 passSession :: Session ()
 168 passSession = do
 169   passVar <- ask
 170   lift $ putMVar passVar True
 171
 172 -- | Listens to the server output, makes sure it matches the record and
 173 -- signals any semaphores
 174 listenServer :: [FromServerMessage] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
 175 listenServer [] _ _ = passSession
 176 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 177   msg <- lift $ getNextMessage h
 178
 179   newExpectedMsgs <- case decode msg of
 180     Just m -> request m
 181     Nothing -> case decode msg of
 182       Just m -> notification m
 183       Nothing -> case decode msg of
 184         Just m -> response m
 185         Nothing -> failSession "Malformed message" >> return expectedMsgs
 186
 187   listenServer newExpectedMsgs h semas
 188
 189   where response :: LSP.ResponseMessage a -> Session [FromServerMessage]
 190         response res = do
 191           lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 192
 193           lift $ print res
 194
 195           checkOrder res
 196
 197           lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 198
 199           markReceived res
 200
 201         request :: LSP.RequestMessage LSP.ServerMethod a b -> Session [FromServerMessage]
 202         request req = do
 203           lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
 204
 205           lift $ print req
 206
 207           checkOrder req
 208
 209           lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 210
 211           markReceived req
 212
 213         notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage]
 214         notification n = do
 215           lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 216           lift $ print n
 217
 218           lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
 219
 220           if n ^. LSP.method == LSP.WindowLogMessage
 221             then return expectedMsgs
 222             else markReceived n
 223
 224         checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
 225           let (Just expected) = decode firstExpected
 226               _ = expected == msg -- make expected type same as res
 227           failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
 228
 229         markReceived :: Eq a => a -> [FromServerMessage] -> Session [FromServerMessage]
 230         markReceived msg =
 231           -- TODO: Find some way of equating FromServerMessage and LSP.ResponseMessage etc.
 232           let new = delete msg expectedMsgs
 233            in if new == expectedMsgs
 234               then failSession ("Unexpected message: " ++ show msg) >> return new
 235               else return new
 236
 237         firstExpected = head $ filter (not . isNotification) expectedMsgs
 238
 239 isNotification :: FromServerMessage -> Bool
 240 isNotification (NotPublishDiagnostics _) = True
 241 isNotification (NotLogMessage _) = True
 242 isNotification (NotShowMessage _) = True
 243 isNotification (NotCancelRequestFromServer _) = True
 244 isNotification _ = False
 245
 246 -- TODO: QuickCheck tests?
 247 -- | Checks wether or not the message appears in the right order
 248 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 249 -- given N2, notification order doesn't matter.
 250 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 251 -- given REQ1
 252 -- @ N1 N3 N4 N5 REQ2 RES1 @
 253 -- given RES1
 254 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 255 -- Order of requests and responses matter
 256 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
 257
 258 inRightOrder _ [] = error "Why is this empty"
 259 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 260
 261 inRightOrder received (expected:msgs)
 262   | Just received == decode expected = True
 263   | isNotification expected = inRightOrder received msgs
 264   | otherwise =  False