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