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 replay :: FilePath -> IO Int
21 (Just serverIn, Just serverOut, _, _) <- createProcess
22 (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe
23 , std_out = CreatePipe
26 hSetBuffering serverIn NoBuffering
27 hSetBuffering serverOut NoBuffering
29 -- whether to send the next request
30 semaphore <- newEmptyMVar
34 headers <- getHeaders serverOut
35 case read . init <$> lookup "Content-Length" headers of
36 Nothing -> error "Couldn't read Content-Length header"
38 message <- B.hGet serverOut size
39 case decode message :: Maybe (LSP.ResponseMessage Value) of
40 Just _ -> putMVar semaphore ()
41 Nothing -> return () -- might be a notification or something, that's ok
43 -- the recorded client input to the server
44 clientRecIn <- openFile fp ReadMode
45 null <- openFile "/dev/null" WriteMode
47 -- send inialize request ourselves since haskell-lsp consumes it
48 -- rest are handled via `handlers`
49 sendInitialize clientRecIn serverIn
51 Control.runWithHandles clientRecIn
53 (const $ Right (), const $ return Nothing)
54 (handlers serverIn semaphore)
59 sendInitialize recH serverH = do
60 headers <- getHeaders recH
61 case read . init <$> lookup "Content-Length" headers of
62 Nothing -> error "Failed to read the read the initialize request"
64 message <- B.hGet recH size
65 B.hPut serverH (addHeader message)
66 -- bring the file back to the start for haskell-lsp
67 hSeek recH AbsoluteSeek 0
70 handlers :: Handle -> MVar () -> Handlers
71 handlers serverH flag = def
74 hoverHandler = Just request
75 , completionHandler = Just request
76 , completionResolveHandler = Just request
77 , signatureHelpHandler = Just request
78 , definitionHandler = Just request
79 , referencesHandler = Just request
80 , documentHighlightHandler = Just request
81 , documentSymbolHandler = Just request
82 , workspaceSymbolHandler = Just request
83 , codeActionHandler = Just request
84 , codeLensHandler = Just request
85 , codeLensResolveHandler = Just request
86 , documentFormattingHandler = Just request
87 , documentRangeFormattingHandler = Just request
88 , documentTypeFormattingHandler = Just request
89 , renameHandler = Just request
90 , documentLinkHandler = Just request
91 , documentLinkResolveHandler = Just request
92 , executeCommandHandler = Just request
94 , didChangeConfigurationParamsHandler = Just notification
95 , didOpenTextDocumentNotificationHandler = Just notification
96 , didChangeTextDocumentNotificationHandler = Just notification
97 , didCloseTextDocumentNotificationHandler = Just notification
98 , didSaveTextDocumentNotificationHandler = Just notification
99 , didChangeWatchedFilesNotificationHandler = Just notification
100 , initializedHandler = Just notification
101 , willSaveTextDocumentNotificationHandler = Just notification
102 , cancelNotificationHandler = Just notification
103 , responseHandler = Just notification
107 B.hPut serverH $ addHeader (encode m)
108 putStrLn "sent a notification"
110 B.hPut serverH $ addHeader (encode m)
111 putStrLn "sent a request, waiting for a response"
113 putStrLn "got a response"
115 addHeader :: B.ByteString -> B.ByteString
116 addHeader content = B.concat
118 , B.pack $ show $ B.length content
124 getHeaders :: Handle -> IO [(String, String)]
127 let (name, val) = span (/= ':') l
128 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h