{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
-- | A testing tool for replaying recorded client logs back to a server,
-- and validating that the server output matches up with another log.
module Language.Haskell.LSP.Test.Recorded
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Default
-import Language.Haskell.LSP.Control as Control
import qualified Data.ByteString.Lazy.Char8 as B
+import Data.List
+import Language.Haskell.LSP.Capture
+import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Core
import qualified Language.Haskell.LSP.Types as LSP
import Data.Aeson
-- | Replays a recorded client output and
-- makes sure it matches up with an expected response.
replay
- :: FilePath -- ^ The client output to replay to the server.
- -> FilePath -- ^ The expected response from the server.
+ :: FilePath -- ^ The recorded session file.
-> FilePath -- ^ The root directory of the project
-> IO Bool
-replay cfp sfp curRootDir = do
+replay sessionFp curRootDir = do
-- need to keep hold of current directory since haskell-lsp changes it
prevDir <- getCurrentDirectory
didPass <- newEmptyMVar
- -- the recorded client input to the server
- clientRecIn <- openFile cfp ReadMode
- serverRecIn <- openFile sfp ReadMode
- null <- openFile "/dev/null" WriteMode
+ entries <- B.lines <$> B.readFile sessionFp
+ -- decode session
+ let unswappedEvents = map (fromJust . decode) entries
- unswappedClientMsgs <- getAllMessages clientRecIn
+ events <- swapFiles curRootDir unswappedEvents
- let recRootDir = rootDir unswappedClientMsgs
-
- clientMsgs <- swapFiles recRootDir curRootDir unswappedClientMsgs
-
- print clientMsgs
- error "sdaf"
-
- tmpDir <- getTemporaryDirectory
- (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
- mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
- hSeek mappedClientRecIn AbsoluteSeek 0
-
- expectedMsgs <- swapFiles recRootDir curRootDir =<< getAllMessages serverRecIn
+ let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
+ serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
-- listen to server
- forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
+ forkIO $ runReaderT (listenServer serverEvents serverOut semas) didPass
- -- start client replay
- forkIO $ do
- Control.runWithHandles mappedClientRecIn
- null
- (const $ Right (), const $ return Nothing)
- (handlers serverIn semas)
- def
- Nothing
- Nothing
+ forM_ clientEvents (processClient serverIn)
- -- todo: we shouldn't do this, we should check all notifications were delivered first
- putMVar didPass True
+ print events
result <- takeMVar didPass
terminateProcess serverProc
-- restore directory
setCurrentDirectory prevDir
- -- cleanup temp files
- removeFile mappedClientRecFp
-
return result
+ where
+ isClientMsg (FromClient _ _) = True
+ isClientMsg _ = False
+
+ isServerMsg (FromServer _ _) = True
+ isServerMsg _ = False
+
+processEvent :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> Event -> IO ()
+processEvent serverH rspSema reqSema (FromClient _ msg) = processClient serverH rspSema reqSema msg
+processEvent _ _ _ (FromServer _ msg) = processServer msg
+
+processClient
+ :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
+processClient serverH rspSema reqSema msg = case msg of
+ ReqInitialize m -> request m
+ ReqShutdown m -> request m
+ ReqHover m -> request m
+ ReqCompletion m -> request m
+ ReqCompletionItemResolve m -> request m
+ ReqSignatureHelp m -> request m
+ ReqDefinition m -> request m
+ ReqFindReferences m -> request m
+ ReqDocumentHighlights m -> request m
+ ReqDocumentSymbols m -> request m
+ ReqWorkspaceSymbols m -> request m
+ ReqCodeAction m -> request m
+ ReqCodeLens m -> request m
+ ReqCodeLensResolve m -> request m
+ ReqDocumentFormatting m -> request m
+ ReqDocumentRangeFormatting m -> request m
+ ReqDocumentOnTypeFormatting m -> request m
+ ReqRename m -> request m
+ ReqExecuteCommand m -> request m
+ ReqDocumentLink m -> request m
+ ReqDocumentLinkResolve m -> request m
+ ReqWillSaveWaitUntil m -> request m
+ where
+ -- TODO: May need to prevent premature exit notification being sent
+ notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+ putStrLn "Will send exit notification soon"
+ threadDelay 10000000
+ B.hPut serverH $ addHeader (encode msg)
+ notification msg@(LSP.NotificationMessage _ m _) = do
+ B.hPut serverH $ addHeader (encode msg)
+
+ putStrLn $ "Sent a notification " ++ show m
+
+ request msg@(LSP.RequestMessage _ id m _) = do
+
+ when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
+
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn
+ $ "Sent a request id "
+ ++ show id
+ ++ ": "
+ ++ show m
+ ++ "\nWaiting for a response"
+
+ rspId <- takeMVar reqSema
+ when (LSP.responseId id /= rspId)
+ $ error
+ $ "Expected id "
+ ++ show id
+ ++ ", got "
+ ++ show rspId
+
+ response msg@(LSP.ResponseMessage _ id _ _) = do
+ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
+ reqId <- takeMVar rspSema
+ if LSP.responseId reqId /= id
+ then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
+ else do
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn $ "Sent response to request id " ++ show id
-- | The internal monad for tests that can fail or pass,
-- ending execution early.
type Session = ReaderT (MVar Bool) IO
+-- TODO: Make return type polymoprhic more like error
failSession :: String -> Session ()
failSession reason = do
lift $ putStrLn reason
-- | Listens to the server output, makes sure it matches the record and
-- signals any semaphores
-listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
+listenServer :: [FromServerMessage] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
listenServer [] _ _ = passSession
listenServer expectedMsgs h semas@(reqSema, rspSema) = do
msg <- lift $ getNextMessage h
listenServer newExpectedMsgs h semas
-
- where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
+ where response :: LSP.ResponseMessage a -> Session [FromServerMessage]
response res = do
lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
markReceived res
- request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
+ request :: LSP.RequestMessage LSP.ServerMethod a b -> Session [FromServerMessage]
request req = do
lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
markReceived req
- notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
+ notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage]
notification n = do
lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
lift $ print n
_ = expected == msg -- make expected type same as res
failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
+ markReceived :: Eq a => a -> [FromServerMessage] -> Session [FromServerMessage]
markReceived msg =
- let new = deleteFirstJson msg expectedMsgs
+ -- TODO: Find some way of equating FromServerMessage and LSP.ResponseMessage etc.
+ let new = delete msg expectedMsgs
in if new == expectedMsgs
then failSession ("Unexpected message: " ++ show msg) >> return new
else return new
- deleteFirstJson _ [] = []
- deleteFirstJson msg (x:xs)
- | Just msg == decode x = xs
- | otherwise = x:deleteFirstJson msg xs
-
firstExpected = head $ filter (not . isNotification) expectedMsgs
-
-
-isNotification :: B.ByteString -> Bool
-isNotification msg =
- isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
+isNotification :: FromServerMessage -> Bool
+isNotification (NotPublishDiagnostics _) = True
+isNotification (NotLogMessage _) = True
+isNotification (NotShowMessage _) = True
+isNotification (NotCancelRequestFromServer _) = True
+isNotification _ = False
-- TODO: QuickCheck tests?
-- | Checks wether or not the message appears in the right order
| Just received == decode expected = True
| isNotification expected = inRightOrder received msgs
| otherwise = False
\ No newline at end of file
-
-
-handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
-handlers serverH (reqSema, rspSema) = def
- {
- -- Requests
- hoverHandler = Just request
- , completionHandler = Just request
- , completionResolveHandler = Just request
- , signatureHelpHandler = Just request
- , definitionHandler = Just request
- , referencesHandler = Just request
- , documentHighlightHandler = Just request
- , documentSymbolHandler = Just request
- , workspaceSymbolHandler = Just request
- , codeActionHandler = Just request
- , codeLensHandler = Just request
- , codeLensResolveHandler = Just request
- , documentFormattingHandler = Just request
- , documentRangeFormattingHandler = Just request
- , documentTypeFormattingHandler = Just request
- , renameHandler = Just request
- , documentLinkHandler = Just request
- , documentLinkResolveHandler = Just request
- , executeCommandHandler = Just request
- , initializeRequestHandler = Just request
- -- Notifications
- , didChangeConfigurationParamsHandler = Just notification
- , didOpenTextDocumentNotificationHandler = Just notification
- , didChangeTextDocumentNotificationHandler = Just notification
- , didCloseTextDocumentNotificationHandler = Just notification
- , didSaveTextDocumentNotificationHandler = Just notification
- , didChangeWatchedFilesNotificationHandler = Just notification
- , initializedHandler = Just notification
- , willSaveTextDocumentNotificationHandler = Just notification
- , cancelNotificationHandler = Just notification
- , exitNotificationHandler = Just notification
- -- Responses
- , responseHandler = Just response
- }
- where
-
- -- TODO: May need to prevent premature exit notification being sent
- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
- putStrLn "Will send exit notification soon"
- threadDelay 10000000
- B.hPut serverH $ addHeader (encode msg)
- notification msg@(LSP.NotificationMessage _ m _) = do
- B.hPut serverH $ addHeader (encode msg)
-
- putStrLn $ "Sent a notification " ++ show m
-
- request msg@(LSP.RequestMessage _ id m _) = do
-
- when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
-
- B.hPut serverH $ addHeader (encode msg)
- putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
-
- rspId <- takeMVar reqSema
- when (LSP.responseId id /= rspId)
- $ error
- $ "Expected id "
- ++ show id
- ++ ", got "
- ++ show rspId
-
- response msg@(LSP.ResponseMessage _ id _ _) = do
- putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
- reqId <- takeMVar rspSema
- if LSP.responseId reqId /= id
- then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
- else do
- B.hPut serverH $ addHeader (encode msg)
- putStrLn $ "Sent response to request id " ++ show id
projects / lsp-test.git / blobdiff