X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=73151d75cd8711a0107c65cadff95483014d1d5a;hb=cdb1ba7038c32bac71a3bc783effc1e07049a985;hp=7def859a2e9bda826d40d10602bad9f6a9897afc;hpb=5170a20560a68b8fcaed83ecaf6146d84a147992;p=opengl.git diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 7def859..73151d7 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -7,27 +7,25 @@ where import Prelude hiding (id) import Control.Concurrent -import Control.Exception import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Text as T -import Data.UUID import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Types 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.Random import Language.Haskell.LSP.Test 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 @@ -36,7 +34,7 @@ import Language.Haskell.LSP.Test.Server -- named "session.log". replaySession :: String -- ^ The command to run the server. -> FilePath -- ^ The recorded session directory. - -> IO Bool + -> IO () replaySession serverExe sessionDir = do entries <- B.lines <$> B.readFile (sessionDir "session.log") @@ -44,9 +42,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - withServer serverExe $ \serverIn serverOut pid -> do + withServer serverExe False $ \serverIn serverOut pid -> do - events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents + events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events serverEvents = filter isServerMsg events @@ -56,18 +54,19 @@ replaySession serverExe sessionDir = do reqSema <- newEmptyMVar rspSema <- newEmptyMVar - passVar <- newEmptyMVar :: IO (MVar Bool) + passSema <- newEmptyMVar + mainThread <- myThreadId - threadId <- forkIO $ + sessionThread <- liftIO $ forkIO $ runSessionWithHandles serverIn serverOut - (listenServer serverMsgs requestMap reqSema rspSema passVar) + (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) + def + fullCaps sessionDir (sendMessages clientMsgs reqSema rspSema) - - result <- takeMVar passVar - killThread threadId - return result + takeMVar passSema + killThread sessionThread where isClientMsg (FromClient _ _) = True @@ -97,7 +96,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = 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 @@ -125,51 +124,51 @@ isNotification (NotShowMessage _) = True isNotification (NotCancelRequestFromServer _) = True isNotification _ = False -listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session () -listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True -listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do - - let handler :: IOException -> IO B.ByteString - handler _ = putMVar passVar False >> return B.empty - - msgBytes <- liftIO $ catch (getNextMessage serverOut) handler +-- 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 <- getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes handleServerMessage request response notification msg if shouldSkip msg - then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut + then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx else if inRightOrder msg expectedMsgs - then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut - else liftIO $ do - putStrLn "Out of order" - putStrLn "Got:" - print msg - putStrLn "Expected one of:" - mapM_ print $ takeWhile (not . isNotification) expectedMsgs - print $ head $ dropWhile isNotification expectedMsgs - putMVar passVar False + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx + else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs + ++ [head $ dropWhile isNotification expectedMsgs] + 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) @@ -199,18 +198,26 @@ shouldSkip (NotShowMessage _) = True shouldSkip (ReqShowMessage _) = True shouldSkip _ = False --- | Swaps out the expected UUIDs to match the current process ID -swapUUIDs :: Int -> [Event] -> [Event] -swapUUIDs _ [] = [] -swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs +-- | Swaps out any commands uniqued with process IDs to match the specified process ID +swapCommands :: Int -> [Event] -> [Event] +swapCommands _ [] = [] + +swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs + where swapped = params . command .~ newCmd $ req + newCmd = swapPid pid (req ^. params . command) + +swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs where swapped = case newCommands of - Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp + Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp Nothing -> rsp - oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands - newCommands = fmap (fmap swap) oldCommands - swap cmd - | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd - | otherwise = cmd - uuid = toText $ fst $ random $ mkStdGen pid - isUuid = isJust . fromText . T.takeWhile (/= ':') -swapUUIDs pid (x:xs) = x:swapUUIDs pid xs \ No newline at end of file + oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands + newCommands = fmap (fmap (swapPid pid)) oldCommands + +swapCommands pid (x:xs) = x:swapCommands pid xs + +hasPid :: T.Text -> Bool +hasPid = (>= 2) . T.length . T.filter (':' ==) +swapPid :: Int -> T.Text -> T.Text +swapPid pid t + | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t + | otherwise = t