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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 -- | A testing tool for replaying recorded client logs back to a server,
   4 -- and validating that the server output matches up with another log.
   5 module Language.Haskell.LSP.Test.Recorded
   6   ( replay
   7   )
   8 where
   9
  10 import           Control.Concurrent
  11 import           Control.Monad.Trans.Class
  12 import           Control.Monad.Trans.Reader
  13 import           Data.Default
  14 import           Language.Haskell.LSP.Control  as Control
  15 import qualified Data.ByteString.Lazy.Char8    as B
  16 import           Language.Haskell.LSP.Core
  17 import qualified Language.Haskell.LSP.Types    as LSP
  18 import           Data.Aeson
  19 import           Data.Maybe
  20 import           Control.Lens
  21 import           Control.Monad
  22 import           System.IO
  23 import           System.Directory
  24 import           System.Process
  25 import           Language.Haskell.LSP.Test.Files
  26 import           Language.Haskell.LSP.Test.Parsing
  27
  28 -- | Replays a recorded client output and
  29 -- makes sure it matches up with an expected response.
  30 replay
  31   :: FilePath -- ^ The client output to replay to the server.
  32   -> FilePath -- ^ The expected response from the server.
  33   -> FilePath -- ^ The root directory of the project
  34   -> IO Bool
  35 replay cfp sfp curRootDir = do
  36
  37   -- need to keep hold of current directory since haskell-lsp changes it
  38   prevDir <- getCurrentDirectory
  39
  40   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  41     (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in  = CreatePipe , std_out = CreatePipe }
  42
  43   hSetBuffering serverIn  NoBuffering
  44   hSetBuffering serverOut NoBuffering
  45
  46   -- whether to send the next request
  47   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  48   -- whether to send the next response
  49   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  50   let semas = (reqSema, rspSema)
  51
  52   didPass      <- newEmptyMVar
  53
  54   -- the recorded client input to the server
  55   clientRecIn  <- openFile cfp ReadMode
  56   serverRecIn  <- openFile sfp ReadMode
  57   null         <- openFile "/dev/null" WriteMode
  58
  59
  60   unswappedClientMsgs <- getAllMessages clientRecIn
  61
  62   let recRootDir = rootDir unswappedClientMsgs
  63
  64   (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs
  65
  66   tmpDir <- getTemporaryDirectory
  67   (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
  68   mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
  69   hSeek mappedClientRecIn AbsoluteSeek 0
  70
  71   (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn
  72
  73   -- listen to server
  74   forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
  75
  76   -- start client replay
  77   forkIO $ do
  78     Control.runWithHandles mappedClientRecIn
  79                            null
  80                            (const $ Right (), const $ return Nothing)
  81                            (handlers serverIn semas)
  82                            def
  83                            Nothing
  84                            Nothing
  85
  86     -- todo: we shouldn't do this, we should check all notifications were delivered first
  87     putMVar didPass True
  88
  89   result <- takeMVar didPass
  90   terminateProcess serverProc
  91
  92   -- restore directory
  93   setCurrentDirectory prevDir
  94
  95   -- cleanup temp files
  96   removeFile mappedClientRecFp
  97
  98   return result
  99
 100 -- | The internal monad for tests that can fail or pass,
 101 -- ending execution early.
 102 type Session = ReaderT (MVar Bool) IO
 103
 104 failSession :: String -> Session ()
 105 failSession reason = do
 106   lift $ putStrLn reason
 107   passVar <- ask
 108   lift $ putMVar passVar False
 109
 110 passSession :: Session ()
 111 passSession = do
 112   passVar <- ask
 113   lift $ putMVar passVar True
 114
 115 -- | Listens to the server output, makes sure it matches the record and
 116 -- signals any semaphores
 117 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
 118 listenServer [] _ _ = passSession
 119 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 120   msg <- lift $ getNextMessage h
 121
 122   newExpectedMsgs <- case decode msg of
 123     Just m -> request m
 124     Nothing -> case decode msg of
 125       Just m -> notification m
 126       Nothing -> case decode msg of
 127         Just m -> response m
 128         Nothing -> failSession "Malformed message" >> return expectedMsgs
 129
 130   listenServer newExpectedMsgs h semas
 131
 132
 133   where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
 134         response res = do
 135           lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 136
 137           lift $ print res
 138
 139           checkOrder res
 140
 141           lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 142
 143           markReceived res
 144
 145         request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
 146         request req = do
 147           lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
 148
 149           lift $ print req
 150
 151           checkOrder req
 152
 153           lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 154
 155           markReceived req
 156
 157         notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
 158         notification n = do
 159           lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 160           lift $ print n
 161
 162           lift $ putStrLn $ show ((length $ filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
 163
 164           if n ^. LSP.method == LSP.WindowLogMessage
 165             then return expectedMsgs
 166             else markReceived n
 167
 168         checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
 169           let (Just expected) = decode firstExpected
 170               _ = expected == msg -- make expected type same as res
 171           failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
 172
 173         markReceived msg =
 174           let new = deleteFirstJson msg expectedMsgs
 175            in if new == expectedMsgs
 176               then failSession ("Unexpected message: " ++ show msg) >> return new
 177               else return new
 178
 179         deleteFirstJson _ [] = []
 180         deleteFirstJson msg (x:xs)
 181           | Just msg == decode x = xs
 182           | otherwise = x:deleteFirstJson msg xs
 183
 184         firstExpected = head $ filter (not . isNotification) expectedMsgs
 185
 186
 187
 188 isNotification :: B.ByteString -> Bool
 189 isNotification msg =
 190   isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 191
 192 -- TODO: QuickCheck tests?
 193 -- | Checks wether or not the message appears in the right order
 194 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 195 -- given N2, notification order doesn't matter.
 196 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 197 -- given REQ1
 198 -- @ N1 N3 N4 N5 REQ2 RES1 @
 199 -- given RES1
 200 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 201 -- Order of requests and responses matter
 202 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
 203
 204 inRightOrder _ [] = error "Why is this empty"
 205 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 206
 207 inRightOrder received (expected:msgs)
 208   | Just received == decode expected = True
 209   | isNotification expected = inRightOrder received msgs
 210   | otherwise =  False
 211
 212
 213 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 214 handlers serverH (reqSema, rspSema) = def
 215   {
 216     -- Requests
 217     hoverHandler                             = Just request
 218   , completionHandler                        = Just request
 219   , completionResolveHandler                 = Just request
 220   , signatureHelpHandler                     = Just request
 221   , definitionHandler                        = Just request
 222   , referencesHandler                        = Just request
 223   , documentHighlightHandler                 = Just request
 224   , documentSymbolHandler                    = Just request
 225   , workspaceSymbolHandler                   = Just request
 226   , codeActionHandler                        = Just request
 227   , codeLensHandler                          = Just request
 228   , codeLensResolveHandler                   = Just request
 229   , documentFormattingHandler                = Just request
 230   , documentRangeFormattingHandler           = Just request
 231   , documentTypeFormattingHandler            = Just request
 232   , renameHandler                            = Just request
 233   , documentLinkHandler                      = Just request
 234   , documentLinkResolveHandler               = Just request
 235   , executeCommandHandler                    = Just request
 236   , initializeRequestHandler                 = Just request
 237     -- Notifications
 238   , didChangeConfigurationParamsHandler      = Just notification
 239   , didOpenTextDocumentNotificationHandler   = Just notification
 240   , didChangeTextDocumentNotificationHandler = Just notification
 241   , didCloseTextDocumentNotificationHandler  = Just notification
 242   , didSaveTextDocumentNotificationHandler   = Just notification
 243   , didChangeWatchedFilesNotificationHandler = Just notification
 244   , initializedHandler                       = Just notification
 245   , willSaveTextDocumentNotificationHandler  = Just notification
 246   , cancelNotificationHandler                = Just notification
 247   , exitNotificationHandler                  = Just notification
 248     -- Responses
 249   , responseHandler                          = Just response
 250   }
 251  where
 252
 253   -- TODO: May need to prevent premature exit notification being sent
 254   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 255     putStrLn "Will send exit notification soon"
 256     threadDelay 10000000
 257     B.hPut serverH $ addHeader (encode msg)
 258   notification msg@(LSP.NotificationMessage _ m _) = do
 259     B.hPut serverH $ addHeader (encode msg)
 260
 261     putStrLn $ "Sent a notification " ++ show m
 262
 263   request msg@(LSP.RequestMessage _ id m _) = do
 264
 265     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 266
 267     B.hPut serverH $ addHeader (encode msg)
 268     putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 269
 270     rspId <- takeMVar reqSema
 271     when (LSP.responseId id /= rspId)
 272       $  error
 273       $  "Expected id "
 274       ++ show id
 275       ++ ", got "
 276       ++ show rspId
 277
 278   response msg@(LSP.ResponseMessage _ id _ _) = do
 279     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 280     reqId <- takeMVar rspSema
 281     if LSP.responseId reqId /= id
 282       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 283       else do
 284         B.hPut serverH $ addHeader (encode msg)
 285         putStrLn $ "Sent response to request id " ++ show id