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   cleanupFiles
  98
  99   return result
 100
 101 -- | The internal monad for tests that can fail or pass,
 102 -- ending execution early.
 103 type Session = ReaderT (MVar Bool) IO
 104
 105 failSession :: String -> Session ()
 106 failSession reason = do
 107   lift $ putStrLn reason
 108   passVar <- ask
 109   lift $ putMVar passVar False
 110
 111 passSession :: Session ()
 112 passSession = do
 113   passVar <- ask
 114   lift $ putMVar passVar True
 115
 116 -- | Listens to the server output, makes sure it matches the record and
 117 -- signals any semaphores
 118 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
 119 listenServer [] _ _ = passSession
 120 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 121   msg <- lift $ getNextMessage h
 122
 123   newExpectedMsgs <- case decode msg of
 124     Just m -> request m
 125     Nothing -> case decode msg of
 126       Just m -> notification m
 127       Nothing -> case decode msg of
 128         Just m -> response m
 129         Nothing -> failSession "Malformed message" >> return expectedMsgs
 130
 131   listenServer newExpectedMsgs h semas
 132
 133
 134   where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
 135         response res = do
 136           lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 137
 138           lift $ print res
 139
 140           checkOrder res
 141
 142           lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 143
 144           markReceived res
 145
 146         request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
 147         request req = do
 148           lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
 149
 150           lift $ print req
 151
 152           checkOrder req
 153
 154           lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 155
 156           markReceived req
 157
 158         notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
 159         notification n = do
 160           lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 161           lift $ print n
 162
 163           lift $ putStrLn $ (show ((length $ filter isNotification expectedMsgs) - 1)) ++ " notifications remaining"
 164
 165           if n ^. LSP.method == LSP.WindowLogMessage
 166             then return expectedMsgs
 167             else markReceived n
 168
 169         checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
 170           let (Just expected) = decode firstExpected
 171               _ = expected == msg -- make expected type same as res
 172           failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
 173
 174         markReceived msg = do
 175           let new = deleteFirstJson msg expectedMsgs
 176            in if (new == expectedMsgs)
 177               then failSession ("Unexpected message: " ++ show msg) >> return new
 178               else return new
 179
 180         deleteFirstJson _ [] = []
 181         deleteFirstJson msg (x:xs)
 182           | (Just msg) == (decode x) = xs
 183           | otherwise = x:deleteFirstJson msg xs
 184
 185         firstExpected = head $ filter (not . isNotification) expectedMsgs
 186
 187
 188
 189 isNotification :: B.ByteString -> Bool
 190 isNotification msg =
 191   isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 192
 193 -- TODO: QuickCheck tests?
 194 -- | Checks wether or not the message appears in the right order
 195 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 196 -- given N2, notification order doesn't matter.
 197 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 198 -- given REQ1
 199 -- @ N1 N3 N4 N5 REQ2 RES1 @
 200 -- given RES1
 201 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 202 -- Order of requests and responses matter
 203 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
 204
 205 inRightOrder _ [] = error "Why is this empty"
 206 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 207
 208 inRightOrder received (expected:msgs)
 209   | Just received == decode expected = True
 210   | isNotification expected = inRightOrder received msgs
 211   | otherwise =  False
 212
 213
 214 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 215 handlers serverH (reqSema, rspSema) = def
 216   {
 217     -- Requests
 218     hoverHandler                             = Just request
 219   , completionHandler                        = Just request
 220   , completionResolveHandler                 = Just request
 221   , signatureHelpHandler                     = Just request
 222   , definitionHandler                        = Just request
 223   , referencesHandler                        = Just request
 224   , documentHighlightHandler                 = Just request
 225   , documentSymbolHandler                    = Just request
 226   , workspaceSymbolHandler                   = Just request
 227   , codeActionHandler                        = Just request
 228   , codeLensHandler                          = Just request
 229   , codeLensResolveHandler                   = Just request
 230   , documentFormattingHandler                = Just request
 231   , documentRangeFormattingHandler           = Just request
 232   , documentTypeFormattingHandler            = Just request
 233   , renameHandler                            = Just request
 234   , documentLinkHandler                      = Just request
 235   , documentLinkResolveHandler               = Just request
 236   , executeCommandHandler                    = Just request
 237   , initializeRequestHandler                 = Just request
 238     -- Notifications
 239   , didChangeConfigurationParamsHandler      = Just notification
 240   , didOpenTextDocumentNotificationHandler   = Just notification
 241   , didChangeTextDocumentNotificationHandler = Just notification
 242   , didCloseTextDocumentNotificationHandler  = Just notification
 243   , didSaveTextDocumentNotificationHandler   = Just notification
 244   , didChangeWatchedFilesNotificationHandler = Just notification
 245   , initializedHandler                       = Just notification
 246   , willSaveTextDocumentNotificationHandler  = Just notification
 247   , cancelNotificationHandler                = Just notification
 248   , exitNotificationHandler                  = Just notification
 249     -- Responses
 250   , responseHandler                          = Just response
 251   }
 252  where
 253
 254   -- TODO: May need to prevent premature exit notification being sent
 255   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 256     putStrLn "Will send exit notification soon"
 257     threadDelay 10000000
 258     B.hPut serverH $ addHeader (encode msg)
 259   notification msg@(LSP.NotificationMessage _ m _) = do
 260     B.hPut serverH $ addHeader (encode msg)
 261
 262     putStrLn $ "Sent a notification " ++ show m
 263
 264   request msg@(LSP.RequestMessage _ id m _) = do
 265
 266     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 267
 268     B.hPut serverH $ addHeader (encode msg)
 269     putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 270
 271     rspId <- takeMVar reqSema
 272     when (LSP.responseId id /= rspId)
 273       $  error
 274       $  "Expected id "
 275       ++ show id
 276       ++ ", got "
 277       ++ show rspId
 278
 279   response msg@(LSP.ResponseMessage _ id _ _) = do
 280     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 281     reqId <- takeMVar rspSema
 282     if LSP.responseId reqId /= id
 283       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 284       else do
 285         B.hPut serverH $ addHeader (encode msg)
 286         putStrLn $ "Sent response to request id " ++ show id