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 <- swapFiles recRootDir curRootDir unswappedClientMsgs
  65
  66   print clientMsgs
  67   error "sdaf"
  68
  69   tmpDir <- getTemporaryDirectory
  70   (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
  71   mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
  72   hSeek mappedClientRecIn AbsoluteSeek 0
  73
  74   expectedMsgs <- swapFiles recRootDir curRootDir =<< getAllMessages serverRecIn
  75
  76   -- listen to server
  77   forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
  78
  79   -- start client replay
  80   forkIO $ do
  81     Control.runWithHandles mappedClientRecIn
  82                            null
  83                            (const $ Right (), const $ return Nothing)
  84                            (handlers serverIn semas)
  85                            def
  86                            Nothing
  87                            Nothing
  88
  89     -- todo: we shouldn't do this, we should check all notifications were delivered first
  90     putMVar didPass True
  91
  92   result <- takeMVar didPass
  93   terminateProcess serverProc
  94
  95   -- restore directory
  96   setCurrentDirectory prevDir
  97
  98   -- cleanup temp files
  99   removeFile mappedClientRecFp
 100
 101   return result
 102
 103 -- | The internal monad for tests that can fail or pass,
 104 -- ending execution early.
 105 type Session = ReaderT (MVar Bool) IO
 106
 107 failSession :: String -> Session ()
 108 failSession reason = do
 109   lift $ putStrLn reason
 110   passVar <- ask
 111   lift $ putMVar passVar False
 112
 113 passSession :: Session ()
 114 passSession = do
 115   passVar <- ask
 116   lift $ putMVar passVar True
 117
 118 -- | Listens to the server output, makes sure it matches the record and
 119 -- signals any semaphores
 120 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
 121 listenServer [] _ _ = passSession
 122 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 123   msg <- lift $ getNextMessage h
 124
 125   newExpectedMsgs <- case decode msg of
 126     Just m -> request m
 127     Nothing -> case decode msg of
 128       Just m -> notification m
 129       Nothing -> case decode msg of
 130         Just m -> response m
 131         Nothing -> failSession "Malformed message" >> return expectedMsgs
 132
 133   listenServer newExpectedMsgs h semas
 134
 135
 136   where 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           markReceived res
 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           markReceived req
 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
 165           lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
 166
 167           if n ^. LSP.method == LSP.WindowLogMessage
 168             then return expectedMsgs
 169             else markReceived n
 170
 171         checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
 172           let (Just expected) = decode firstExpected
 173               _ = expected == msg -- make expected type same as res
 174           failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
 175
 176         markReceived msg =
 177           let new = deleteFirstJson msg expectedMsgs
 178            in if new == expectedMsgs
 179               then failSession ("Unexpected message: " ++ show msg) >> return new
 180               else return new
 181
 182         deleteFirstJson _ [] = []
 183         deleteFirstJson msg (x:xs)
 184           | Just msg == decode x = xs
 185           | otherwise = x:deleteFirstJson msg xs
 186
 187         firstExpected = head $ filter (not . isNotification) expectedMsgs
 188
 189
 190
 191 isNotification :: B.ByteString -> Bool
 192 isNotification msg =
 193   isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 194
 195 -- TODO: QuickCheck tests?
 196 -- | Checks wether or not the message appears in the right order
 197 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 198 -- given N2, notification order doesn't matter.
 199 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 200 -- given REQ1
 201 -- @ N1 N3 N4 N5 REQ2 RES1 @
 202 -- given RES1
 203 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 204 -- Order of requests and responses matter
 205 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
 206
 207 inRightOrder _ [] = error "Why is this empty"
 208 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 209
 210 inRightOrder received (expected:msgs)
 211   | Just received == decode expected = True
 212   | isNotification expected = inRightOrder received msgs
 213   | otherwise =  False
 214
 215
 216 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 217 handlers serverH (reqSema, rspSema) = def
 218   {
 219     -- Requests
 220     hoverHandler                             = Just request
 221   , completionHandler                        = Just request
 222   , completionResolveHandler                 = Just request
 223   , signatureHelpHandler                     = Just request
 224   , definitionHandler                        = Just request
 225   , referencesHandler                        = Just request
 226   , documentHighlightHandler                 = Just request
 227   , documentSymbolHandler                    = Just request
 228   , workspaceSymbolHandler                   = Just request
 229   , codeActionHandler                        = Just request
 230   , codeLensHandler                          = Just request
 231   , codeLensResolveHandler                   = Just request
 232   , documentFormattingHandler                = Just request
 233   , documentRangeFormattingHandler           = Just request
 234   , documentTypeFormattingHandler            = Just request
 235   , renameHandler                            = Just request
 236   , documentLinkHandler                      = Just request
 237   , documentLinkResolveHandler               = Just request
 238   , executeCommandHandler                    = Just request
 239   , initializeRequestHandler                 = Just request
 240     -- Notifications
 241   , didChangeConfigurationParamsHandler      = Just notification
 242   , didOpenTextDocumentNotificationHandler   = Just notification
 243   , didChangeTextDocumentNotificationHandler = Just notification
 244   , didCloseTextDocumentNotificationHandler  = Just notification
 245   , didSaveTextDocumentNotificationHandler   = Just notification
 246   , didChangeWatchedFilesNotificationHandler = Just notification
 247   , initializedHandler                       = Just notification
 248   , willSaveTextDocumentNotificationHandler  = Just notification
 249   , cancelNotificationHandler                = Just notification
 250   , exitNotificationHandler                  = Just notification
 251     -- Responses
 252   , responseHandler                          = Just response
 253   }
 254  where
 255
 256   -- TODO: May need to prevent premature exit notification being sent
 257   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 258     putStrLn "Will send exit notification soon"
 259     threadDelay 10000000
 260     B.hPut serverH $ addHeader (encode msg)
 261   notification msg@(LSP.NotificationMessage _ m _) = do
 262     B.hPut serverH $ addHeader (encode msg)
 263
 264     putStrLn $ "Sent a notification " ++ show m
 265
 266   request msg@(LSP.RequestMessage _ id m _) = do
 267
 268     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 269
 270     B.hPut serverH $ addHeader (encode msg)
 271     putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 272
 273     rspId <- takeMVar reqSema
 274     when (LSP.responseId id /= rspId)
 275       $  error
 276       $  "Expected id "
 277       ++ show id
 278       ++ ", got "
 279       ++ show rspId
 280
 281   response msg@(LSP.ResponseMessage _ id _ _) = do
 282     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 283     reqId <- takeMVar rspSema
 284     if LSP.responseId reqId /= id
 285       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 286       else do
 287         B.hPut serverH $ addHeader (encode msg)
 288         putStrLn $ "Sent response to request id " ++ show id