X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=ac55e9e749008c575f8a5c50dafbbec70b15040d;hp=88bc09228fd3a76e643fcc01ab62e692d0ac3f1d;hb=f0a961503e19c2d281c3d6319df1096f5bf6cfcf;hpb=22df37c703e39fa5ebeb130be5785b3a9713c520 diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 88bc092..ac55e9e 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -12,21 +12,23 @@ import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Text as T import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types as LSP hiding (error) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens as LSP hiding (error) import Data.Aeson import Data.Default import Data.List import Data.Maybe import Control.Lens hiding (List) import Control.Monad -import System.IO import System.FilePath +import System.IO import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Server - +import Language.Haskell.LSP.Test.Session -- | Replays a captured client output and -- makes sure it matches up with an expected response. @@ -42,8 +44,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - withServer serverExe $ \serverIn serverOut pid -> do + withServer serverExe False $ \serverIn serverOut serverProc -> do + pid <- getProcessID serverProc events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events @@ -58,11 +61,12 @@ replaySession serverExe sessionDir = do mainThread <- myThreadId sessionThread <- liftIO $ forkIO $ - runSessionWithHandles serverIn - serverOut + runSessionWithHandles serverIn serverOut serverProc (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) def + fullCaps sessionDir + (return ()) -- No finalizer cleanup (sendMessages clientMsgs reqSema rspSema) takeMVar passSema killThread sessionThread @@ -83,19 +87,19 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = notification msg@(NotificationMessage _ Exit _) = do liftIO $ putStrLn "Will send exit notification soon" liftIO $ threadDelay 10000000 - sendNotification' msg + sendMessage msg liftIO $ error "Done" notification msg@(NotificationMessage _ m _) = do - sendNotification' msg + sendMessage msg liftIO $ putStrLn $ "Sent a notification " ++ show m sendMessages remainingMsgs reqSema rspSema request msg@(RequestMessage _ id m _) = do - sendRequest' msg + sendRequestMessage msg liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" rsp <- liftIO $ takeMVar rspSema @@ -115,6 +119,15 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = sendMessages remainingMsgs reqSema rspSema +sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () +sendRequestMessage req = do + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method) + + sendMessage req + isNotification :: FromServerMessage -> Bool isNotification (NotPublishDiagnostics _) = True @@ -123,44 +136,51 @@ isNotification (NotShowMessage _) = True isNotification (NotCancelRequestFromServer _) = True isNotification _ = False -listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar () -> ThreadId -> Handle -> Session () -listenServer [] _ _ _ passSema _ _ = liftIO $ putMVar passSema () -listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut = do +listenServer :: [FromServerMessage] + -> RequestMap + -> MVar LspId + -> MVar LspIdRsp + -> MVar () + -> ThreadId + -> Handle + -> SessionContext + -> IO () +listenServer [] _ _ _ passSema _ _ _ = putMVar passSema () +listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do - msgBytes <- liftIO $ getNextMessage serverOut + msgBytes <- getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes handleServerMessage request response notification msg if shouldSkip msg - then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut + then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx else if inRightOrder msg expectedMsgs - then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs ++ [head $ dropWhile isNotification expectedMsgs] - exc = ReplayOutOfOrderException msg remainingMsgs + exc = ReplayOutOfOrder msg remainingMsgs in liftIO $ throwTo mainThreadId exc where - response :: ResponseMessage a -> Session () + response :: ResponseMessage a -> IO () response res = do - liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) + putStrLn $ "Got response for id " ++ show (res ^. id) - liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request + putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: RequestMessage ServerMethod a b -> Session () + request :: RequestMessage ServerMethod a b -> IO () request req = do - liftIO - $ putStrLn + putStrLn $ "Got request for id " ++ show (req ^. id) ++ " " ++ show (req ^. method) - liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response + putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification :: NotificationMessage ServerMethod a -> Session () - notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + notification :: NotificationMessage ServerMethod a -> IO () + notification n = putStrLn $ "Got notification " ++ show (n ^. method)