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.List
  20 import           Data.Maybe
  21 import           Control.Lens
  22 import           Control.Monad
  23 import           System.IO
  24 import           System.Directory
  25 import           System.Process
  26 import           Language.Haskell.LSP.Test.Files
  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) <- loadSwappedFiles emptyFileMap clientRecIn
  60
  61   tmpDir <- getTemporaryDirectory
  62   (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
  63   mapM_ (B.hPut mappedClientRecIn) $ map addHeader clientMsgs
  64   hSeek mappedClientRecIn AbsoluteSeek 0
  65
  66
  67   (expectedMsgs, _) <- loadSwappedFiles fileMap serverRecIn
  68
  69   -- listen to server
  70   forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
  71
  72   -- start client replay
  73   forkIO $ do
  74     Control.runWithHandles mappedClientRecIn
  75                            null
  76                            (const $ Right (), const $ return Nothing)
  77                            (handlers serverIn semas)
  78                            def
  79                            Nothing
  80                            Nothing
  81
  82     -- todo: we shouldn't do this, we should check all notifications were delivered first
  83     putMVar didPass True
  84
  85   result <- takeMVar didPass
  86   terminateProcess serverProc
  87
  88   -- restore directory
  89   setCurrentDirectory prevDir
  90
  91   return result
  92
  93 -- | The internal monad for tests that can fail or pass,
  94 -- ending execution early.
  95 type Session = ReaderT (MVar Bool) IO
  96
  97 failSession :: String -> Session ()
  98 failSession reason = do
  99   lift $ putStrLn reason
 100   passVar <- ask
 101   lift $ putMVar passVar False
 102
 103 passSession :: Session ()
 104 passSession = do
 105   passVar <- ask
 106   lift $ putMVar passVar True
 107
 108 -- | Listens to the server output, makes sure it matches the record and
 109 -- signals any semaphores
 110 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
 111 listenServer [] _ _ = passSession
 112 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 113   msg <- lift $ getNextMessage h
 114   lift $ putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
 115   if inRightOrder msg expectedMsgs
 116     then do
 117
 118       whenResponse msg $ \res -> lift $ do
 119         putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 120         putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 121
 122       whenRequest msg $ \req -> lift $ do
 123         putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
 124         putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 125
 126       whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 127
 128       unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message"
 129
 130       listenServer (delete msg expectedMsgs) h semas
 131     else
 132       let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs))
 133         in failSession reason
 134
 135 isNotification :: B.ByteString -> Bool
 136 isNotification msg =
 137   isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 138
 139 whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> Session ()) -> Session ()
 140 whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
 141   Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
 142   _         -> return ()
 143
 144 whenRequest
 145   :: B.ByteString -> (LSP.RequestMessage Value Value Value -> Session ()) -> Session ()
 146 whenRequest msg =
 147   forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
 148
 149 whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session ()
 150 whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
 151
 152 -- TODO: QuickCheck tests?
 153 -- | Checks wether or not the message appears in the right order
 154 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 155 -- given N2, notification order doesn't matter.
 156 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 157 -- given REQ1
 158 -- @ N1 N3 N4 N5 REQ2 RES1 @
 159 -- given RES1
 160 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 161 -- Order of requests and responses matter
 162 inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
 163 inRightOrder _        []   = error "why is this empty"
 164 inRightOrder received msgs = received `elem` valid
 165  where
 166   valid   = takeWhile canSkip msgs ++ firstNonSkip
 167   -- we don't care about the order of notifications
 168   canSkip = isNotification
 169   nonSkip = dropWhile canSkip msgs
 170   firstNonSkip | null nonSkip = []
 171                | otherwise    = [head nonSkip]
 172
 173 getAllMessages :: Handle -> IO [B.ByteString]
 174 getAllMessages h = do
 175   done <- hIsEOF h
 176   if done
 177     then return []
 178     else do
 179       msg <- getNextMessage h
 180
 181       (msg :) <$> getAllMessages h
 182
 183 -- | Fetches the next message bytes based on
 184 -- the Content-Length header
 185 getNextMessage :: Handle -> IO B.ByteString
 186 getNextMessage h = do
 187   headers <- getHeaders h
 188   case read . init <$> lookup "Content-Length" headers of
 189     Nothing   -> error "Couldn't read Content-Length header"
 190     Just size -> B.hGet h size
 191
 192 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 193 handlers serverH (reqSema, rspSema) = def
 194   {
 195     -- Requests
 196     hoverHandler                             = Just request
 197   , completionHandler                        = Just request
 198   , completionResolveHandler                 = Just request
 199   , signatureHelpHandler                     = Just request
 200   , definitionHandler                        = Just request
 201   , referencesHandler                        = Just request
 202   , documentHighlightHandler                 = Just request
 203   , documentSymbolHandler                    = Just request
 204   , workspaceSymbolHandler                   = Just request
 205   , codeActionHandler                        = Just request
 206   , codeLensHandler                          = Just request
 207   , codeLensResolveHandler                   = Just request
 208   , documentFormattingHandler                = Just request
 209   , documentRangeFormattingHandler           = Just request
 210   , documentTypeFormattingHandler            = Just request
 211   , renameHandler                            = Just request
 212   , documentLinkHandler                      = Just request
 213   , documentLinkResolveHandler               = Just request
 214   , executeCommandHandler                    = Just request
 215   , initializeRequestHandler                 = Just request
 216     -- Notifications
 217   , didChangeConfigurationParamsHandler      = Just notification
 218   , didOpenTextDocumentNotificationHandler   = Just notification
 219   , didChangeTextDocumentNotificationHandler = Just notification
 220   , didCloseTextDocumentNotificationHandler  = Just notification
 221   , didSaveTextDocumentNotificationHandler   = Just notification
 222   , didChangeWatchedFilesNotificationHandler = Just notification
 223   , initializedHandler                       = Just notification
 224   , willSaveTextDocumentNotificationHandler  = Just notification
 225   , cancelNotificationHandler                = Just notification
 226   , exitNotificationHandler                  = Just notification
 227     -- Responses
 228   , responseHandler                          = Just response
 229   }
 230  where
 231
 232   -- TODO: May need to prevent premature exit notification being sent
 233   -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 234   --   putStrLn "Will send exit notification soon"
 235   --   threadDelay 10000000
 236   --   B.hPut serverH $ addHeader (encode msg)
 237   notification msg@(LSP.NotificationMessage _ m _) = do
 238     B.hPut serverH $ addHeader (encode msg)
 239
 240     putStrLn $ "Sent a notification " ++ show m
 241
 242   request msg@(LSP.RequestMessage _ id m _) = do
 243
 244     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 245
 246     B.hPut serverH $ addHeader (encode msg)
 247     putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 248
 249     rspId <- takeMVar reqSema
 250     when (LSP.responseId id /= rspId)
 251       $  error
 252       $  "Expected id "
 253       ++ show id
 254       ++ ", got "
 255       ++ show rspId
 256
 257   response msg@(LSP.ResponseMessage _ id _ _) = do
 258     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 259     reqId <- takeMVar rspSema
 260     if LSP.responseId reqId /= id
 261       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 262       else do
 263         B.hPut serverH $ addHeader (encode msg)
 264         putStrLn $ "Sent response to request id " ++ show id
 265
 266 addHeader :: B.ByteString -> B.ByteString
 267 addHeader content = B.concat
 268   [ "Content-Length: "
 269   , B.pack $ show $ B.length content
 270   , "\r\n"
 271   , "\r\n"
 272   , content
 273   ]
 274
 275 getHeaders :: Handle -> IO [(String, String)]
 276 getHeaders h = do
 277   l <- hGetLine h
 278   let (name, val) = span (/= ':') l
 279   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h