1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Haskell.LSP.Test.Recorded
7 import Control.Concurrent
10 import Language.Haskell.LSP.Control as Control
11 import qualified Data.ByteString.Lazy.Char8 as B
12 import Language.Haskell.LSP.Core
13 import qualified Language.Haskell.LSP.Types as LSP
18 -- | Replays a recorded client output and
19 -- makes sure it matches up with an expected response.
20 replay :: FilePath -- ^ The client output to replay to the server.
21 -> FilePath -- ^ The expected response from the server.
25 (Just serverIn, Just serverOut, _, _) <- createProcess
26 (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe
27 , std_out = CreatePipe
30 hSetBuffering serverIn NoBuffering
31 hSetBuffering serverOut NoBuffering
33 -- whether to send the next request
34 semaphore <- newEmptyMVar
36 -- the recorded client input to the server
37 clientRecIn <- openFile cfp ReadMode
38 serverRecIn <- openFile sfp ReadMode
39 null <- openFile "/dev/null" WriteMode
43 msg <- getNextMessage serverOut
44 expectedMsg <- getNextMessage serverRecIn
45 putStrLn $ "received: " ++ (show msg)
46 putStrLn $ "next expected: " ++ (show expectedMsg)
47 case decode msg :: Maybe (LSP.RequestMessage Value Value Value) of
48 Just _ -> putStrLn "ignoring request" >> return ()
49 Nothing -> when (msg /= expectedMsg) $ error ("Expected " ++ show expectedMsg ++ " but got " ++ show msg)
50 case decode msg :: Maybe (LSP.ResponseMessage Value) of
51 Just _ -> putMVar semaphore ()
52 Nothing -> return () -- might be a notification or something, that's ok
54 -- send inialize request ourselves since haskell-lsp consumes it
55 -- rest are handled via `handlers`
56 sendInitialize clientRecIn serverIn
58 Control.runWithHandles clientRecIn
60 (const $ Right (), const $ return Nothing)
61 (handlers serverIn semaphore)
66 sendInitialize recH serverH = do
67 message <- getNextMessage recH
68 B.hPut serverH (addHeader message)
69 -- bring the file back to the start for haskell-lsp
70 hSeek recH AbsoluteSeek 0
72 -- | Fetches the next message bytes based on
73 -- the Content-Length header
74 getNextMessage :: Handle -> IO B.ByteString
76 headers <- getHeaders h
77 case read . init <$> lookup "Content-Length" headers of
78 Nothing -> error "Couldn't read Content-Length header"
79 Just size -> B.hGet h size
82 handlers :: Handle -> MVar () -> Handlers
83 handlers serverH flag = def
86 hoverHandler = Just request
87 , completionHandler = Just request
88 , completionResolveHandler = Just request
89 , signatureHelpHandler = Just request
90 , definitionHandler = Just request
91 , referencesHandler = Just request
92 , documentHighlightHandler = Just request
93 , documentSymbolHandler = Just request
94 , workspaceSymbolHandler = Just request
95 , codeActionHandler = Just request
96 , codeLensHandler = Just request
97 , codeLensResolveHandler = Just request
98 , documentFormattingHandler = Just request
99 , documentRangeFormattingHandler = Just request
100 , documentTypeFormattingHandler = Just request
101 , renameHandler = Just request
102 , documentLinkHandler = Just request
103 , documentLinkResolveHandler = Just request
104 , executeCommandHandler = Just request
106 , didChangeConfigurationParamsHandler = Just notification
107 , didOpenTextDocumentNotificationHandler = Just notification
108 , didChangeTextDocumentNotificationHandler = Just notification
109 , didCloseTextDocumentNotificationHandler = Just notification
110 , didSaveTextDocumentNotificationHandler = Just notification
111 , didChangeWatchedFilesNotificationHandler = Just notification
112 , initializedHandler = Just notification
113 , willSaveTextDocumentNotificationHandler = Just notification
114 , cancelNotificationHandler = Just notification
115 , responseHandler = Just notification
119 B.hPut serverH $ addHeader (encode m)
120 putStrLn "sent a notification"
122 B.hPut serverH $ addHeader (encode m)
123 putStrLn "sent a request, waiting for a response"
125 putStrLn "got a response"
127 addHeader :: B.ByteString -> B.ByteString
128 addHeader content = B.concat
130 , B.pack $ show $ B.length content
136 getHeaders :: Handle -> IO [(String, String)]
139 let (name, val) = span (/= ':') l
140 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h