diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Luke Lau (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Luke Lau nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# lsp-test [![Build Status](https://travis-ci.com/Bubba/haskell-lsp-test.svg?branch=master)](https://travis-ci.com/Bubba/haskell-lsp-test) +lsp-test is a functional testing framework for Language Server Protocol servers. + +```haskell +import Language.Haskell.LSP.Test +runSession "hie" fullCaps "proj/dir" $ do + doc <- openDoc "Foo.hs" "haskell" + skipMany anyNotification + symbols <- getDocumentSymbols doc +``` + +## Examples + +### Unit tests with HSpec +```haskell +describe "diagnostics" $ + it "report errors" $ runSession "hie" fullCaps "test/data" $ do + openDoc "Error.hs" "haskell" + [diag] <- waitForDiagnosticsSource "ghcmod" + liftIO $ do + diag ^. severity `shouldBe` Just DsError + diag ^. source `shouldBe` Just "ghcmod" +``` + +### Replaying captured session +```haskell +replaySession "hie" "test/data/renamePass" +``` + +### Parsing with combinators +```haskell +skipManyTill loggingNotification publishDiagnosticsNotification +count 4 (message :: Session ApplyWorkspaceEditRequest) +anyRequest <|> anyResponse +``` + +Try out the example tests in the `example` directory with `cabal new-test`. +For more examples check the [Wiki](https://github.com/Bubba/haskell-lsp-test/wiki/Introduction) + +## Developing +To test make sure you have the following language servers installed: +- [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) +- [javascript-typescript-langserver](https://github.com/sourcegraph/javascript-typescript-langserver) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lsp-test.cabal b/lsp-test.cabal new file mode 100644 --- /dev/null +++ b/lsp-test.cabal @@ -0,0 +1,87 @@ +name: lsp-test +version: 0.1.0.0 +synopsis: Functional test framework for LSP servers. +description: + A test framework for writing tests against + . + @Language.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session + down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from + . + It's currently used for testing in . +homepage: https://github.com/Bubba/haskell-lsp-test#readme +license: BSD3 +license-file: LICENSE +author: Luke Lau +maintainer: luke_lau@icloud.com +stability: experimental +bug-reports: https://github.com/Bubba/haskell-lsp-test/issues +copyright: 2018 Luke Lau +category: Testing +build-type: Simple +cabal-version: 2.0 +extra-source-files: README.md +tested-with: GHC == 8.2.2 , GHC == 8.4.2 , GHC == 8.4.3 + +source-repository head + type: git + location: https://github.com/Bubba/haskell-lsp-test/ + +library + hs-source-dirs: src + exposed-modules: Language.Haskell.LSP.Test + , Language.Haskell.LSP.Test.Replay + reexported-modules: haskell-lsp:Language.Haskell.LSP.Types + , haskell-lsp:Language.Haskell.LSP.Types.Capabilities + , parser-combinators:Control.Applicative.Combinators + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp >= 0.5 + , aeson + , aeson-pretty + , ansi-terminal + , bytestring + , conduit + , conduit-parse + , containers + , data-default + , Diff + , directory + , filepath + , lens + , mtl + , parser-combinators + , process + , text + , transformers + , unordered-containers + , yi-rope + if os(windows) + build-depends: Win32 + else + build-depends: unix + other-modules: Language.Haskell.LSP.Test.Compat + Language.Haskell.LSP.Test.Decoding + Language.Haskell.LSP.Test.Exceptions + Language.Haskell.LSP.Test.Files + Language.Haskell.LSP.Test.Messages + Language.Haskell.LSP.Test.Parsing + Language.Haskell.LSP.Test.Server + Language.Haskell.LSP.Test.Session + ghc-options: -W + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + ghc-options: -W + build-depends: base >= 4.7 && < 5 + , hspec + , lens + , data-default + , haskell-lsp >= 0.5 + , lsp-test + , aeson + , unordered-containers + , text + default-language: Haskell2010 + diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} + +{-| +Module : Language.Haskell.LSP.Test +Description : A functional testing framework for LSP servers. +Maintainer : luke_lau@icloud.com +Stability : experimental +Portability : POSIX + +Provides the framework to start functionally testing +. +You should import "Language.Haskell.LSP.Types" alongside this. +-} +module Language.Haskell.LSP.Test + ( + -- * Sessions + Session + , runSession + -- ** Config + , runSessionWithConfig + , SessionConfig(..) + , defaultConfig + , module Language.Haskell.LSP.Types.Capabilities + -- ** Exceptions + , module Language.Haskell.LSP.Test.Exceptions + , withTimeout + -- * Sending + , request + , request_ + , sendRequest + , sendNotification + , sendResponse + -- * Receving + , module Language.Haskell.LSP.Test.Parsing + -- * Utilities + -- | Quick helper functions for common tasks. + -- ** Initialization + , initializeResponse + -- ** Documents + , openDoc + , closeDoc + , documentContents + , getDocumentEdit + , getDocUri + , getVersionedDoc + -- ** Symbols + , getDocumentSymbols + -- ** Diagnostics + , waitForDiagnostics + , waitForDiagnosticsSource + , noDiagnostics + -- ** Commands + , executeCommand + -- ** Code Actions + , getAllCodeActions + , executeCodeAction + -- ** Completions + , getCompletions + -- ** References + , getReferences + -- ** Definitions + , getDefinitions + -- ** Renaming + , rename + -- ** Hover + , getHover + -- ** Highlights + , getHighlights + -- ** Formatting + , formatDoc + , formatRange + -- ** Edits + , applyEdit + ) where + +import Control.Applicative.Combinators +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception +import Control.Lens hiding ((.=), List) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import Data.Maybe +import Language.Haskell.LSP.Types hiding (id, capabilities, message) +import qualified Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Types.Capabilities +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Test.Compat +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Exceptions +import Language.Haskell.LSP.Test.Parsing +import Language.Haskell.LSP.Test.Session +import Language.Haskell.LSP.Test.Server +import System.IO +import System.Directory +import System.FilePath +import qualified Yi.Rope as Rope + +-- | Starts a new session. +-- +-- > runSession "hie" fullCaps "path/to/root/dir" $ do +-- > doc <- openDoc "Desktop/simple.hs" "haskell" +-- > diags <- waitForDiagnostics +-- > let pos = Position 12 5 +-- > params = TextDocumentPositionParams doc +-- > hover <- request TextDocumentHover params +runSession :: String -- ^ The command to run the server. + -> ClientCapabilities -- ^ The capabilities that the client should declare. + -> FilePath -- ^ The filepath to the root directory for the session. + -> Session a -- ^ The session to run. + -> IO a +runSession = runSessionWithConfig def + +-- | Starts a new sesion with a custom configuration. +runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. + -> String -- ^ The command to run the server. + -> ClientCapabilities -- ^ The capabilities that the client should declare. + -> FilePath -- ^ The filepath to the root directory for the session. + -> Session a -- ^ The session to run. + -> IO a +runSessionWithConfig config serverExe caps rootDir session = do + pid <- getCurrentProcessID + absRootDir <- canonicalizePath rootDir + + let initializeParams = InitializeParams (Just pid) + (Just $ T.pack absRootDir) + (Just $ filePathToUri absRootDir) + Nothing + caps + (Just TraceOff) + withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> + runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do + + -- Wrap the session around initialize and shutdown calls + initRspMsg <- request Initialize initializeParams :: Session InitializeResponse + + liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error) + + initRspVar <- initRsp <$> ask + liftIO $ putMVar initRspVar initRspMsg + + sendNotification Initialized InitializedParams + + -- Run the actual test + result <- session + + sendNotification Exit ExitParams + + return result + where + -- | Listens to the server output, makes sure it matches the record and + -- signals any semaphores + listenServer :: Handle -> SessionContext -> IO () + listenServer serverOut context = do + msgBytes <- getNextMessage serverOut + + reqMap <- readMVar $ requestMap context + + let msg = decodeFromServerMsg reqMap msgBytes + writeChan (messageChan context) (ServerMessage msg) + + listenServer serverOut context + +-- | The current text contents of a document. +documentContents :: TextDocumentIdentifier -> Session T.Text +documentContents doc = do + vfs <- vfs <$> get + let file = vfs Map.! (doc ^. uri) + return $ Rope.toText $ Language.Haskell.LSP.VFS._text file + +-- | Parses an ApplyEditRequest, checks that it is for the passed document +-- and returns the new content +getDocumentEdit :: TextDocumentIdentifier -> Session T.Text +getDocumentEdit doc = do + req <- message :: Session ApplyWorkspaceEditRequest + + unless (checkDocumentChanges req || checkChanges req) $ + liftIO $ throw (IncorrectApplyEditRequest (show req)) + + documentContents doc + where + checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool + checkDocumentChanges req = + let changes = req ^. params . edit . documentChanges + maybeDocs = fmap (fmap (^. textDocument . uri)) changes + in case maybeDocs of + Just docs -> (doc ^. uri) `elem` docs + Nothing -> False + checkChanges :: ApplyWorkspaceEditRequest -> Bool + checkChanges req = + let mMap = req ^. params . edit . changes + in maybe False (HashMap.member (doc ^. uri)) mMap + +-- | Sends a request to the server and waits for its response. +-- Will skip any messages in between the request and the response +-- @ +-- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse +-- @ +-- Note: will skip any messages in between the request and the response. +request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) +request m = sendRequest m >=> skipManyTill anyMessage . responseForId + +-- | The same as 'sendRequest', but discard the response. +request_ :: ToJSON params => ClientMethod -> params -> Session () +request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value)) + +-- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. +sendRequest + :: ToJSON params + => ClientMethod -- ^ The request method. + -> params -- ^ The request parameters. + -> Session LspId -- ^ The id of the request that was sent. +sendRequest method params = do + id <- curReqId <$> get + modify $ \c -> c { curReqId = nextId id } + + let req = RequestMessage' "2.0" id method params + + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r id method + + sendMessage req + + return id + + where nextId (IdInt i) = IdInt (i + 1) + nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 + +-- | A custom type for request message that doesn't +-- need a response type, allows us to infer the request +-- message type without using proxies. +data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a + +instance ToJSON a => ToJSON (RequestMessage' a) where + toJSON (RequestMessage' rpc id method params) = + object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] + + +-- | Sends a notification to the server. +sendNotification :: ToJSON a + => ClientMethod -- ^ The notification method. + -> a -- ^ The notification parameters. + -> Session () + +-- Open a virtual file if we send a did open text document notification +sendNotification TextDocumentDidOpen params = do + let params' = fromJust $ decode $ encode params + n :: DidOpenTextDocumentNotification + n = NotificationMessage "2.0" TextDocumentDidOpen params' + oldVFS <- vfs <$> get + newVFS <- liftIO $ openVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + +-- Close a virtual file if we send a close text document notification +sendNotification TextDocumentDidClose params = do + let params' = fromJust $ decode $ encode params + n :: DidCloseTextDocumentNotification + n = NotificationMessage "2.0" TextDocumentDidClose params' + oldVFS <- vfs <$> get + newVFS <- liftIO $ closeVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + +sendNotification method params = sendMessage (NotificationMessage "2.0" method params) + +-- | Sends a response to the server. +sendResponse :: ToJSON a => ResponseMessage a -> Session () +sendResponse = sendMessage + +-- | Returns the initialize response that was received from the server. +-- The initialize requests and responses are not included the session, +-- so if you need to test it use this. +initializeResponse :: Session InitializeResponse +initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) + +-- | Opens a text document and sends a notification to the client. +openDoc :: FilePath -> String -> Session TextDocumentIdentifier +openDoc file languageId = do + item <- getDocItem file languageId + sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) + TextDocumentIdentifier <$> getDocUri file + where + -- | Reads in a text document as the first version. + getDocItem :: FilePath -- ^ The path to the text document to read in. + -> String -- ^ The language ID, e.g "haskell" for .hs files. + -> Session TextDocumentItem + getDocItem file languageId = do + context <- ask + let fp = rootDir context file + contents <- liftIO $ T.readFile fp + return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents + +-- | Closes a text document and sends a notification to the client. +closeDoc :: TextDocumentIdentifier -> Session () +closeDoc docId = do + let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) + sendNotification TextDocumentDidClose params + + oldVfs <- vfs <$> get + let notif = NotificationMessage "" TextDocumentDidClose params + newVfs <- liftIO $ closeVFS oldVfs notif + modify $ \s -> s { vfs = newVfs } + +-- | Gets the Uri for the file corrected to the session directory. +getDocUri :: FilePath -> Session Uri +getDocUri file = do + context <- ask + let fp = rootDir context file + return $ filePathToUri fp + +-- | Waits for diagnostics to be published and returns them. +waitForDiagnostics :: Session [Diagnostic] +waitForDiagnostics = do + diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. params . LSP.diagnostics + return diags + +-- | The same as 'waitForDiagnostics', but will only match a specific +-- 'Language.Haskell.LSP.Types._source'. +waitForDiagnosticsSource :: String -> Session [Diagnostic] +waitForDiagnosticsSource src = do + diags <- waitForDiagnostics + let res = filter matches diags + if null res + then waitForDiagnosticsSource src + else return res + where + matches :: Diagnostic -> Bool + matches d = d ^. source == Just (T.pack src) + +-- | Expects a 'PublishDiagnosticsNotification' and throws an +-- 'UnexpectedDiagnosticsException' if there are any diagnostics +-- returned. +noDiagnostics :: Session () +noDiagnostics = do + diagsNot <- message :: Session PublishDiagnosticsNotification + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics + +-- | Returns the symbols in a document. +getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] +getDocumentSymbols doc = do + ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) + maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr + let (Just (List symbols)) = mRes + return symbols + +-- | Returns all the code actions in a document by +-- querying the code actions at each of the current +-- diagnostics' positions. +getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction] +getAllCodeActions doc = do + curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get + let ctx = CodeActionContext (List curDiags) Nothing + + foldM (go ctx) [] curDiags + + where + go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction] + go ctx acc diag = do + ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx) + + case mErr of + Just e -> throw (UnexpectedResponseError rspLid e) + Nothing -> + let Just (List cmdOrCAs) = mRes + in return (acc ++ cmdOrCAs) + +-- | Executes a command. +executeCommand :: Command -> Session () +executeCommand cmd = do + let args = decode $ encode $ fromJust $ cmd ^. arguments + execParams = ExecuteCommandParams (cmd ^. command) args + request_ WorkspaceExecuteCommand execParams + +-- | Executes a code action. +-- Matching with the specification, if a code action +-- contains both an edit and a command, the edit will +-- be applied first. +executeCodeAction :: CodeAction -> Session () +executeCodeAction action = do + maybe (return ()) handleEdit $ action ^. edit + maybe (return ()) executeCommand $ action ^. command + + where handleEdit :: WorkspaceEdit -> Session () + handleEdit e = + -- Its ok to pass in dummy parameters here as they aren't used + let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) + in updateState (ReqApplyWorkspaceEdit req) + +-- | Adds the current version to the document, as tracked by the session. +getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier +getVersionedDoc (TextDocumentIdentifier uri) = do + fs <- vfs <$> get + let ver = + case fs Map.!? uri of + Just (VirtualFile v _) -> Just v + _ -> Nothing + return (VersionedTextDocumentIdentifier uri ver) + +-- | Applys an edit to the document and returns the updated document version. +applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier +applyEdit doc edit = do + + verDoc <- getVersionedDoc doc + + caps <- asks sessionCapabilities + + let supportsDocChanges = fromMaybe False $ do + let ClientCapabilities mWorkspace _ _ = caps + WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace + WorkspaceEditClientCapabilities mDocChanges <- mEdit + mDocChanges + + let wEdit = if supportsDocChanges + then + let docEdit = TextDocumentEdit verDoc (List [edit]) + in WorkspaceEdit Nothing (Just (List [docEdit])) + else + let changes = HashMap.singleton (doc ^. uri) (List [edit]) + in WorkspaceEdit (Just changes) Nothing + + let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + updateState (ReqApplyWorkspaceEdit req) + + -- version may have changed + getVersionedDoc doc + +-- | Returns the completions for the position in the document. +getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] +getCompletions doc pos = do + rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos) + + case getResponseResult rsp of + Completions (List items) -> return items + CompletionList (CompletionListType _ (List items)) -> return items + +-- | Returns the references for the position in the document. +getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. + -> Position -- ^ The position to lookup. + -> Bool -- ^ Whether to include declarations as references. + -> Session [Location] -- ^ The locations of the references. +getReferences doc pos inclDecl = + let ctx = ReferenceContext inclDecl + params = ReferenceParams doc pos ctx + in getResponseResult <$> request TextDocumentReferences params + +-- | Returns the definition(s) for the term at the specified position. +getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. + -> Position -- ^ The position the term is at. + -> Session [Location] -- ^ The location(s) of the definitions +getDefinitions doc pos = + let params = TextDocumentPositionParams doc pos + in getResponseResult <$> request TextDocumentDefinition params + +-- | Renames the term at the specified position. +rename :: TextDocumentIdentifier -> Position -> String -> Session () +rename doc pos newName = do + let params = RenameParams doc pos (T.pack newName) + rsp <- request TextDocumentRename params :: Session RenameResponse + let wEdit = getResponseResult rsp + req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + updateState (ReqApplyWorkspaceEdit req) + +-- | Returns the hover information at the specified position. +getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) +getHover doc pos = + let params = TextDocumentPositionParams doc pos + in getResponseResult <$> request TextDocumentHover params + +-- | Returns the highlighted occurences of the term at the specified position +getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] +getHighlights doc pos = + let params = TextDocumentPositionParams doc pos + in getResponseResult <$> request TextDocumentDocumentHighlight params + +-- | Checks the response for errors and throws an exception if needed. +-- Returns the result if successful. +getResponseResult :: ResponseMessage a -> a +getResponseResult rsp = fromMaybe exc (rsp ^. result) + where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id) + (fromJust $ rsp ^. LSP.error) + +-- | Applies formatting to the specified document. +formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () +formatDoc doc opts = do + let params = DocumentFormattingParams doc opts + edits <- getResponseResult <$> request TextDocumentFormatting params + applyTextEdits doc edits + +-- | Applies formatting to the specified range in a document. +formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () +formatRange doc opts range = do + let params = DocumentRangeFormattingParams doc range opts + edits <- getResponseResult <$> request TextDocumentRangeFormatting params + applyTextEdits doc edits + +applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () +applyTextEdits doc edits = + let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing + req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + in updateState (ReqApplyWorkspaceEdit req) diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +-- For some reason ghc warns about not using +-- Control.Monad.IO.Class but it's needed for +-- MonadIO +{-# OPTIONS_GHC -Wunused-imports #-} +module Language.Haskell.LSP.Test.Compat where + +import Data.Maybe + +#if MIN_VERSION_process(1,6,3) +import System.Process hiding (getPid) +import qualified System.Process (getPid) +#else +import System.Process +import System.Process.Internals +import Control.Concurrent.MVar +#endif + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process +#else +import qualified System.Posix.Process +#endif + + +getCurrentProcessID :: IO Int +#ifdef mingw32_HOST_OS +getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId +#else +getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID +#endif + +getProcessID :: ProcessHandle -> IO Int +getProcessID p = fromIntegral . fromJust <$> getProcessID' p + where +#if MIN_VERSION_process(1,6,3) + getProcessID' = System.Process.getPid +#else + getProcessID' (ProcessHandle mh _ _) = do + p_ <- readMVar mh + case p_ of +#ifdef mingw32_HOST_OS + OpenHandle h -> do + pid <- System.Win32.Process.getProcessId h + return $ Just pid +#else + OpenHandle pid -> return $ Just pid +#endif + _ -> return Nothing +#endif diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Decoding where + +import Prelude hiding ( id ) +import Data.Aeson +import Control.Lens +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Maybe +import System.IO +import Language.Haskell.LSP.Types + hiding ( error ) +import Language.Haskell.LSP.Messages +import qualified Data.HashMap.Strict as HM + +getAllMessages :: Handle -> IO [B.ByteString] +getAllMessages h = do + done <- hIsEOF h + if done + then return [] + else do + msg <- getNextMessage h + + (msg :) <$> getAllMessages h + +-- | Fetches the next message bytes based on +-- the Content-Length header +getNextMessage :: Handle -> IO B.ByteString +getNextMessage h = do + headers <- getHeaders h + case read . init <$> lookup "Content-Length" headers of + Nothing -> error "Couldn't read Content-Length header" + Just size -> B.hGet h size + +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 + +type RequestMap = HM.HashMap LspId ClientMethod + +newRequestMap :: RequestMap +newRequestMap = HM.empty + +updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap +updateRequestMap reqMap id method = HM.insert id method reqMap + +getRequestMap :: [FromClientMessage] -> RequestMap +getRequestMap = foldl helper HM.empty + where + helper acc msg = case msg of + (ReqInitialize val) -> insert val acc + (ReqShutdown val) -> insert val acc + (ReqHover val) -> insert val acc + (ReqCompletion val) -> insert val acc + (ReqCompletionItemResolve val) -> insert val acc + (ReqSignatureHelp val) -> insert val acc + (ReqDefinition val) -> insert val acc + (ReqFindReferences val) -> insert val acc + (ReqDocumentHighlights val) -> insert val acc + (ReqDocumentSymbols val) -> insert val acc + (ReqWorkspaceSymbols val) -> insert val acc + (ReqCodeAction val) -> insert val acc + (ReqCodeLens val) -> insert val acc + (ReqCodeLensResolve val) -> insert val acc + (ReqDocumentFormatting val) -> insert val acc + (ReqDocumentRangeFormatting val) -> insert val acc + (ReqDocumentOnTypeFormatting val) -> insert val acc + (ReqRename val) -> insert val acc + (ReqExecuteCommand val) -> insert val acc + (ReqDocumentLink val) -> insert val acc + (ReqDocumentLinkResolve val) -> insert val acc + (ReqWillSaveWaitUntil val) -> insert val acc + _ -> acc + insert m = HM.insert (m ^. id) (m ^. method) + +matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage +matchResponseMsgType req = case req of + Initialize -> RspInitialize . decoded + Shutdown -> RspShutdown . decoded + TextDocumentHover -> RspHover . decoded + TextDocumentCompletion -> RspCompletion . decoded + CompletionItemResolve -> RspCompletionItemResolve . decoded + TextDocumentSignatureHelp -> RspSignatureHelp . decoded + TextDocumentDefinition -> RspDefinition . decoded + TextDocumentReferences -> RspFindReferences . decoded + TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded + TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded + WorkspaceSymbol -> RspWorkspaceSymbols . decoded + TextDocumentCodeAction -> RspCodeAction . decoded + TextDocumentCodeLens -> RspCodeLens . decoded + CodeLensResolve -> RspCodeLensResolve . decoded + TextDocumentFormatting -> RspDocumentFormatting . decoded + TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded + TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded + TextDocumentRename -> RspRename . decoded + WorkspaceExecuteCommand -> RspExecuteCommand . decoded + TextDocumentDocumentLink -> RspDocumentLink . decoded + DocumentLinkResolve -> RspDocumentLinkResolve . decoded + TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded + x -> error . ((show x ++ " is not a request: ") ++) . show + where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: " + ++ show req ++ "\n" ++ show x) + (decode x) + +decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage +decodeFromServerMsg reqMap bytes = + case HM.lookup "method" (fromJust $ decode bytes :: Object) of + Just methodStr -> case fromJSON methodStr of + Success method -> case method of + -- We can work out the type of the message + TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes + WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes + WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes + CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes + TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes + WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes + ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes + ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes + WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes + + Error e -> error e + + Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of + Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of + Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type + Nothing -> error "Couldn't match up response with request" + Nothing -> error "Couldn't decode message" diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -0,0 +1,46 @@ +module Language.Haskell.LSP.Test.Exceptions where + +import Control.Exception +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Data.Aeson.Encode.Pretty +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B + +-- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' +data SessionException = Timeout + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String + | UnexpectedResponseError LspIdRsp ResponseError + deriving Eq + +instance Exception SessionException + +instance Show SessionException where + show Timeout = "Timed out waiting to receive a message from the server." + show (UnexpectedMessage expected lastMsg) = + "Received an unexpected message from the server:\n" ++ + "Was parsing: " ++ expected ++ "\n" ++ + "Last message received: " ++ show lastMsg + show (ReplayOutOfOrder received expected) = + let expected' = nub expected + getJsonDiff = lines . B.unpack . encodePretty + showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++ + ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp)) + in "Replay is out of order:\n" ++ + -- Print json so its a bit easier to update the session logs + "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++ + "Expected one of:\n" ++ unlines (map showExp expected') + show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." + show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" + ++ msgStr + show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" + ++ show e + +-- | A predicate that matches on any 'SessionException' +anySessionException :: SessionException -> Bool +anySessionException = const True diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Files + ( swapFiles + , rootDir + ) +where + +import Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Types hiding ( error ) +import Language.Haskell.LSP.Messages +import Control.Lens +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Maybe +import System.Directory +import System.FilePath + +swapFiles :: FilePath -> [Event] -> IO [Event] +swapFiles relCurBaseDir msgs = do + let capturedBaseDir = rootDir msgs + + curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory + let transform uri = + let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) + newFp = curBaseDir makeRelative capturedBaseDir fp + in filePathToUri newFp + newMsgs = map (mapUris transform) msgs + + return newMsgs + +rootDir :: [Event] -> FilePath +rootDir (FromClient _ (ReqInitialize req):_) = + fromMaybe (error "Couldn't find root dir") $ do + rootUri <- req ^. params .rootUri + uriToFilePath rootUri +rootDir _ = error "Couldn't find initialize request in session" + +mapUris :: (Uri -> Uri) -> Event -> Event +mapUris f event = + case event of + FromClient t msg -> FromClient t (fromClientMsg msg) + FromServer t msg -> FromServer t (fromServerMsg msg) + + where + --TODO: Handle all other URIs that might need swapped + fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n + fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r + fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r + fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r + fromClientMsg x = x + + fromServerMsg :: FromServerMessage -> FromServerMessage + fromServerMsg (ReqApplyWorkspaceEdit r) = + ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r + + fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n + + fromServerMsg (RspDocumentSymbols r) = + let newSymbols = fmap (fmap (swapUri location)) $ r ^. result + in RspDocumentSymbols $ result .~ newSymbols $ r + + fromServerMsg (RspRename r) = + let oldResult = r ^. result :: Maybe WorkspaceEdit + newResult = fmap swapWorkspaceEdit oldResult + in RspRename $ result .~ newResult $ r + + fromServerMsg x = x + + swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit + swapWorkspaceEdit e = + let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges + newChanges = fmap (swapKeys f) $ e ^. changes + in WorkspaceEdit newChanges newDocChanges + + swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b + swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty + + swapUri :: HasUri b Uri => Lens' a b -> a -> a + swapUri lens x = + let newUri = f (x ^. lens . uri) + in (lens . uri) .~ newUri $ x + + -- | Transforms rootUri/rootPath. + transformInit :: InitializeParams -> InitializeParams + transformInit x = + let newRootUri = fmap f (x ^. rootUri) + newRootPath = do + fp <- T.unpack <$> x ^. rootPath + let uri = filePathToUri fp + T.pack <$> uriToFilePath (f uri) + in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE RankNTypes #-} +module Language.Haskell.LSP.Test.Messages where + +import Data.Aeson +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types hiding (error) + +isServerResponse :: FromServerMessage -> Bool +isServerResponse (RspInitialize _) = True +isServerResponse (RspShutdown _) = True +isServerResponse (RspHover _) = True +isServerResponse (RspCompletion _) = True +isServerResponse (RspCompletionItemResolve _) = True +isServerResponse (RspSignatureHelp _) = True +isServerResponse (RspDefinition _) = True +isServerResponse (RspFindReferences _) = True +isServerResponse (RspDocumentHighlights _) = True +isServerResponse (RspDocumentSymbols _) = True +isServerResponse (RspWorkspaceSymbols _) = True +isServerResponse (RspCodeAction _) = True +isServerResponse (RspCodeLens _) = True +isServerResponse (RspCodeLensResolve _) = True +isServerResponse (RspDocumentFormatting _) = True +isServerResponse (RspDocumentRangeFormatting _) = True +isServerResponse (RspDocumentOnTypeFormatting _) = True +isServerResponse (RspRename _) = True +isServerResponse (RspExecuteCommand _) = True +isServerResponse (RspError _) = True +isServerResponse (RspDocumentLink _) = True +isServerResponse (RspDocumentLinkResolve _) = True +isServerResponse (RspWillSaveWaitUntil _) = True +isServerResponse _ = False + +isServerRequest :: FromServerMessage -> Bool +isServerRequest (ReqRegisterCapability _) = True +isServerRequest (ReqApplyWorkspaceEdit _) = True +isServerRequest (ReqShowMessage _) = True +isServerRequest (ReqUnregisterCapability _) = True +isServerRequest _ = False + +isServerNotification :: FromServerMessage -> Bool +isServerNotification (NotPublishDiagnostics _) = True +isServerNotification (NotLogMessage _) = True +isServerNotification (NotShowMessage _) = True +isServerNotification (NotTelemetry _) = True +isServerNotification (NotCancelRequestFromServer _) = True +isServerNotification _ = False + +handleServerMessage + :: forall a. + (forall b c. RequestMessage ServerMethod b c -> a) + -> (forall d. ResponseMessage d -> a) + -> (forall e. NotificationMessage ServerMethod e -> a) + -> FromServerMessage + -> a +handleServerMessage request response notification msg = case msg of + (ReqRegisterCapability m) -> request m + (ReqApplyWorkspaceEdit m) -> request m + (ReqShowMessage m) -> request m + (ReqUnregisterCapability m) -> request m + (RspInitialize m) -> response m + (RspShutdown m) -> response m + (RspHover m) -> response m + (RspCompletion m) -> response m + (RspCompletionItemResolve m) -> response m + (RspSignatureHelp m) -> response m + (RspDefinition m) -> response m + (RspFindReferences m) -> response m + (RspDocumentHighlights m) -> response m + (RspDocumentSymbols m) -> response m + (RspWorkspaceSymbols m) -> response m + (RspCodeAction m) -> response m + (RspCodeLens m) -> response m + (RspCodeLensResolve m) -> response m + (RspDocumentFormatting m) -> response m + (RspDocumentRangeFormatting m) -> response m + (RspDocumentOnTypeFormatting m) -> response m + (RspRename m) -> response m + (RspExecuteCommand m) -> response m + (RspError m) -> response m + (RspDocumentLink m) -> response m + (RspDocumentLinkResolve m) -> response m + (RspWillSaveWaitUntil m) -> response m + (NotPublishDiagnostics m) -> notification m + (NotLogMessage m) -> notification m + (NotShowMessage m) -> notification m + (NotTelemetry m) -> notification m + (NotCancelRequestFromServer m) -> notification m + +handleClientMessage + :: forall a. + (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a) + -> (forall d . ToJSON d => ResponseMessage d -> a) + -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a) + -> FromClientMessage + -> a +handleClientMessage request response notification msg = case msg of + (ReqInitialize m) -> request m + (ReqShutdown m) -> request m + (ReqHover m) -> request m + (ReqCompletion m) -> request m + (ReqCompletionItemResolve m) -> request m + (ReqSignatureHelp m) -> request m + (ReqDefinition m) -> request m + (ReqFindReferences m) -> request m + (ReqDocumentHighlights m) -> request m + (ReqDocumentSymbols m) -> request m + (ReqWorkspaceSymbols m) -> request m + (ReqCodeAction m) -> request m + (ReqCodeLens m) -> request m + (ReqCodeLensResolve m) -> request m + (ReqDocumentFormatting m) -> request m + (ReqDocumentRangeFormatting m) -> request m + (ReqDocumentOnTypeFormatting m) -> request m + (ReqRename m) -> request m + (ReqExecuteCommand m) -> request m + (ReqDocumentLink m) -> request m + (ReqDocumentLinkResolve m) -> request m + (ReqWillSaveWaitUntil m) -> request m + (RspApplyWorkspaceEdit m) -> response m + (RspFromClient m) -> response m + (NotInitialized m) -> notification m + (NotExit m) -> notification m + (NotCancelRequestFromClient m) -> notification m + (NotDidChangeConfiguration m) -> notification m + (NotDidOpenTextDocument m) -> notification m + (NotDidChangeTextDocument m) -> notification m + (NotDidCloseTextDocument m) -> notification m + (NotWillSaveTextDocument m) -> notification m + (NotDidSaveTextDocument m) -> notification m + (NotDidChangeWatchedFiles m) -> notification m + (UnknownFromClientMessage m) -> error $ "Unknown message sent from client: " ++ show m diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Haskell.LSP.Test.Parsing + ( -- $receiving + message + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + , responseForId + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Conduit.Parser +import Data.Maybe +import qualified Data.Text as T +import Data.Typeable +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types as LSP hiding (error, message) +import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Session + +-- $receiving +-- To receive a message, just specify the type that expect: +-- +-- @ +-- msg1 <- message :: Session ApplyWorkspaceEditRequest +-- msg2 <- message :: Session HoverResponse +-- @ +-- +-- 'Language.Haskell.LSP.Test.Session' is actually just a parser +-- that operates on messages under the hood. This means that you +-- can create and combine parsers to match speicifc sequences of +-- messages that you expect. +-- +-- For example, if you wanted to match either a definition or +-- references request: +-- +-- > defOrImpl = (message :: Session DefinitionRequest) +-- > <|> (message :: Session ReferencesRequest) +-- +-- If you wanted to match any number of telemetry +-- notifications immediately followed by a response: +-- +-- @ +-- logThenDiags = +-- skipManyTill (message :: Session TelemetryNotification) +-- anyResponse +-- @ + +satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage +satisfy pred = do + + skipTimeout <- overridingTimeout <$> get + timeoutId <- curTimeoutId <$> get + unless skipTimeout $ do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + void $ liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + writeChan chan (TimeoutMessage timeoutId) + + x <- await + + unless skipTimeout $ + modify $ \s -> s { curTimeoutId = timeoutId + 1 } + + modify $ \s -> s { lastReceivedMessage = Just x } + + if pred x + then do + logMsg LogServer x + return x + else empty + +-- | Matches a message of type 'a'. +message :: forall a. (Typeable a, FromJSON a) => Session a +message = + let parser = decode . encodeMsg :: FromServerMessage -> Maybe a + in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ + castMsg <$> satisfy (isJust . parser) + +-- | Matches if the message is a notification. +anyNotification :: Session FromServerMessage +anyNotification = named "Any notification" $ satisfy isServerNotification + +-- | Matches if the message is a request. +anyRequest :: Session FromServerMessage +anyRequest = named "Any request" $ satisfy isServerRequest + +-- | Matches if the message is a response. +anyResponse :: Session FromServerMessage +anyResponse = named "Any response" $ satisfy isServerResponse + +-- | Matches a response for a specific id. +responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) +responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do + let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) + x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) + return $ castMsg x + +-- | Matches any type of message. +anyMessage :: Session FromServerMessage +anyMessage = satisfy (const True) + +-- | A stupid method for getting out the inner message. +castMsg :: FromJSON a => FromServerMessage -> a +castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg + +-- | A version of encode that encodes FromServerMessages as if they +-- weren't wrapped. +encodeMsg :: FromServerMessage -> B.ByteString +encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) + +-- | Matches if the message is a log message notification or a show message notification/request. +loggingNotification :: Session FromServerMessage +loggingNotification = named "Logging notification" $ satisfy shouldSkip + where + shouldSkip (NotLogMessage _) = True + shouldSkip (NotShowMessage _) = True + shouldSkip (ReqShowMessage _) = True + shouldSkip _ = False + +-- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' +-- (textDocument/publishDiagnostics) notification. +publishDiagnosticsNotification :: Session PublishDiagnosticsNotification +publishDiagnosticsNotification = named "Publish diagnostics notification" $ do + NotPublishDiagnostics diags <- satisfy test + return diags + where test (NotPublishDiagnostics _) = True + test _ = False diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -0,0 +1,232 @@ +-- | A testing tool for replaying captured client logs back to a server, +-- and validating that the server output matches up with another log. +module Language.Haskell.LSP.Test.Replay + ( replaySession + ) +where + +import Prelude hiding (id) +import Control.Concurrent +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as T +import Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types as LSP hiding (error) +import Data.Aeson +import Data.Default +import Data.List +import Data.Maybe +import Control.Lens hiding (List) +import Control.Monad +import System.FilePath +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Files +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Server +import Language.Haskell.LSP.Test.Session + + +-- | Replays a captured client output and +-- makes sure it matches up with an expected response. +-- The session directory should have a captured session file in it +-- named "session.log". +replaySession :: String -- ^ The command to run the server. + -> FilePath -- ^ The recorded session directory. + -> IO () +replaySession serverExe sessionDir = do + + entries <- B.lines <$> B.readFile (sessionDir "session.log") + + -- decode session + let unswappedEvents = map (fromJust . decode) entries + + withServer serverExe False $ \serverIn serverOut pid -> do + + events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents + + let clientEvents = filter isClientMsg events + serverEvents = filter isServerMsg events + clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents + serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents + requestMap = getRequestMap clientMsgs + + reqSema <- newEmptyMVar + rspSema <- newEmptyMVar + passSema <- newEmptyMVar + mainThread <- myThreadId + + sessionThread <- liftIO $ forkIO $ + runSessionWithHandles serverIn + serverOut + (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) + def + fullCaps + sessionDir + (sendMessages clientMsgs reqSema rspSema) + takeMVar passSema + killThread sessionThread + + where + isClientMsg (FromClient _ _) = True + isClientMsg _ = False + + isServerMsg (FromServer _ _) = True + isServerMsg _ = False + +sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () +sendMessages [] _ _ = return () +sendMessages (nextMsg:remainingMsgs) reqSema rspSema = + handleClientMessage request response notification nextMsg + where + -- TODO: May need to prevent premature exit notification being sent + notification msg@(NotificationMessage _ Exit _) = do + liftIO $ putStrLn "Will send exit notification soon" + liftIO $ threadDelay 10000000 + sendMessage msg + + liftIO $ error "Done" + + notification msg@(NotificationMessage _ m _) = do + sendMessage msg + + liftIO $ putStrLn $ "Sent a notification " ++ show m + + sendMessages remainingMsgs reqSema rspSema + + request msg@(RequestMessage _ id m _) = do + sendRequestMessage msg + liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" + + rsp <- liftIO $ takeMVar rspSema + when (responseId id /= rsp) $ + error $ "Expected id " ++ show id ++ ", got " ++ show rsp + + sendMessages remainingMsgs reqSema rspSema + + response msg@(ResponseMessage _ id _ _) = do + liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server" + reqId <- liftIO $ takeMVar reqSema + if responseId reqId /= id + then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId + else do + sendResponse msg + liftIO $ putStrLn $ "Sent response to request id " ++ show id + + sendMessages remainingMsgs reqSema rspSema + +sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () +sendRequestMessage req = do + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method) + + sendMessage req + + +isNotification :: FromServerMessage -> Bool +isNotification (NotPublishDiagnostics _) = True +isNotification (NotLogMessage _) = True +isNotification (NotShowMessage _) = True +isNotification (NotCancelRequestFromServer _) = True +isNotification _ = False + +-- listenServer :: [FromServerMessage] +-- -> RequestMap +-- -> MVar LspId +-- -> MVar LspIdRsp +-- -> MVar () +-- -> ThreadId +-- -> Handle +-- -> SessionContext +-- -> IO () +listenServer [] _ _ _ passSema _ _ _ = putMVar passSema () +listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do + + msgBytes <- getNextMessage serverOut + let msg = decodeFromServerMsg reqMap msgBytes + + handleServerMessage request response notification msg + + if shouldSkip msg + then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx + else if inRightOrder msg expectedMsgs + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx + else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs + ++ [head $ dropWhile isNotification expectedMsgs] + exc = ReplayOutOfOrder msg remainingMsgs + in liftIO $ throwTo mainThreadId exc + + where + response :: ResponseMessage a -> IO () + response res = do + putStrLn $ "Got response for id " ++ show (res ^. id) + + putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request + + request :: RequestMessage ServerMethod a b -> IO () + request req = do + putStrLn + $ "Got request for id " + ++ show (req ^. id) + ++ " " + ++ show (req ^. method) + + putMVar reqSema (req ^. id) -- unblock the handler waiting for a response + + notification :: NotificationMessage ServerMethod a -> IO () + notification n = putStrLn $ "Got notification " ++ show (n ^. method) + + + +-- TODO: QuickCheck tests? +-- | Checks wether or not the message appears in the right order +-- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @ +-- given N2, notification order doesn't matter. +-- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @ +-- given REQ1 +-- @ N1 N3 N4 N5 REQ2 RES1 @ +-- given RES1 +-- @ N1 N3 N4 N5 XXXX RES1 @ False! +-- Order of requests and responses matter +inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool + +inRightOrder _ [] = error "Why is this empty" + +inRightOrder received (expected : msgs) + | received == expected = True + | isNotification expected = inRightOrder received msgs + | otherwise = False + +-- | Ignore logging notifications since they vary from session to session +shouldSkip :: FromServerMessage -> Bool +shouldSkip (NotLogMessage _) = True +shouldSkip (NotShowMessage _) = True +shouldSkip (ReqShowMessage _) = True +shouldSkip _ = False + +-- | Swaps out any commands uniqued with process IDs to match the specified process ID +swapCommands :: Int -> [Event] -> [Event] +swapCommands _ [] = [] + +swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs + where swapped = params . command .~ newCmd $ req + newCmd = swapPid pid (req ^. params . command) + +swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs + where swapped = case newCommands of + Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp + Nothing -> rsp + oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands + newCommands = fmap (fmap (swapPid pid)) oldCommands + +swapCommands pid (x:xs) = x:swapCommands pid xs + +hasPid :: T.Text -> Bool +hasPid = (>= 2) . T.length . T.filter (':' ==) +swapPid :: Int -> T.Text -> T.Text +swapPid pid t + | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t + | otherwise = t diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -0,0 +1,28 @@ +module Language.Haskell.LSP.Test.Server (withServer) where + +import Control.Concurrent +import Control.Monad +import Language.Haskell.LSP.Test.Compat +import System.IO +import System.Process + +withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a +withServer serverExe logStdErr f = do + -- TODO Probably should just change runServer to accept + -- separate command and arguments + let cmd:args = words serverExe + createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc + + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering serverErr NoBuffering + errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn + + pid <- getProcessID serverProc + + result <- f serverIn serverOut pid + + killThread errSinkThread + terminateProcess serverProc + return result diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.Haskell.LSP.Test.Session + ( Session + , SessionConfig(..) + , defaultConfig + , SessionMessage(..) + , SessionContext(..) + , SessionState(..) + , runSessionWithHandles + , get + , put + , modify + , modifyM + , ask + , asks + , sendMessage + , updateState + , withTimeout + , logMsg + , LogMsgType(..) + ) + +where + +import Control.Concurrent hiding (yield) +import Control.Exception +import Control.Lens hiding (List) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Except +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Control.Monad.Trans.Reader as Reader (ask) +import Control.Monad.Trans.State (StateT, runStateT) +import qualified Control.Monad.Trans.State as State (get, put) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Conduit as Conduit +import Data.Conduit.Parser as Parser +import Data.Default +import Data.Foldable +import Data.List +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import Data.Function +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types.Capabilities +import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Exceptions +import System.Console.ANSI +import System.Directory +import System.IO + +-- | A session representing one instance of launching and connecting to a server. +-- +-- You can send and receive messages to the server within 'Session' via 'getMessage', +-- 'sendRequest' and 'sendNotification'. +-- + +type Session = ParserStateReader FromServerMessage SessionState SessionContext IO + +-- | Stuff you can configure for a 'Session'. +data SessionConfig = SessionConfig + { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60. + , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False. + , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to True. + , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. + } + +-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. +defaultConfig :: SessionConfig +defaultConfig = SessionConfig 60 False True True + +instance Default SessionConfig where + def = defaultConfig + +data SessionMessage = ServerMessage FromServerMessage + | TimeoutMessage Int + deriving Show + +data SessionContext = SessionContext + { + serverIn :: Handle + , rootDir :: FilePath + , messageChan :: Chan SessionMessage + , requestMap :: MVar RequestMap + , initRsp :: MVar InitializeResponse + , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities + } + +class Monad m => HasReader r m where + ask :: m r + asks :: (r -> b) -> m b + asks f = f <$> ask + +instance Monad m => HasReader r (ParserStateReader a s r m) where + ask = lift $ lift Reader.ask + +instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where + ask = lift $ lift Reader.ask + +data SessionState = SessionState + { + curReqId :: LspId + , vfs :: VFS + , curDiagnostics :: Map.Map Uri [Diagnostic] + , curTimeoutId :: Int + , overridingTimeout :: Bool + -- ^ The last received message from the server. + -- Used for providing exception information + , lastReceivedMessage :: Maybe FromServerMessage + } + +class Monad m => HasState s m where + get :: m s + + put :: s -> m () + + modify :: (s -> s) -> m () + modify f = get >>= put . f + + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put + +instance Monad m => HasState s (ParserStateReader a s r m) where + get = lift State.get + put = lift . State.put + +instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) + where + get = lift State.get + put = lift . State.put + +type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) + +runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession context state session = runReaderT (runStateT conduit state) context + where + conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) + + handler (Unexpected "ConduitParser.empty") = do + lastMsg <- fromJust . lastReceivedMessage <$> get + name <- getParserName + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) + + handler e = throw e + + chanSource = do + msg <- liftIO $ readChan (messageChan context) + yield msg + chanSource + + watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog = Conduit.awaitForever $ \msg -> do + curId <- curTimeoutId <$> get + case msg of + ServerMessage sMsg -> yield sMsg + TimeoutMessage tId -> when (curId == tId) $ throw Timeout + +-- | An internal version of 'runSession' that allows for a custom handler to listen to the server. +-- It also does not automatically send initialize and exit messages. +runSessionWithHandles :: Handle -- ^ Server in + -> Handle -- ^ Server out + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener + -> SessionConfig + -> ClientCapabilities + -> FilePath -- ^ Root directory + -> Session a + -> IO a +runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do + absRootDir <- canonicalizePath rootDir + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering + + reqMap <- newMVar newRequestMap + messageChan <- newChan + initRsp <- newEmptyMVar + + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps + initState = SessionState (IdInt 0) mempty mempty 0 False Nothing + + threadId <- forkIO $ void $ serverHandler serverOut context + (result, _) <- runSession context initState session + + killThread threadId + + return result + +updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC = awaitForever $ \msg -> do + updateState msg + yield msg + +updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () +updateState (NotPublishDiagnostics n) = do + let List diags = n ^. params . diagnostics + doc = n ^. params . uri + modify (\s -> + let newDiags = Map.insert doc diags (curDiagnostics s) + in s { curDiagnostics = newDiags }) + +updateState (ReqApplyWorkspaceEdit r) = do + + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs + return $ map getParams cs + Nothing -> case r ^. params . edit . changes of + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> error "No changes!" + + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } + + let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams + mergedParams = map mergeParams groupedParams + + -- TODO: Don't do this when replaying a session + forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + + -- Update VFS to new document versions + let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams + latestVersions = map ((^. textDocument) . last) sortedVersions + bumpedVersions = map (version . _Just +~ 1) latestVersions + + forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + modify $ \s -> + let oldVFS = vfs s + update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t + newVFS = Map.adjust update uri oldVFS + in s { vfs = newVFS } + + where checkIfNeedsOpened uri = do + oldVFS <- vfs <$> get + ctx <- ask + + -- if its not open, open it + unless (uri `Map.member` oldVFS) $ do + let fp = fromJust $ uriToFilePath uri + contents <- liftIO $ T.readFile fp + let item = TextDocumentItem (filePathToUri fp) "" 0 contents + msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) + + modifyM $ \s -> do + newVFS <- liftIO $ openVFS (vfs s) msg + return $ s { vfs = newVFS } + + getParams (TextDocumentEdit docId (List edits)) = + let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits + in DidChangeTextDocumentParams docId (List changeEvents) + + textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..] + + textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits + + getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits)) + + mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams + mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) + in DidChangeTextDocumentParams (head params ^. textDocument) (List events) +updateState _ = return () + +sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () +sendMessage msg = do + h <- serverIn <$> ask + logMsg LogClient msg + liftIO $ B.hPut h (addHeader $ encode msg) + +-- | Execute a block f that will throw a 'TimeoutException' +-- after duration seconds. This will override the global timeout +-- for waiting for messages to arrive defined in 'SessionConfig'. +withTimeout :: Int -> Session a -> Session a +withTimeout duration f = do + chan <- asks messageChan + timeoutId <- curTimeoutId <$> get + modify $ \s -> s { overridingTimeout = True } + liftIO $ forkIO $ do + threadDelay (duration * 1000000) + writeChan chan (TimeoutMessage timeoutId) + res <- f + modify $ \s -> s { curTimeoutId = timeoutId + 1, + overridingTimeout = False + } + return res + +data LogMsgType = LogServer | LogClient + deriving Eq + +-- | Logs the message if the config specified it +logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m) + => LogMsgType -> a -> m () +logMsg t msg = do + shouldLog <- asks $ logMessages . config + shouldColor <- asks $ logColor . config + liftIO $ when shouldLog $ do + when shouldColor $ setSGR [SetColor Foreground Dull color] + putStrLn $ arrow ++ showPretty msg + when shouldColor $ setSGR [Reset] + + where arrow + | t == LogServer = "<-- " + | otherwise = "--> " + color + | t == LogServer = Magenta + | otherwise = Cyan + + showPretty = B.unpack . encodePretty diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +import Test.Hspec +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import qualified Data.Text as T +import Control.Applicative.Combinators +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad +import Control.Lens hiding (List) +import GHC.Generics +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Replay +import Language.Haskell.LSP.Types.Capabilities +import Language.Haskell.LSP.Types as LSP hiding (capabilities, message) +import System.Timeout + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} + +main = hspec $ do + describe "Session" $ do + it "fails a test" $ + -- TODO: Catch the exception in haskell-lsp-test and provide nicer output + let session = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + skipMany loggingNotification + anyRequest + in session `shouldThrow` anyException + it "initializeResponse" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + rsp <- initializeResponse + liftIO $ rsp ^. result `shouldNotBe` Nothing + + it "runSessionWithConfig" $ + runSession "hie --lsp" didChangeCaps "test/data/renamePass" $ return () + + describe "withTimeout" $ do + it "times out" $ + let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + -- won't receive a request - will timeout + -- incoming logging requests shouldn't increase the + -- timeout + withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + -- wait just a bit longer than 5 seconds so we have time + -- to open the document + in timeout 6000000 sesh `shouldThrow` anySessionException + + it "doesn't time out" $ + let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification + in void $ timeout 6000000 sesh + + it "further timeout messages are ignored" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + withTimeout 3 $ getDocumentSymbols doc + liftIO $ threadDelay 5000000 + -- shouldn't throw an exception + getDocumentSymbols doc + return () + + it "overrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- shouldn't time out in here since we are overriding it + withTimeout 10 $ liftIO $ threadDelay 7000000 + getDocumentSymbols doc + return True + in sesh `shouldReturn` True + + it "unoverrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- shouldn't time out in here since we are overriding it + withTimeout 10 $ liftIO $ threadDelay 7000000 + getDocumentSymbols doc + -- should now timeout + skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + in sesh `shouldThrow` (== Timeout) + + + describe "SessionException" $ do + it "throw on time out" $ + let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" fullCaps "test/data/renamePass" $ do + skipMany loggingNotification + _ <- message :: Session ApplyWorkspaceEditRequest + return () + in sesh `shouldThrow` anySessionException + + it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" fullCaps "test/data/renamePass" $ do + loggingNotification + liftIO $ threadDelay 10 + _ <- openDoc "Desktop/simple.hs" "haskell" + return () + + describe "UnexpectedMessageException" $ do + it "throws when there's an unexpected message" $ + let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True + selector _ = False + in runSession "hie --lsp" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector + it "provides the correct types that were expected and received" $ + let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + selector _ = False + sesh = do + doc <- openDoc "Desktop/simple.hs" "haskell" + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + skipMany anyNotification + message :: Session RenameResponse -- the wrong type + in runSession "hie --lsp" fullCaps "test/data/renamePass" sesh + `shouldThrow` selector + + describe "replaySession" $ do + it "passes a test" $ + replaySession "hie --lsp" "test/data/renamePass" + it "fails a test" $ + let selector (ReplayOutOfOrder _ _) = True + selector _ = False + in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector + + describe "manual javascript session" $ + it "passes a test" $ + runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + doc <- openDoc "test.js" "javascript" + + noDiagnostics + + (fooSymbol:_) <- getDocumentSymbols doc + + liftIO $ do + fooSymbol ^. name `shouldBe` "foo" + fooSymbol ^. kind `shouldBe` SkFunction + + describe "text document VFS" $ + it "sends back didChange notifications" $ + runSession "hie --lsp" def "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + + let args = toJSON $ AOP (doc ^. uri) + (Position 1 14) + "Redundant bracket" + reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) + request_ WorkspaceExecuteCommand reqParams + + editReq <- message :: Session ApplyWorkspaceEditRequest + liftIO $ do + let (Just cs) = editReq ^. params . edit . changes + [(u, List es)] = HM.toList cs + u `shouldBe` doc ^. uri + es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"] + + noDiagnostics + + contents <- documentContents doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" + + describe "getDocumentEdit" $ + it "automatically consumes applyedit requests" $ + runSession "hie --lsp" fullCaps "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + + let args = toJSON $ AOP (doc ^. uri) + (Position 1 14) + "Redundant bracket" + reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) + request_ WorkspaceExecuteCommand reqParams + contents <- getDocumentEdit doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" + noDiagnostics + + describe "getAllCodeActions" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + _ <- waitForDiagnostics + actions <- getAllCodeActions doc + liftIO $ do + let [CommandOrCodeActionCodeAction action] = actions + action ^. title `shouldBe` "Apply hint:Redundant bracket" + action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne" + + describe "getDocumentSymbols" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + + skipMany loggingNotification + + noDiagnostics + + (mainSymbol:_) <- getDocumentSymbols doc + + liftIO $ do + mainSymbol ^. name `shouldBe` "main" + mainSymbol ^. kind `shouldBe` SkFunction + mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) + mainSymbol ^. containerName `shouldBe` Nothing + + describe "applyEdit" $ do + it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc + let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" + VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit + liftIO $ newVersion `shouldBe` oldVersion + 1 + it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" + applyEdit doc edit + contents <- documentContents doc + liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" + + describe "getCompletions" $ + it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + item:_ <- getCompletions doc (Position 5 5) + liftIO $ do + item ^. label `shouldBe` "interactWithUser" + item ^. kind `shouldBe` Just CiFunction + item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + + describe "getReferences" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let pos = Position 40 3 -- interactWithUser + uri = doc ^. LSP.uri + refs <- getReferences doc pos True + liftIO $ refs `shouldContain` map (Location uri) [ + mkRange 41 0 41 16 + , mkRange 75 6 75 22 + , mkRange 71 6 71 22 + ] + + describe "getDefinitions" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let pos = Position 49 25 -- addItem + defs <- getDefinitions doc pos + liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] + + describe "waitForDiagnosticsSource" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do + openDoc "Error.hs" "haskell" + [diag] <- waitForDiagnosticsSource "ghcmod" + liftIO $ do + diag ^. severity `shouldBe` Just DsError + diag ^. source `shouldBe` Just "ghcmod" + + describe "rename" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do + doc <- openDoc "Rename.hs" "haskell" + rename doc (Position 1 0) "bar" + documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n" + + describe "getHover" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- hover returns nothing until module is loaded + skipManyTill loggingNotification $ count 2 noDiagnostics + hover <- getHover doc (Position 45 9) -- putStrLn + liftIO $ hover `shouldSatisfy` isJust + + describe "getHighlights" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + skipManyTill loggingNotification $ count 2 noDiagnostics + highlights <- getHighlights doc (Position 27 4) -- addItem + liftIO $ length highlights `shouldBe` 4 + + describe "formatDoc" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do + doc <- openDoc "Format.hs" "haskell" + oldContents <- documentContents doc + formatDoc doc (FormattingOptions 4 True) + documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + + describe "formatRange" $ + it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do + doc <- openDoc "Format.hs" "haskell" + oldContents <- documentContents doc + formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10)) + documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + + describe "closeDoc" $ + it "works" $ + let sesh = + runSession "hie --lsp" fullCaps "test/data" $ do + doc <- openDoc "Format.hs" "haskell" + closeDoc doc + -- need to evaluate to throw + documentContents doc >>= liftIO . print + in sesh `shouldThrow` anyException + +mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + +didChangeCaps :: ClientCapabilities +didChangeCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _didChangeConfiguration = Just configCaps } + configCaps = DidChangeConfigurationClientCapabilities (Just True) + +docChangesCaps :: ClientCapabilities +docChangesCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _workspaceEdit = Just editCaps } + editCaps = WorkspaceEditClientCapabilities (Just True) + +data ApplyOneParams = AOP + { file :: Uri + , start_pos :: Position + , hintTitle :: String + } deriving (Generic, ToJSON)