From 9db776483f617de170b6798d5ea8a9f997c0d098 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 18 May 2018 19:11:45 -0400 Subject: [PATCH] Add recorded playback --- .travis.yml | 2 +- example/Main.hs | 4 +- example/Recorded.hs | 7 ++ haskell-lsp-test.cabal | 13 +++ src/Language/Haskell/LSP/Test/Recorded.hs | 128 ++++++++++++++++++++++ stack.yaml | 5 + 6 files changed, 156 insertions(+), 3 deletions(-) create mode 100644 example/Recorded.hs create mode 100644 src/Language/Haskell/LSP/Test/Recorded.hs diff --git a/.travis.yml b/.travis.yml index d8f4976..9e73eaa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,4 @@ -language: haskell +language: c sudo: false diff --git a/example/Main.hs b/example/Main.hs index 9318bcb..8080991 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -9,8 +9,8 @@ import System.Environment main = do files <- getArgs - forM_ files $ \file -> session $ do - file <- liftIO $ canonicalizePath file + forM_ files $ \fp -> session $ do + file <- liftIO $ canonicalizePath fp openDocument file symbols <- documentSymbols file liftIO $ mapM_ T.putStrLn (symbols ^.. traverse . LSP.name) diff --git a/example/Recorded.hs b/example/Recorded.hs new file mode 100644 index 0000000..dc4aa69 --- /dev/null +++ b/example/Recorded.hs @@ -0,0 +1,7 @@ +import Language.Haskell.LSP.Test.Recorded +import System.Directory +import System.Environment + +main = do + file <- (head <$> getArgs) >>= canonicalizePath + replay file diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 44c0487..b00d507 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -16,10 +16,15 @@ extra-source-files: README.md library hs-source-dirs: src exposed-modules: Language.Haskell.LSP.Test + , Language.Haskell.LSP.Test.Recorded default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , haskell-lsp-client , haskell-lsp-types + , haskell-lsp + , data-default + , bytestring + , aeson , lens , text , transformers @@ -42,3 +47,11 @@ executable example , lens , text , directory + +executable recorded-example + hs-source-dirs: example + main-is: Recorded.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp-test + , directory diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs new file mode 100644 index 0000000..10aebe3 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Recorded + ( replay + ) +where + +import Control.Concurrent +import Control.Monad +import Data.Default +import Language.Haskell.LSP.Control as Control +import qualified Data.ByteString.Lazy.Char8 as B +import Language.Haskell.LSP.Core +import qualified Language.Haskell.LSP.Types as LSP +import Data.Aeson +import System.IO +import System.Process + +replay :: FilePath -> IO Int +replay fp = do + + (Just serverIn, Just serverOut, _, _) <- createProcess + (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe + , std_out = CreatePipe + } + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering + + -- whether to send the next request + semaphore <- newEmptyMVar + + -- listen to server + forkIO $ forever $ do + headers <- getHeaders serverOut + case read . init <$> lookup "Content-Length" headers of + Nothing -> error "Couldn't read Content-Length header" + Just size -> do + message <- B.hGet serverOut size + case decode message :: Maybe (LSP.ResponseMessage Value) of + Just _ -> putMVar semaphore () + Nothing -> return () -- might be a notification or something, that's ok + + -- the recorded client input to the server + clientRecIn <- openFile fp ReadMode + null <- openFile "/dev/null" WriteMode + + -- send inialize request ourselves since haskell-lsp consumes it + -- rest are handled via `handlers` + sendInitialize clientRecIn serverIn + + Control.runWithHandles clientRecIn + null + (const $ Right (), const $ return Nothing) + (handlers serverIn semaphore) + def + Nothing + Nothing + where + sendInitialize recH serverH = do + headers <- getHeaders recH + case read . init <$> lookup "Content-Length" headers of + Nothing -> error "Failed to read the read the initialize request" + Just size -> do + message <- B.hGet recH size + B.hPut serverH (addHeader message) + -- bring the file back to the start for haskell-lsp + hSeek recH AbsoluteSeek 0 + + +handlers :: Handle -> MVar () -> Handlers +handlers serverH flag = def + { + -- Requests + hoverHandler = Just request + , completionHandler = Just request + , completionResolveHandler = Just request + , signatureHelpHandler = Just request + , definitionHandler = Just request + , referencesHandler = Just request + , documentHighlightHandler = Just request + , documentSymbolHandler = Just request + , workspaceSymbolHandler = Just request + , codeActionHandler = Just request + , codeLensHandler = Just request + , codeLensResolveHandler = Just request + , documentFormattingHandler = Just request + , documentRangeFormattingHandler = Just request + , documentTypeFormattingHandler = Just request + , renameHandler = Just request + , documentLinkHandler = Just request + , documentLinkResolveHandler = Just request + , executeCommandHandler = Just request + -- Notifications + , didChangeConfigurationParamsHandler = Just notification + , didOpenTextDocumentNotificationHandler = Just notification + , didChangeTextDocumentNotificationHandler = Just notification + , didCloseTextDocumentNotificationHandler = Just notification + , didSaveTextDocumentNotificationHandler = Just notification + , didChangeWatchedFilesNotificationHandler = Just notification + , initializedHandler = Just notification + , willSaveTextDocumentNotificationHandler = Just notification + , cancelNotificationHandler = Just notification + , responseHandler = Just notification + } + where + notification m = do + B.hPut serverH $ addHeader (encode m) + putStrLn "sent a notification" + request m = do + B.hPut serverH $ addHeader (encode m) + putStrLn "sent a request, waiting for a response" + takeMVar flag + putStrLn "got a response" + +addHeader :: B.ByteString -> B.ByteString +addHeader content = B.concat + [ "Content-Length: " + , B.pack $ show $ B.length content + , "\r\n" + , "\r\n" + , content + ] + +getHeaders :: Handle -> IO [(String, String)] +getHeaders h = do + l <- hGetLine h + let (name, val) = span (/= ':') l + if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h diff --git a/stack.yaml b/stack.yaml index d1bf7cc..f85170d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,3 +6,8 @@ extra-deps: - github: Bubba/haskell-lsp-client commit: b7cf14eb48837a73032e867dab90db1708220c66 - haskell-lsp-types-0.2.2.0 + - github: Bubba/haskell-lsp + commit: d21ebcfbe8c2c09ac92e33fa18be0a2ce098b8bb + - sorted-list-0.2.1.0 + - github: yi-editor/yi-rope + commit: 7867909f4f20952be051fd4252cca5bbfc80cf41 -- 2.30.2