import Language.Haskell.LSP.Core
import qualified Language.Haskell.LSP.Types as LSP
import Data.Aeson
-import Data.List
import Data.Maybe
import Control.Lens
import Control.Monad
import System.Directory
import System.Process
import Language.Haskell.LSP.Test.Files
+import Language.Haskell.LSP.Test.Parsing
-- | 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 root directory of the project
-> IO Bool
-replay cfp sfp = do
+replay cfp sfp curRootDir = do
-- need to keep hold of current directory since haskell-lsp changes it
prevDir <- getCurrentDirectory
null <- openFile "/dev/null" WriteMode
- (clientMsgs, fileMap) <- loadSwappedFiles emptyFileMap clientRecIn
+ unswappedClientMsgs <- getAllMessages clientRecIn
+
+ let recRootDir = rootDir unswappedClientMsgs
+
+ (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs
tmpDir <- getTemporaryDirectory
- (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
- mapM_ (B.hPut mappedClientRecIn) $ map addHeader clientMsgs
+ (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
+ mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
hSeek mappedClientRecIn AbsoluteSeek 0
-
- (expectedMsgs, _) <- loadSwappedFiles fileMap serverRecIn
+ (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn
-- listen to server
forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
-- restore directory
setCurrentDirectory prevDir
+ -- cleanup temp files
+ removeFile mappedClientRecFp
+
return result
-- | The internal monad for tests that can fail or pass,
listenServer [] _ _ = passSession
listenServer expectedMsgs h semas@(reqSema, rspSema) = do
msg <- lift $ getNextMessage h
- lift $ putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
- if inRightOrder msg expectedMsgs
- then do
- whenResponse msg $ \res -> lift $ do
- putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
- putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+ newExpectedMsgs <- case decode msg of
+ Just m -> request m
+ Nothing -> case decode msg of
+ Just m -> notification m
+ Nothing -> case decode msg of
+ Just m -> response m
+ Nothing -> failSession "Malformed message" >> return expectedMsgs
- whenRequest msg $ \req -> lift $ do
- putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
- putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+ listenServer newExpectedMsgs h semas
- whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
- unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message"
+ where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
+ response res = do
+ lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
- listenServer (delete msg expectedMsgs) h semas
- else
- let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs))
- in failSession reason
+ lift $ print res
-isNotification :: B.ByteString -> Bool
-isNotification msg =
- isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
+ checkOrder res
+
+ lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+
+ markReceived res
+
+ request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
+ request req = do
+ lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
+
+ lift $ print req
+
+ checkOrder req
+
+ lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+
+ markReceived req
+
+ notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
+ notification n = do
+ lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
+ lift $ print n
-whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> Session ()) -> Session ()
-whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
- Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
- _ -> return ()
+ lift $ putStrLn $ show ((length $ filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
-whenRequest
- :: B.ByteString -> (LSP.RequestMessage Value Value Value -> Session ()) -> Session ()
-whenRequest msg =
- forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
+ if n ^. LSP.method == LSP.WindowLogMessage
+ then return expectedMsgs
+ else markReceived n
-whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session ()
-whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
+ checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
+ let (Just expected) = decode firstExpected
+ _ = expected == msg -- make expected type same as res
+ failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
+
+ markReceived msg =
+ let new = deleteFirstJson 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))
-- TODO: QuickCheck tests?
-- | Checks wether or not the message appears in the right order
-- given RES1
-- @ N1 N3 N4 N5 XXXX RES1 @ False!
-- Order of requests and responses matter
-inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
-inRightOrder _ [] = error "why is this empty"
-inRightOrder received msgs = received `elem` valid
- where
- valid = takeWhile canSkip msgs ++ firstNonSkip
- -- we don't care about the order of notifications
- canSkip = isNotification
- nonSkip = dropWhile canSkip msgs
- firstNonSkip | null nonSkip = []
- | otherwise = [head nonSkip]
-
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
- done <- hIsEOF h
- if done
- then return []
- else do
- msg <- getNextMessage h
+inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
- (msg :) <$> getAllMessages h
+inRightOrder _ [] = error "Why is this empty"
+-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
+
+inRightOrder received (expected:msgs)
+ | Just received == decode expected = True
+ | isNotification expected = inRightOrder received msgs
+ | otherwise = False
--- | Fetches the next message bytes based on
--- the Content-Length header
-getNextMessage :: Handle -> IO B.ByteString
-getNextMessage h = do
- headers <- getHeaders h
- case read . init <$> lookup "Content-Length" headers of
- Nothing -> error "Couldn't read Content-Length header"
- Just size -> B.hGet h size
handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
handlers serverH (reqSema, rspSema) = def
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 _ 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)
else do
B.hPut serverH $ addHeader (encode msg)
putStrLn $ "Sent response to request id " ++ show id
-
-addHeader :: B.ByteString -> B.ByteString
-addHeader content = B.concat
- [ "Content-Length: "
- , B.pack $ show $ B.length content
- , "\r\n"
- , "\r\n"
- , content
- ]
-
-getHeaders :: Handle -> IO [(String, String)]
-getHeaders h = do
- l <- hGetLine h
- let (name, val) = span (/= ':') l
- if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h