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