7def859a2e9bda826d40d10602bad9f6a9897afc
[opengl.git] / src / Language / Haskell / LSP / Test / Replay.hs
1 -- | A testing tool for replaying captured client logs back to a server,
2 -- and validating that the server output matches up with another log.
3 module Language.Haskell.LSP.Test.Replay
4   ( replaySession
5   )
6 where
7
8 import           Prelude hiding (id)
9 import           Control.Concurrent
10 import           Control.Exception
11 import           Control.Monad.IO.Class
12 import qualified Data.ByteString.Lazy.Char8    as B
13 import qualified Data.Text                     as T
14 import           Data.UUID
15 import           Language.Haskell.LSP.Capture
16 import           Language.Haskell.LSP.Messages
17 import           Language.Haskell.LSP.Types hiding (error)
18 import           Data.Aeson
19 import           Data.List
20 import           Data.Maybe
21 import           Control.Lens hiding (List)
22 import           Control.Monad
23 import           System.IO
24 import           System.FilePath
25 import           System.Random
26 import           Language.Haskell.LSP.Test
27 import           Language.Haskell.LSP.Test.Files
28 import           Language.Haskell.LSP.Test.Decoding
29 import           Language.Haskell.LSP.Test.Messages
30 import           Language.Haskell.LSP.Test.Server
31
32
33 -- | Replays a captured client output and 
34 -- makes sure it matches up with an expected response.
35 -- The session directory should have a captured session file in it
36 -- named "session.log".
37 replaySession :: String -- ^ The command to run the server.
38               -> FilePath -- ^ The recorded session directory.
39               -> IO Bool
40 replaySession serverExe sessionDir = do
41
42   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
43
44   -- decode session
45   let unswappedEvents = map (fromJust . decode) entries
46
47   withServer serverExe $ \serverIn serverOut pid -> do
48
49     events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents
50
51     let clientEvents = filter isClientMsg events
52         serverEvents = filter isServerMsg events
53         clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
54         serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
55         requestMap = getRequestMap clientMsgs
56
57     reqSema <- newEmptyMVar
58     rspSema <- newEmptyMVar
59     passVar <- newEmptyMVar :: IO (MVar Bool)
60
61     threadId <- forkIO $
62       runSessionWithHandles serverIn
63                             serverOut
64                             (listenServer serverMsgs requestMap reqSema rspSema passVar)
65                             sessionDir
66                             (sendMessages clientMsgs reqSema rspSema)
67
68     result <- takeMVar passVar
69     killThread threadId
70     return result
71
72   where
73     isClientMsg (FromClient _ _) = True
74     isClientMsg _                = False
75
76     isServerMsg (FromServer _ _) = True
77     isServerMsg _                = False
78
79 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
80 sendMessages [] _ _ = return ()
81 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
82   handleClientMessage request response notification nextMsg
83  where
84   -- TODO: May need to prevent premature exit notification being sent
85   notification msg@(NotificationMessage _ Exit _) = do
86     liftIO $ putStrLn "Will send exit notification soon"
87     liftIO $ threadDelay 10000000
88     sendNotification' msg
89
90     liftIO $ error "Done"
91
92   notification msg@(NotificationMessage _ m _) = do
93     sendNotification' msg
94
95     liftIO $ putStrLn $ "Sent a notification " ++ show m
96
97     sendMessages remainingMsgs reqSema rspSema
98
99   request msg@(RequestMessage _ id m _) = do
100     sendRequest' msg
101     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
102
103     rsp <- liftIO $ takeMVar rspSema
104     when (responseId id /= rsp) $
105       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
106
107     sendMessages remainingMsgs reqSema rspSema
108
109   response msg@(ResponseMessage _ id _ _) = do
110     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
111     reqId <- liftIO $ takeMVar reqSema
112     if responseId reqId /= id
113       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
114       else do
115         sendResponse msg
116         liftIO $ putStrLn $ "Sent response to request id " ++ show id
117
118     sendMessages remainingMsgs reqSema rspSema
119
120
121 isNotification :: FromServerMessage -> Bool
122 isNotification (NotPublishDiagnostics      _) = True
123 isNotification (NotLogMessage              _) = True
124 isNotification (NotShowMessage             _) = True
125 isNotification (NotCancelRequestFromServer _) = True
126 isNotification _                              = False
127
128 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
129 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
130 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
131
132   let handler :: IOException -> IO B.ByteString
133       handler _ = putMVar passVar False >> return B.empty
134
135   msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
136   let msg = decodeFromServerMsg reqMap msgBytes
137
138   handleServerMessage request response notification msg
139
140   if shouldSkip msg
141     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
142     else if inRightOrder msg expectedMsgs
143       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
144       else liftIO $ do
145         putStrLn "Out of order"
146         putStrLn "Got:"
147         print msg
148         putStrLn "Expected one of:"
149         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
150         print $ head $ dropWhile isNotification expectedMsgs
151         putMVar passVar False
152
153   where
154   response :: ResponseMessage a -> Session ()
155   response res = do
156     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
157
158     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
159
160   request :: RequestMessage ServerMethod a b -> Session ()
161   request req = do
162     liftIO
163       $  putStrLn
164       $  "Got request for id "
165       ++ show (req ^. id)
166       ++ " "
167       ++ show (req ^. method)
168
169     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
170
171   notification :: NotificationMessage ServerMethod a -> Session ()
172   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
173
174
175
176 -- TODO: QuickCheck tests?
177 -- | Checks wether or not the message appears in the right order
178 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
179 -- given N2, notification order doesn't matter.
180 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
181 -- given REQ1
182 -- @ N1 N3 N4 N5 REQ2 RES1 @
183 -- given RES1
184 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
185 -- Order of requests and responses matter
186 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
187
188 inRightOrder _ [] = error "Why is this empty"
189
190 inRightOrder received (expected : msgs)
191   | received == expected               = True
192   | isNotification expected            = inRightOrder received msgs
193   | otherwise                          = False
194
195 -- | Ignore logging notifications since they vary from session to session
196 shouldSkip :: FromServerMessage -> Bool
197 shouldSkip (NotLogMessage  _) = True
198 shouldSkip (NotShowMessage _) = True
199 shouldSkip (ReqShowMessage _) = True
200 shouldSkip _                  = False
201
202 -- | Swaps out the expected UUIDs to match the current process ID
203 swapUUIDs :: Int -> [Event] -> [Event]
204 swapUUIDs _ [] = []
205 swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs
206   where swapped = case newCommands of
207           Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
208           Nothing -> rsp
209         oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
210         newCommands = fmap (fmap swap) oldCommands
211         swap cmd
212           | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd
213           | otherwise = cmd
214         uuid = toText $ fst $ random $ mkStdGen pid
215         isUuid = isJust . fromText . T.takeWhile (/= ':')
216 swapUUIDs pid (x:xs) = x:swapUUIDs pid xs