src/Language/Haskell/LSP/Test/Recorded.hs

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