X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;fp=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=746ff0bf7323ca2ce01690d985c569bed481862d;hp=d109d9a74a9140abfec989b20120b5105db3c21e;hb=35925b4a5a5e24e1611431106fd8ddd7c89a4436;hpb=092af98d24a00b540c3370774ebaa33161e98f3b diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index d109d9a..746ff0b 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} module Language.Haskell.LSP.Test.Recorded ( replay ) @@ -17,16 +16,21 @@ import Data.Maybe import Control.Lens import Control.Monad import System.IO +import System.Directory import System.Process -- | 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. +replay + :: FilePath -- ^ The client output to replay to the server. -> FilePath -- ^ The expected response from the server. - -> IO Int + -> IO Bool replay cfp sfp = do - (Just serverIn, Just serverOut, _, _) <- createProcess + -- need to keep hold of current directory since haskell-lsp changes it + prevDir <- getCurrentDirectory + + (Just serverIn, Just serverOut, _, serverProc) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe , std_out = CreatePipe } @@ -41,6 +45,8 @@ replay cfp sfp = do rspSema <- newEmptyMVar :: IO (MVar LSP.LspId) let semas = (reqSema, rspSema) + didPass <- newEmptyMVar + -- the recorded client input to the server clientRecIn <- openFile cfp ReadMode serverRecIn <- openFile sfp ReadMode @@ -50,17 +56,10 @@ replay cfp sfp = do expectedMsgs <- getAllMessages serverRecIn -- listen to server - forkIO $ listenServer expectedMsgs serverOut semas - - -- send initialize request ourselves since haskell-lsp consumes it - -- rest are handled via `handlers` - sendInitialize clientRecIn serverIn - - -- wait for initialize response - putStrLn "Waiting for initialzie response" - takeMVar reqSema - putStrLn "Got initialize response" + forkIO $ listenServer expectedMsgs serverOut semas didPass + -- start client replay + forkIO $ do Control.runWithHandles clientRecIn null (const $ Right (), const $ return Nothing) @@ -68,44 +67,68 @@ replay cfp sfp = do def Nothing Nothing - where - listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO () - listenServer expectedMsgs h semas@(reqSema, rspSema) = do + + -- todo: we shouldn't do this, we should check all notifications were delivered first + putMVar didPass True + + result <- takeMVar didPass + terminateProcess serverProc + + -- restore directory + setCurrentDirectory prevDir + + return result + +-- todo: Maybe make a reader monad and a fail function for it? +listenServer + :: [B.ByteString] + -> Handle + -> (MVar LSP.LspIdRsp, MVar LSP.LspId) + -> MVar Bool + -> IO () +listenServer [] _ _ passVar = putMVar passVar True +listenServer expectedMsgs h semas@(reqSema, rspSema) passVar = do msg <- getNextMessage h putStrLn $ "Remaining messages " ++ show (length expectedMsgs) if inRightOrder msg expectedMsgs then do - -- if we got a request response unblock the replay waiting for a response whenResponse msg $ \res -> do - putStrLn ("Got response for id " ++ show (res ^. LSP.id)) - putMVar reqSema (res ^. LSP.id) + putStrLn $ "Got response for id " ++ show (res ^. LSP.id) + putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request whenRequest msg $ \req -> do - putStrLn ("Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)) - putMVar rspSema (req ^. LSP.id) + 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 + + whenNotification msg $ \n -> putStrLn $ "Got notification " ++ (show (n ^. LSP.method)) - listenServer (delete msg expectedMsgs) h semas - else error $ "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs)) + when (not (msg `elem` expectedMsgs)) $ do + putStrLn "Got an unexpected message" + putMVar passVar False - sendInitialize recH serverH = do - message <- getNextMessage recH - B.hPut serverH (addHeader message) - putStrLn $ "Sent initialize response " ++ show message - -- bring the file back to the start for haskell-lsp - hSeek recH AbsoluteSeek 0 + listenServer (delete msg expectedMsgs) h semas passVar + else do + putStrLn $ "Got: " ++ show msg ++ "\n Expected: " ++ show + (head (filter (not . isNotification) expectedMsgs)) + putMVar passVar False isNotification :: B.ByteString -> Bool -isNotification msg = isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) +isNotification msg = + isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO () -whenResponse msg f = - case decode msg :: Maybe (LSP.ResponseMessage Value) of +whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg') _ -> return () -whenRequest :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO () -whenRequest msg = forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value))) +whenRequest + :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO () +whenRequest msg = + forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value))) + +whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> IO ()) -> IO () +whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value))) -- TODO: QuickCheck tests? -- | Checks wether or not the message appears in the right order @@ -120,12 +143,12 @@ whenRequest msg = forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Va inRightOrder :: B.ByteString -> [B.ByteString] -> Bool inRightOrder _ [] = error "why is this empty" inRightOrder received msgs = received `elem` valid - where valid = takeWhile canSkip msgs ++ firstNonSkip + where + valid = takeWhile canSkip msgs ++ firstNonSkip -- we don't care about the order of notifications canSkip = isNotification nonSkip = dropWhile canSkip msgs - firstNonSkip - | null nonSkip = [] + firstNonSkip | null nonSkip = [] | otherwise = [head nonSkip] getAllMessages :: Handle -> IO [B.ByteString] @@ -170,6 +193,7 @@ handlers serverH (reqSema, rspSema) = def , documentLinkHandler = Just request , documentLinkResolveHandler = Just request , executeCommandHandler = Just request + , initializeRequestHandler = Just request -- Notifications , didChangeConfigurationParamsHandler = Just notification , didOpenTextDocumentNotificationHandler = Just notification @@ -180,23 +204,32 @@ handlers serverH (reqSema, rspSema) = def , initializedHandler = Just notification , willSaveTextDocumentNotificationHandler = Just notification , cancelNotificationHandler = Just notification + , exitNotificationHandler = Just notification -- Responses , responseHandler = Just response } where - notification m = do - B.hPut serverH $ addHeader (encode m) - putStrLn "Sent a notification" + -- 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) - request msg@(LSP.RequestMessage _ id m _) = do + putStrLn $ "Sent a notification " ++ show m + request msg@(LSP.RequestMessage _ id m _) = do B.hPut serverH $ addHeader (encode msg) putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" rspId <- takeMVar reqSema - if LSP.responseId id /= rspId - then error $ "Expected id " ++ show id ++ ", got " ++ show rspId - else putStrLn $ "Got a response for request id " ++ show id ++ ": " ++ show m + 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"