1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Haskell.LSP.Test.Recorded
7 import Control.Concurrent
9 import Language.Haskell.LSP.Control as Control
10 import qualified Data.ByteString.Lazy.Char8 as B
11 import Language.Haskell.LSP.Core
12 import qualified Language.Haskell.LSP.Types as LSP
19 import System.Directory
22 -- | Replays a recorded client output and
23 -- makes sure it matches up with an expected response.
25 :: FilePath -- ^ The client output to replay to the server.
26 -> FilePath -- ^ The expected response from the server.
30 -- need to keep hold of current directory since haskell-lsp changes it
31 prevDir <- getCurrentDirectory
33 (Just serverIn, Just serverOut, _, serverProc) <- createProcess
34 (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe
35 , std_out = CreatePipe
38 hSetBuffering serverIn NoBuffering
39 hSetBuffering serverOut NoBuffering
42 -- whether to send the next request
43 reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
44 -- whether to send the next response
45 rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
46 let semas = (reqSema, rspSema)
48 didPass <- newEmptyMVar
50 -- the recorded client input to the server
51 clientRecIn <- openFile cfp ReadMode
52 serverRecIn <- openFile sfp ReadMode
53 null <- openFile "/dev/null" WriteMode
56 expectedMsgs <- getAllMessages serverRecIn
59 forkIO $ listenServer expectedMsgs serverOut semas didPass
61 -- start client replay
63 Control.runWithHandles clientRecIn
65 (const $ Right (), const $ return Nothing)
66 (handlers serverIn semas)
71 -- todo: we shouldn't do this, we should check all notifications were delivered first
74 result <- takeMVar didPass
75 terminateProcess serverProc
78 setCurrentDirectory prevDir
82 -- todo: Maybe make a reader monad and a fail function for it?
86 -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
89 listenServer [] _ _ passVar = putMVar passVar True
90 listenServer expectedMsgs h semas@(reqSema, rspSema) passVar = do
91 msg <- getNextMessage h
92 putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
93 if inRightOrder msg expectedMsgs
96 whenResponse msg $ \res -> do
97 putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
98 putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
100 whenRequest msg $ \req -> do
101 putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
102 putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
104 whenNotification msg $ \n -> putStrLn $ "Got notification " ++ (show (n ^. LSP.method))
106 when (not (msg `elem` expectedMsgs)) $ do
107 putStrLn "Got an unexpected message"
108 putMVar passVar False
110 listenServer (delete msg expectedMsgs) h semas passVar
112 putStrLn $ "Got: " ++ show msg ++ "\n Expected: " ++ show
113 (head (filter (not . isNotification) expectedMsgs))
114 putMVar passVar False
116 isNotification :: B.ByteString -> Bool
118 isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
120 whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO ()
121 whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
122 Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
126 :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO ()
128 forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
130 whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> IO ()) -> IO ()
131 whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
133 -- TODO: QuickCheck tests?
134 -- | Checks wether or not the message appears in the right order
135 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
136 -- given N2, notification order doesn't matter.
137 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
139 -- @ N1 N3 N4 N5 REQ2 RES1 @
141 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
142 -- Order of requests and responses matter
143 inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
144 inRightOrder _ [] = error "why is this empty"
145 inRightOrder received msgs = received `elem` valid
147 valid = takeWhile canSkip msgs ++ firstNonSkip
148 -- we don't care about the order of notifications
149 canSkip = isNotification
150 nonSkip = dropWhile canSkip msgs
151 firstNonSkip | null nonSkip = []
152 | otherwise = [head nonSkip]
154 getAllMessages :: Handle -> IO [B.ByteString]
155 getAllMessages h = do
160 msg <- getNextMessage h
161 (msg :) <$> getAllMessages h
163 -- | Fetches the next message bytes based on
164 -- the Content-Length header
165 getNextMessage :: Handle -> IO B.ByteString
166 getNextMessage h = do
167 headers <- getHeaders h
168 case read . init <$> lookup "Content-Length" headers of
169 Nothing -> error "Couldn't read Content-Length header"
170 Just size -> B.hGet h size
173 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
174 handlers serverH (reqSema, rspSema) = def
177 hoverHandler = Just request
178 , completionHandler = Just request
179 , completionResolveHandler = Just request
180 , signatureHelpHandler = Just request
181 , definitionHandler = Just request
182 , referencesHandler = Just request
183 , documentHighlightHandler = Just request
184 , documentSymbolHandler = Just request
185 , workspaceSymbolHandler = Just request
186 , codeActionHandler = Just request
187 , codeLensHandler = Just request
188 , codeLensResolveHandler = Just request
189 , documentFormattingHandler = Just request
190 , documentRangeFormattingHandler = Just request
191 , documentTypeFormattingHandler = Just request
192 , renameHandler = Just request
193 , documentLinkHandler = Just request
194 , documentLinkResolveHandler = Just request
195 , executeCommandHandler = Just request
196 , initializeRequestHandler = Just request
198 , didChangeConfigurationParamsHandler = Just notification
199 , didOpenTextDocumentNotificationHandler = Just notification
200 , didChangeTextDocumentNotificationHandler = Just notification
201 , didCloseTextDocumentNotificationHandler = Just notification
202 , didSaveTextDocumentNotificationHandler = Just notification
203 , didChangeWatchedFilesNotificationHandler = Just notification
204 , initializedHandler = Just notification
205 , willSaveTextDocumentNotificationHandler = Just notification
206 , cancelNotificationHandler = Just notification
207 , exitNotificationHandler = Just notification
209 , responseHandler = Just response
212 -- TODO: May need to prevent premature exit notification being sent
213 -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
214 -- putStrLn "Will send exit notification soon"
215 -- threadDelay 10000000
216 -- B.hPut serverH $ addHeader (encode msg)
217 notification msg @(LSP.NotificationMessage _ m _) = do
218 B.hPut serverH $ addHeader (encode msg)
220 putStrLn $ "Sent a notification " ++ show m
222 request msg@(LSP.RequestMessage _ id m _) = do
223 B.hPut serverH $ addHeader (encode msg)
224 putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
226 rspId <- takeMVar reqSema
227 when (LSP.responseId id /= rspId)
234 response msg@(LSP.ResponseMessage _ id _ _) = do
235 putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
236 reqId <- takeMVar rspSema
237 if LSP.responseId reqId /= id
238 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
240 B.hPut serverH $ addHeader (encode msg)
241 putStrLn $ "Sent response to request id " ++ show id
243 addHeader :: B.ByteString -> B.ByteString
244 addHeader content = B.concat
246 , B.pack $ show $ B.length content
252 getHeaders :: Handle -> IO [(String, String)]
255 let (name, val) = span (/= ':') l
256 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h