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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 module Language.Haskell.LSP.Test.Recorded
   4   ( replay
   5   )
   6 where
   7
   8 import           Control.Concurrent
   9 import           Data.Default
  10 import           Language.Haskell.LSP.Control  as Control
  11 import qualified Data.ByteString.Lazy.Char8    as B
  12 import           Language.Haskell.LSP.Core
  13 import qualified Language.Haskell.LSP.Types    as LSP
  14 import           Data.Aeson
  15 import           Data.List
  16 import           Data.Maybe
  17 import           Control.Lens
  18 import           Control.Monad
  19 import           System.IO
  20 import           System.Process
  21
  22 -- | Replays a recorded client output and
  23 -- makes sure it matches up with an expected response.
  24 replay :: FilePath -- ^ The client output to replay to the server.
  25        -> FilePath -- ^ The expected response from the server.
  26        -> IO Int
  27 replay cfp sfp = do
  28
  29   (Just serverIn, Just serverOut, _, _) <- createProcess
  30     (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in  = CreatePipe
  31                                                        , std_out = CreatePipe
  32                                                        }
  33
  34   hSetBuffering serverIn  NoBuffering
  35   hSetBuffering serverOut NoBuffering
  36
  37   -- todo: use qsem
  38   -- whether to send the next request
  39   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  40   -- whether to send the next response
  41   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  42   let semas = (reqSema, rspSema)
  43
  44   -- the recorded client input to the server
  45   clientRecIn <- openFile cfp ReadMode
  46   serverRecIn <- openFile sfp ReadMode
  47   null        <- openFile "/dev/null" WriteMode
  48
  49
  50   expectedMsgs <- getAllMessages serverRecIn
  51
  52   -- listen to server
  53   forkIO $ listenServer expectedMsgs serverOut semas
  54
  55   -- send initialize request ourselves since haskell-lsp consumes it
  56   -- rest are handled via `handlers`
  57   sendInitialize clientRecIn serverIn
  58
  59   -- wait for initialize response
  60   putStrLn "Waiting for initialzie response"
  61   takeMVar reqSema
  62   putStrLn "Got initialize response"
  63
  64   Control.runWithHandles clientRecIn
  65                          null
  66                          (const $ Right (), const $ return Nothing)
  67                          (handlers serverIn semas)
  68                          def
  69                          Nothing
  70                          Nothing
  71  where
  72   listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO ()
  73   listenServer expectedMsgs h semas@(reqSema, rspSema) = do
  74     msg <- getNextMessage h
  75     putStrLn $ "Remaining messages "  ++ show (length expectedMsgs)
  76     if inRightOrder msg expectedMsgs
  77       then do
  78
  79         -- if we got a request response unblock the replay waiting for a response
  80         whenResponse msg $ \res -> do
  81           putStrLn ("Got response for id " ++ show (res ^. LSP.id))
  82           putMVar reqSema (res ^. LSP.id)
  83
  84         whenRequest msg $ \req -> do
  85           putStrLn ("Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method))
  86           putMVar rspSema (req ^. LSP.id)
  87
  88         listenServer (delete msg expectedMsgs) h semas
  89       else error $ "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs))
  90
  91   sendInitialize recH serverH = do
  92     message <- getNextMessage recH
  93     B.hPut serverH (addHeader message)
  94     putStrLn $ "Sent initialize response " ++ show message
  95     -- bring the file back to the start for haskell-lsp
  96     hSeek recH AbsoluteSeek 0
  97
  98 isNotification :: B.ByteString -> Bool
  99 isNotification msg = isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 100
 101 whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO ()
 102 whenResponse msg f =
 103   case decode msg :: Maybe (LSP.ResponseMessage Value) of
 104     Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
 105     _ -> return ()
 106
 107 whenRequest :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO ()
 108 whenRequest msg = forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
 109
 110 -- TODO: QuickCheck tests?
 111 -- | Checks wether or not the message appears in the right order
 112 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 113 -- given N2, notification order doesn't matter.
 114 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 115 -- given REQ1
 116 -- @ N1 N3 N4 N5 REQ2 RES1 @
 117 -- given RES1
 118 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 119 -- Order of requests and responses matter
 120 inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
 121 inRightOrder _ [] = error "why is this empty"
 122 inRightOrder received msgs = received `elem` valid
 123   where valid = takeWhile canSkip msgs ++ firstNonSkip
 124         -- we don't care about the order of notifications
 125         canSkip = isNotification
 126         nonSkip = dropWhile canSkip msgs
 127         firstNonSkip
 128           | null nonSkip = []
 129           | otherwise  = [head nonSkip]
 130
 131 getAllMessages :: Handle -> IO [B.ByteString]
 132 getAllMessages h = do
 133   done <- hIsEOF h
 134   if done
 135     then return []
 136     else do
 137       msg <- getNextMessage h
 138       (msg:) <$> getAllMessages h
 139
 140 -- | Fetches the next message bytes based on
 141 -- the Content-Length header
 142 getNextMessage :: Handle -> IO B.ByteString
 143 getNextMessage h = do
 144   headers <- getHeaders h
 145   case read . init <$> lookup "Content-Length" headers of
 146     Nothing   -> error "Couldn't read Content-Length header"
 147     Just size -> B.hGet h size
 148
 149
 150 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 151 handlers serverH (reqSema, rspSema) = def
 152   {
 153     -- Requests
 154     hoverHandler                             = Just request
 155   , completionHandler                        = Just request
 156   , completionResolveHandler                 = Just request
 157   , signatureHelpHandler                     = Just request
 158   , definitionHandler                        = Just request
 159   , referencesHandler                        = Just request
 160   , documentHighlightHandler                 = Just request
 161   , documentSymbolHandler                    = Just request
 162   , workspaceSymbolHandler                   = Just request
 163   , codeActionHandler                        = Just request
 164   , codeLensHandler                          = Just request
 165   , codeLensResolveHandler                   = Just request
 166   , documentFormattingHandler                = Just request
 167   , documentRangeFormattingHandler           = Just request
 168   , documentTypeFormattingHandler            = Just request
 169   , renameHandler                            = Just request
 170   , documentLinkHandler                      = Just request
 171   , documentLinkResolveHandler               = Just request
 172   , executeCommandHandler                    = Just request
 173     -- Notifications
 174   , didChangeConfigurationParamsHandler      = Just notification
 175   , didOpenTextDocumentNotificationHandler   = Just notification
 176   , didChangeTextDocumentNotificationHandler = Just notification
 177   , didCloseTextDocumentNotificationHandler  = Just notification
 178   , didSaveTextDocumentNotificationHandler   = Just notification
 179   , didChangeWatchedFilesNotificationHandler = Just notification
 180   , initializedHandler                       = Just notification
 181   , willSaveTextDocumentNotificationHandler  = Just notification
 182   , cancelNotificationHandler                = Just notification
 183     -- Responses
 184   , responseHandler                          = Just response
 185   }
 186  where
 187   notification m = do
 188     B.hPut serverH $ addHeader (encode m)
 189     putStrLn "Sent a notification"
 190
 191   request msg@(LSP.RequestMessage _ id m _) = do
 192
 193     B.hPut serverH $ addHeader (encode msg)
 194     putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 195
 196     rspId <- takeMVar reqSema
 197     if LSP.responseId id /= rspId
 198       then error $ "Expected id " ++ show id ++ ", got " ++ show rspId
 199       else putStrLn $ "Got a response for request id " ++ show id ++ ": " ++ show m
 200
 201   response msg@(LSP.ResponseMessage _ id _ _) = do
 202     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 203     reqId <- takeMVar rspSema
 204     if LSP.responseId reqId /= id
 205       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 206       else do
 207         B.hPut serverH $ addHeader (encode msg)
 208         putStrLn $ "Sent response to request id " ++ show id
 209
 210 addHeader :: B.ByteString -> B.ByteString
 211 addHeader content = B.concat
 212   [ "Content-Length: "
 213   , B.pack $ show $ B.length content
 214   , "\r\n"
 215   , "\r\n"
 216   , content
 217   ]
 218
 219 getHeaders :: Handle -> IO [(String, String)]
 220 getHeaders h = do
 221   l <- hGetLine h
 222   let (name, val) = span (/= ':') l
 223   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h