diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for lsp-client + +## 0.1.0.0 -- 2023-06-20 + +* First version. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# lsp-client + +lsp-client is a Language Server Protocol client. + +Notably, it does not use `conduit` to parse incoming messages, but +instead exposes a truly concurrent session, in which messages can be +sent and received asynchronously. + +It is part of the [lsp](https://github.com/haskell/lsp) family of +packages, along with [lsp](https://hackage.haskell.org/package/lsp) +and [lsp-types](https://hackage.haskell.org/package/lsp-types). diff --git a/lsp-client.cabal b/lsp-client.cabal new file mode 100644 --- /dev/null +++ b/lsp-client.cabal @@ -0,0 +1,99 @@ +cabal-version: 3.0 +name: lsp-client +version: 0.1.0.0 +synopsis: Haskell library for Language Server Protocol clients +homepage: https://github.com/ners/lsp-client/blob/master/README.md +license: Apache-2.0 +license-file: LICENCE +author: ners +maintainer: ners@gmx.ch +bug-reports: https://github.com/ners/lsp-client/issues +category: System +build-type: Simple +extra-source-files: ChangeLog.md, README.md + +source-repository head + type: git + location: https://github.com/ners/lsp-client + +common common + default-language: GHC2021 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-missing-safe-haskell-mode + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-all-missed-specialisations + default-extensions: + ApplicativeDo + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExplicitNamespaces + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RecordWildCards + RecursiveDo + TypeFamilies + ViewPatterns + build-depends: + aeson >= 2.0 && < 3, + base >= 4.16 && < 5, + bytestring, + lens >= 5.0, + lsp-types >= 1.6.0.0, + unliftio >= 0.2, + +library + import: common + hs-source-dirs: src + build-depends: + Diff, + Glob, + aeson-pretty, + co-log-core, + data-default, + dependent-map, + directory, + filepath, + generic-lens, + hashable, + lsp, + mtl, + stm, + text, + text-rope, + unordered-containers, + if os(windows) + build-depends: Win32 + else + build-depends: unix + exposed-modules: + Language.LSP.Client, + Language.LSP.Client.Compat, + Language.LSP.Client.Decoding, + Language.LSP.Client.Encoding, + Language.LSP.Client.Exceptions, + Language.LSP.Client.Session, + +test-suite spec + import: common + ghc-options: -threaded + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + QuickCheck, + extra, + hspec, + lsp-client, + process, + other-modules: + Language.LSP.ClientSpec diff --git a/src/Language/LSP/Client.hs b/src/Language/LSP/Client.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client.hs @@ -0,0 +1,128 @@ +{- | +This module provides utilities to run an LSP `Session` in `IO`. +-} +module Language.LSP.Client where + +import Control.Concurrent.STM +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (asks, runReaderT) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Dependent.Map qualified as DMap +import Data.Either (fromLeft) +import Data.Generics.Labels () +import Language.LSP.Client.Decoding +import Language.LSP.Client.Encoding (encode) +import Language.LSP.Client.Session +import Language.LSP.Types (From, Method, MethodType, SMethod (..)) +import Language.LSP.Types qualified as LSP +import Language.LSP.VFS (initVFS) +import System.IO (Handle, stdin, stdout) +import UnliftIO (concurrently_, race) +import Prelude + +{- | Starts a new session, using the specified handles to communicate with the +server. +-} +runSessionWithHandles + :: Handle + -- ^ The input handle: messages sent from the server to the client will be read from here + -> Handle + -- ^ The output handle: messages sent by the client will be written here + -> Session a + -- ^ Session actions + -> IO a +runSessionWithHandles input output action = initVFS $ \vfs -> do + initialState <- defaultSessionState vfs + flip runReaderT initialState $ do + actionResult <- race action $ do + let send = do + message <- asks outgoing >>= liftIO . atomically . readTQueue + liftIO $ LazyByteString.hPut output $ encode message + let receive = do + serverBytes <- liftIO $ getNextMessage input + (serverMessage, requestCallback) <- + asks pendingRequests + >>= liftIO . atomically . flip stateTVar (decodeFromServerMsg serverBytes) + handleServerMessage serverMessage + liftIO requestCallback + case serverMessage of + LSP.FromServerMess smethod msg -> case methodType smethod of + Notification -> do + handlers :: NotificationMap <- asks notificationHandlers >>= liftIO . readTVarIO + let NotificationCallback cb = DMap.findWithDefault (NotificationCallback (const $ pure ())) smethod handlers + liftIO $ cb msg + _ -> pure () + _ -> pure () + concurrently_ (forever send) (forever receive) + pure $ fromLeft (error "runSessionWithHandle: send/receive thread should not exit") actionResult + +data SMethodType (t :: MethodType) where + Notification :: SMethodType 'LSP.Notification + Request :: SMethodType 'LSP.Request + +methodType :: forall (f :: From) (t :: MethodType) (m :: Method f t). SMethod m -> SMethodType t +methodType SInitialize = Request +methodType SInitialized = Notification +methodType SShutdown = Request +methodType SExit = Notification +methodType SWorkspaceDidChangeWorkspaceFolders = Notification +methodType SWorkspaceDidChangeConfiguration = Notification +methodType SWorkspaceDidChangeWatchedFiles = Notification +methodType SWorkspaceSymbol = Request +methodType SWorkspaceExecuteCommand = Request +methodType STextDocumentDidOpen = Notification +methodType STextDocumentDidChange = Notification +methodType STextDocumentWillSave = Notification +methodType STextDocumentWillSaveWaitUntil = Request +methodType STextDocumentDidSave = Notification +methodType STextDocumentDidClose = Notification +methodType STextDocumentCompletion = Request +methodType SCompletionItemResolve = Request +methodType STextDocumentHover = Request +methodType STextDocumentSignatureHelp = Request +methodType STextDocumentDeclaration = Request +methodType STextDocumentDefinition = Request +methodType STextDocumentTypeDefinition = Request +methodType STextDocumentImplementation = Request +methodType STextDocumentReferences = Request +methodType STextDocumentDocumentHighlight = Request +methodType STextDocumentDocumentSymbol = Request +methodType STextDocumentCodeAction = Request +methodType STextDocumentCodeLens = Request +methodType SCodeLensResolve = Request +methodType STextDocumentDocumentLink = Request +methodType SDocumentLinkResolve = Request +methodType STextDocumentDocumentColor = Request +methodType STextDocumentColorPresentation = Request +methodType STextDocumentFormatting = Request +methodType STextDocumentRangeFormatting = Request +methodType STextDocumentOnTypeFormatting = Request +methodType STextDocumentRename = Request +methodType STextDocumentPrepareRename = Request +methodType STextDocumentFoldingRange = Request +methodType STextDocumentSelectionRange = Request +methodType STextDocumentPrepareCallHierarchy = Request +methodType SCallHierarchyIncomingCalls = Request +methodType SCallHierarchyOutgoingCalls = Request +methodType STextDocumentSemanticTokens = Request +methodType STextDocumentSemanticTokensFull = Request +methodType STextDocumentSemanticTokensFullDelta = Request +methodType STextDocumentSemanticTokensRange = Request +methodType SWindowShowMessage = Notification +methodType SWindowShowMessageRequest = Request +methodType SWindowShowDocument = Request +methodType SWindowLogMessage = Notification +methodType SWindowWorkDoneProgressCancel = Notification +methodType SWindowWorkDoneProgressCreate = Request +methodType SProgress = Notification +methodType STelemetryEvent = Notification +methodType SClientRegisterCapability = Request +methodType SClientUnregisterCapability = Request +methodType SWorkspaceWorkspaceFolders = Request +methodType SWorkspaceConfiguration = Request +methodType SWorkspaceApplyEdit = Request +methodType SWorkspaceSemanticTokensRefresh = Request +methodType STextDocumentPublishDiagnostics = Notification +methodType SCancelRequest = Notification +methodType (SCustomMethod _) = undefined diff --git a/src/Language/LSP/Client/Compat.hs b/src/Language/LSP/Client/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client/Compat.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +module Language.LSP.Client.Compat where + +import Language.LSP.Types +import Prelude + +#ifdef mingw32_HOST_OS +import System.Win32.Process qualified +#else +import System.Posix.Process qualified +#endif + +getCurrentProcessID :: IO Int +#ifdef mingw32_HOST_OS +getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessID +#else +getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID +#endif + +lspClientInfo :: ClientInfo +lspClientInfo = ClientInfo "lsp-client" (Just CURRENT_PACKAGE_VERSION) diff --git a/src/Language/LSP/Client/Decoding.hs b/src/Language/LSP/Client/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client/Decoding.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.LSP.Client.Decoding where + +import Control.Exception (catch, throw) +import Control.Monad (liftM2) +import Data.Aeson (Result (Error, Success), Value, decode) +import Data.Aeson.Types (parse) +import Data.ByteString.Lazy (LazyByteString) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Dependent.Map (DMap) +import Data.Dependent.Map qualified as DMap +import Data.Functor +import Data.Functor.Const +import Data.Functor.Product (Product (Pair)) +import Data.IxMap (IxMap) +import Data.IxMap qualified as IxMap +import Data.Maybe (fromJust, fromMaybe) +import Language.LSP.Client.Exceptions +import Language.LSP.Types +import System.IO (Handle, hGetLine) +import System.IO.Error (isEOFError) +import Prelude hiding (id) + +{- | Fetches the next message bytes based on + the Content-Length header +-} +getNextMessage :: Handle -> IO LazyByteString +getNextMessage h = do + headers <- getHeaders h + case read . init <$> lookup "Content-Length" headers of + Nothing -> throw NoContentLengthHeader + Just size -> LazyByteString.hGet h size + +getHeaders :: Handle -> IO [(String, String)] +getHeaders h = do + l <- catch (hGetLine h) eofHandler + let (name, val) = span (/= ':') l + if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h + where + eofHandler :: IOError -> a + eofHandler e + | isEOFError e = throw UnexpectedServerTermination + | otherwise = throw e + +type RequestMap = IxMap LspId RequestCallback + +emptyRequestMap :: RequestMap +emptyRequestMap = IxMap.emptyIxMap + +data RequestCallback (m :: Method 'FromClient 'Request) = RequestCallback + { requestCallback :: ResponseMessage m -> IO () + , requestMethod :: SMethod m + } + +type NotificationMap = DMap SMethod NotificationCallback + +emptyNotificationMap :: NotificationMap +emptyNotificationMap = mempty + +newtype NotificationCallback (m :: Method 'FromServer 'Notification) = NotificationCallback + { notificationCallback :: Message m -> IO () + } + +instance Semigroup (NotificationCallback m) where + (NotificationCallback c1) <> (NotificationCallback c2) = NotificationCallback $ liftM2 (*>) c1 c2 + +instance Monoid (NotificationCallback m) where + mempty = NotificationCallback (const $ pure ()) + +updateRequestMap :: LspId m -> RequestCallback m -> RequestMap -> RequestMap +updateRequestMap = ((fromMaybe (error "updateRequestMap: duplicate key registration") .) .) . IxMap.insertIxMap + +appendNotificationCallback :: SMethod m -> NotificationCallback m -> NotificationMap -> NotificationMap +appendNotificationCallback = DMap.insertWith' (<>) + +removeNotificationCallback :: SMethod (m :: Method 'FromServer 'Notification) -> NotificationMap -> NotificationMap +removeNotificationCallback = DMap.delete + +decodeFromServerMsg :: LazyByteString -> RequestMap -> ((FromServerMessage, IO ()), RequestMap) +decodeFromServerMsg bytes reqMap = unP $ parse p obj + where + obj = fromJust $ decode bytes :: Value + p = parseServerMessage $ \(lid :: LspId m) -> + let (maybeCallback, newMap) = IxMap.pickFromIxMap lid reqMap + in maybeCallback <&> \c -> (c.requestMethod, Pair c (Const newMap)) + unP (Success (FromServerMess m msg)) = ((FromServerMess m msg, pure ()), reqMap) + unP (Success (FromServerRsp (Pair c (Const newMap)) msg)) = ((FromServerRsp c.requestMethod msg, c.requestCallback msg), newMap) + unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e diff --git a/src/Language/LSP/Client/Encoding.hs b/src/Language/LSP/Client/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client/Encoding.hs @@ -0,0 +1,20 @@ +module Language.LSP.Client.Encoding where + +import Data.Aeson (ToJSON) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy (LazyByteString) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Prelude + +addHeader :: LazyByteString -> LazyByteString +addHeader content = + mconcat + [ "Content-Length: " + , LazyByteString.pack $ show $ LazyByteString.length content + , "\r\n" + , "\r\n" + , content + ] + +encode :: ToJSON a => a -> LazyByteString +encode = addHeader . Aeson.encode diff --git a/src/Language/LSP/Client/Exceptions.hs b/src/Language/LSP/Client/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client/Exceptions.hs @@ -0,0 +1,80 @@ +module Language.LSP.Client.Exceptions where + +import Control.Exception (Exception) +import Data.Aeson (Value, encode) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Algorithm.Diff (getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.List (nub) +import Language.LSP.Types + ( FromServerMessage + , ResponseError + , SomeLspId + ) +import Prelude + +-- | An exception that can be thrown during a 'Language.LSP.Client.Session' +data SessionException + = Timeout (Maybe FromServerMessage) + | NoContentLengthHeader + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String + | UnexpectedResponseError SomeLspId ResponseError + | UnexpectedServerTermination + | IllegalInitSequenceMessage FromServerMessage + | MessageSendError Value IOError + deriving stock (Eq) + +instance Exception SessionException + +instance Show SessionException where + show (Timeout lastMsg) = + "Timed out waiting to receive a message from the server." + ++ case lastMsg of + Just msg -> "\nLast message received:\n" ++ LazyByteString.unpack (encodePretty msg) + Nothing -> mempty + show NoContentLengthHeader = "Couldn't read Content-Length header from the server." + show (UnexpectedMessage expected lastMsg) = + "Received an unexpected message from the server:\n" + ++ "Was parsing: " + ++ expected + ++ "\n" + ++ "But the last message received was:\n" + ++ LazyByteString.unpack (encodePretty lastMsg) + show (ReplayOutOfOrder received expected) = + let expected' = nub expected + getJsonDiff :: FromServerMessage -> [String] + getJsonDiff = lines . LazyByteString.unpack . encodePretty + showExp e = + LazyByteString.unpack (encodePretty e) + ++ "\nDiff:\n" + ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff e)) + in "Replay is out of order:\n" + ++ + -- Print json so its a bit easier to update the session logs + "Received from server:\n" + ++ LazyByteString.unpack (encodePretty received) + ++ "\n" + ++ "Raw from server:\n" + ++ LazyByteString.unpack (encode 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 expected error in a response for id " + ++ show lid + ++ ":\n" + ++ show e + show UnexpectedServerTermination = "Language server unexpectedly terminated" + show (IllegalInitSequenceMessage msg) = + "Received an illegal message between the initialize request and response:\n" + ++ LazyByteString.unpack (encodePretty msg) + show (MessageSendError msg e) = + "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ LazyByteString.unpack (encodePretty msg) diff --git a/src/Language/LSP/Client/Session.hs b/src/Language/LSP/Client/Session.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Client/Session.hs @@ -0,0 +1,476 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{-| +-} + +module Language.LSP.Client.Session where + +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..)) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM +import Control.Exception (throw) +import Control.Lens hiding (Empty, List) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (ReaderT, asks) +import Control.Monad.State (StateT, execState) +import Data.Default (def) +import Data.Foldable (foldl', foldr', forM_, toList) +import Data.Function (on) +import Data.Functor (void) +import Data.Generics.Labels () +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Hashable (Hashable) +import Data.List (groupBy, sortBy) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Data.Text.Utf16.Rope (Rope) +import GHC.Generics (Generic) +import Language.LSP.Client.Compat (getCurrentProcessID, lspClientInfo) +import Language.LSP.Client.Decoding +import Language.LSP.Client.Exceptions (SessionException (UnexpectedResponseError)) +import Language.LSP.Types +import Language.LSP.Types.Capabilities (ClientCapabilities, fullCaps) +import Language.LSP.Types.Lens hiding (applyEdit, capabilities, executeCommand, id, message, rename, to) +import Language.LSP.Types.Lens qualified as LSP +import Language.LSP.VFS + ( VFS + , VfsLog + , VirtualFile (..) + , changeFromClientVFS + , changeFromServerVFS + , closeVFS + , lsp_version + , openVFS + , vfsMap + , virtualFileVersion + ) +import System.Directory (canonicalizePath) +import System.FilePath (isAbsolute, ()) +import System.FilePath.Glob qualified as Glob +import Prelude + +deriving stock instance Generic ProgressToken + +deriving anyclass instance Hashable ProgressToken + +data SessionState = SessionState + { initialized :: TMVar InitializeResult + -- ^ The response of the initialization handshake, if any. + , pendingRequests :: TVar RequestMap + -- ^ Response callbacks for sent requests waiting for a response. Once a response arrives the request is removed from this map. + , notificationHandlers :: TVar NotificationMap + -- ^ Notification callbacks that fire whenever a notification of their type is received. + , lastRequestId :: TVar Int32 + -- ^ A counter to send each request to the server is sent with a unique ID, allowing us to pair it back with its response. + , serverCapabilities :: TVar (HashMap Text SomeRegistration) + -- ^ The capabilities that the server has dynamically registered with us so far. + , clientCapabilities :: ClientCapabilities + -- ^ The client capabilities advertised to the server. Not a `TVar` because it does not change during the session. + , progressTokens :: TVar (HashSet ProgressToken) + -- ^ Progress messages received from the server. + , outgoing :: TQueue FromClientMessage + -- ^ Messages that have been serialised but not yet written to the output handle. + , vfs :: TVar VFS + -- ^ Virtual, in-memory file system of the files known to the LSP. + , rootDir :: FilePath + -- ^ The root of the project as sent to the server. Document URIs are relative to it. Not a `TVar` because it does not change during the session. + } + +defaultSessionState :: VFS -> IO SessionState +defaultSessionState vfs' = do + initialized <- newEmptyTMVarIO + pendingRequests <- newTVarIO emptyRequestMap + notificationHandlers <- newTVarIO emptyNotificationMap + lastRequestId <- newTVarIO 0 + serverCapabilities <- newTVarIO mempty + progressTokens <- newTVarIO mempty + outgoing <- newTQueueIO + vfs <- newTVarIO vfs' + pure + SessionState + { rootDir = "." + , clientCapabilities = def + , .. + } + +-- | A session representing one instance of launching and connecting to a server. +-- It is essentially an STM-backed `StateT`: despite it being `ReaderT`, it can still +-- mutate `TVar` values. +type Session = ReaderT SessionState IO + +documentChangeUri :: DocumentChange -> Uri +documentChangeUri (InL x) = x ^. textDocument . uri +documentChangeUri (InR (InL x)) = x ^. uri +documentChangeUri (InR (InR (InL x))) = x ^. oldUri +documentChangeUri (InR (InR (InR x))) = x ^. uri + +-- | Fires whenever the client receives a message from the server. Updates the session state as needed. +-- Note that this does not provide any business logic beyond updating the session state; you most likely +-- want to use `sendRequest` and `receiveNotification` to register callbacks for specific messages. +handleServerMessage :: FromServerMessage -> Session () + +handleServerMessage (FromServerMess SProgress req) = do + let update = asks progressTokens >>= liftIO . flip modifyTVarIO (HashSet.insert $ req ^. params . token) + case req ^. params . value of + Begin{} -> update + End{} -> update + Report{} -> pure () + +handleServerMessage (FromServerMess SClientRegisterCapability req) = do + let List newRegs = req ^. params . registrations <&> \sr@(SomeRegistration r) -> (r ^. LSP.id, sr) + asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs)) + +handleServerMessage (FromServerMess SClientUnregisterCapability req) = do + let List unRegs = req ^. params . unregisterations <&> (^. LSP.id) + asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs) + +handleServerMessage (FromServerMess SWorkspaceApplyEdit r) = do + -- First, prefer the versioned documentChanges field + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . documentChangeUri) cs + -- replace the user provided version numbers with the VFS ones + 1 + -- (technically we should check that the user versions match the VFS ones) + cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs + return $ mapMaybe getParamsFromDocumentChange cs' + -- Then fall back to the changes field + Nothing -> case r ^. params . edit . changes of + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> + error "WorkspaceEdit contains neither documentChanges nor changes!" + + asks vfs >>= liftIO . flip modifyTVarIO (execState $ changeFromServerVFS logger r) + + let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams + mergedParams = mergeParams <$> groupedParams + + forM_ mergedParams (sendNotification STextDocumentDidChange) + + -- Update VFS to new document versions + let sortedVersions = sortBy (compare `on` (^. textDocument . version)) <$> groupedParams + latestVersions = (^. textDocument) . last <$> sortedVersions + + forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> + asks vfs + >>= liftIO + . flip + modifyTVarIO + ( \vfs -> do + let update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t + in vfs & vfsMap . ix (toNormalizedUri uri) %~ update + ) + sendResponse + r + $ Right + ApplyWorkspaceEditResponseBody + { _applied = True + , _failureReason = Nothing + , _failedChange = Nothing + } + where + logger :: LogAction (StateT VFS Identity) (WithSeverity VfsLog) + logger = LogAction $ \(WithSeverity msg sev) -> case sev of Error -> error $ show msg; _ -> pure () + checkIfNeedsOpened uri = do + isOpen <- asks vfs >>= liftIO . readTVarIO <&> has (vfsMap . ix (toNormalizedUri uri)) + + -- if its not open, open it + unless isOpen $ do + contents <- maybe (pure "") (liftIO . Text.readFile) (uriToFilePath uri) + sendNotification + STextDocumentDidOpen + DidOpenTextDocumentParams + { _textDocument = + TextDocumentItem + { _uri = uri + , _languageId = "" + , _version = 0 + , _text = contents + } + } + + getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams + getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do + DidChangeTextDocumentParams docId (List $ editToChangeEvent <$> edits) + + editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent + editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + + getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams + getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit + getParamsFromDocumentChange _ = Nothing + + bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = head <$> textDocumentVersions uri + + -- For a uri returns an infinite list of versions [n,n+1,n+2,...] + -- where n is the current version + textDocumentVersions :: Uri -> Session [VersionedTextDocumentIdentifier] + textDocumentVersions uri = do + vfs <- asks vfs >>= liftIO . readTVarIO + let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version + pure $ VersionedTextDocumentIdentifier uri . Just <$> [curVer + 1 ..] + + textDocumentEdits uri edits = do + vers <- textDocumentVersions uri + pure $ zipWith (\v e -> TextDocumentEdit v (List [InL e])) vers edits + + getChangeParams uri (List edits) = fmap getParamsFromTextDocumentEdit <$> textDocumentEdits uri (reverse edits) + + mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams + mergeParams params = + let events = concat $ toList $ toList . (^. contentChanges) <$> params + in DidChangeTextDocumentParams (head params ^. textDocument) (List events) + +handleServerMessage (FromServerMess SWindowWorkDoneProgressCreate req) = sendResponse req $ Right Empty + +handleServerMessage _ = pure () + +overTVar :: (a -> a) -> TVar a -> STM a +overTVar f var = stateTVar var (\x -> (f x, f x)) + +overTVarIO :: (a -> a) -> TVar a -> IO a +overTVarIO = (atomically .) . overTVar + +modifyTVarIO :: TVar a -> (a -> a) -> IO () +modifyTVarIO = (atomically .) . modifyTVar + +writeTVarIO :: TVar a -> a -> IO () +writeTVarIO = (atomically .) . writeTVar + +-- | Sends a request to the server, with a callback that fires when the response arrives. +-- Multiple requests can be waiting at the same time. +sendRequest + :: forall (m :: Method 'FromClient 'Request) + . Message m ~ RequestMessage m + => SMethod m + -> MessageParams m + -> (ResponseMessage m -> IO ()) + -> Session (LspId m) +sendRequest requestMethod params requestCallback = do + reqId <- asks lastRequestId >>= liftIO . overTVarIO (+ 1) <&> IdInt + asks pendingRequests >>= liftIO . flip modifyTVarIO (updateRequestMap reqId RequestCallback{..}) + sendMessage $ fromClientReq $ RequestMessage "2.0" reqId requestMethod params + pure reqId + +-- | Send a response to the server. This is used internally to acknowledge server requests. +-- Users of this library cannot register callbacks to server requests, so this function is probably of no use to them. +sendResponse + :: forall (m :: Method 'FromServer 'Request) + . RequestMessage m + -> Either ResponseError (ResponseResult m) + -> Session () +sendResponse req = + sendMessage + . FromClientRsp (req ^. LSP.method) + . ResponseMessage (req ^. jsonrpc) (Just $ req ^. LSP.id) + +-- | Sends a request to the server and synchronously waits for its response. +request + :: forall (m :: Method 'FromClient 'Request) + . Message m ~ RequestMessage m + => SMethod m + -> MessageParams m + -> Session (ResponseMessage m) +request method params = do + done <- liftIO newEmptyMVar + void $ sendRequest method params $ putMVar done + liftIO $ takeMVar done + +{- | Checks the response for errors and throws an exception if needed. + Returns the result if successful. +-} +getResponseResult :: ResponseMessage m -> ResponseResult m +getResponseResult response = either err id $ response ^. result + where + lid = SomeLspId $ fromJust $ response ^. LSP.id + err = throw . UnexpectedResponseError lid + +-- | Sends a notification to the server. Updates the VFS if the notification is a document update. +sendNotification + :: forall (m :: Method 'FromClient 'Notification) + . Message m ~ NotificationMessage m + => SMethod m + -> MessageParams m + -> Session () +sendNotification m params = do + let n = NotificationMessage "2.0" m params + vfs <- asks vfs + case m of + STextDocumentDidOpen -> liftIO $ modifyTVarIO vfs (execState $ openVFS mempty n) + STextDocumentDidClose -> liftIO $ modifyTVarIO vfs (execState $ closeVFS mempty n) + STextDocumentDidChange -> liftIO $ modifyTVarIO vfs (execState $ changeFromClientVFS mempty n) + _ -> pure () + sendMessage $ fromClientNot n + +-- | Registers a callback for notifications received from the server. +-- If multiple callbacks are registered for the same notification method, they will all be called. +receiveNotification + :: forall (m :: Method 'FromServer 'Notification) + . SMethod m + -> (Message m -> IO ()) + -> Session () +receiveNotification method notificationCallback = + asks notificationHandlers + >>= liftIO + . flip + modifyTVarIO + ( appendNotificationCallback method NotificationCallback{..} + ) + +-- | Clears the registered callback for the given notification method, if any. +-- If multiple callbacks have been registered, this clears /all/ of them. +clearNotificationCallback + :: forall (m :: Method 'FromServer 'Notification) + . SMethod m + -> Session () +clearNotificationCallback method = + asks notificationHandlers + >>= liftIO + . flip + modifyTVarIO + ( removeNotificationCallback method + ) + +-- | Queues a message to be sent to the server at the client's earliest convenience. +sendMessage :: FromClientMessage -> Session () +sendMessage msg = asks outgoing >>= liftIO . atomically . (`writeTQueue` msg) + +-- | Performs the initialisation handshake and synchronously waits for its completion. +-- When the function completes, the session is initialised. +initialize :: Session () +initialize = do + pid <- liftIO getCurrentProcessID + response <- + request + SInitialize + InitializeParams + { _workDoneToken = Nothing + , _processId = Just $ fromIntegral pid + , _clientInfo = Just lspClientInfo + , _rootPath = Nothing + , _rootUri = Nothing + , _initializationOptions = Nothing + , _capabilities = fullCaps + , _trace = Just TraceOff + , _workspaceFolders = Nothing + } + asks initialized >>= liftIO . atomically . flip putTMVar (getResponseResult response) + sendNotification SInitialized $ Just InitializedParams + +{- | /Creates/ a new text document. This is different from 'openDoc' + as it sends a @workspace/didChangeWatchedFiles@ notification letting the server + know that a file was created within the workspace, __provided that the server + has registered for it__, and the file matches any patterns the server + registered for. + It /does not/ actually create a file on disk, but is useful for convincing + the server that one does exist. +-} +createDoc + :: FilePath + -- ^ The path to the document to open, __relative to the root directory__. + -> Text + -- ^ The text document's language identifier, e.g. @"haskell"@. + -> Text + -- ^ The content of the text document to create. + -> Session TextDocumentIdentifier + -- ^ The identifier of the document just created. +createDoc file language contents = do + serverCaps <- asks serverCapabilities >>= liftIO . readTVarIO + clientCaps <- asks clientCapabilities + rootDir <- asks rootDir + absFile <- liftIO $ canonicalizePath (rootDir file) + let pred :: SomeRegistration -> [Registration 'WorkspaceDidChangeWatchedFiles] + pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] + pred _ = mempty + regs :: [Registration 'WorkspaceDidChangeWatchedFiles] + regs = concatMap pred $ HashMap.elems serverCaps + watchHits :: FileSystemWatcher -> Bool + watchHits (FileSystemWatcher pattern kind) = + -- If WatchKind is excluded, defaults to all true as per spec + fileMatches (Text.unpack pattern) && maybe True (view watchCreate) kind + + fileMatches pattern = Glob.match (Glob.compile pattern) (if isAbsolute pattern then absFile else file) + + regHits :: Registration 'WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = any watchHits $ reg ^. registerOptions . watchers + + clientCapsSupports = + clientCaps + ^? workspace + . _Just + . didChangeWatchedFiles + . _Just + . dynamicRegistration + . _Just + == Just True + shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs + + when shouldSend $ + sendNotification SWorkspaceDidChangeWatchedFiles $ + DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri (rootDir file)) FcCreated] + openDoc' file language contents + +{- | Opens a text document that /exists on disk/, and sends a + @textDocument/didOpen@ notification to the server. +-} +openDoc :: FilePath -> Text -> Session TextDocumentIdentifier +openDoc file language = do + rootDir <- asks rootDir + let fp = rootDir file + contents <- liftIO $ Text.readFile fp + openDoc' file language contents + +{- | This is a variant of `openDoc` that takes the file content as an argument. + Use this is the file exists /outside/ of the current workspace. +-} +openDoc' :: FilePath -> Text -> Text -> Session TextDocumentIdentifier +openDoc' file language contents = do + rootDir <- asks rootDir + let fp = rootDir file + uri = filePathToUri fp + item = TextDocumentItem uri language 0 contents + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item) + pure $ TextDocumentIdentifier uri + +-- | Closes a text document and sends a @textDocument/didClose@ notification to the server. +closeDoc :: TextDocumentIdentifier -> Session () +closeDoc docId = do + let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) + sendNotification STextDocumentDidClose params + +-- | Changes a text document and sends a @textDocument/didChange@ notification to the server. +changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () +changeDoc docId changes = do + verDoc <- getVersionedDoc docId + let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) + sendNotification STextDocumentDidChange params + +-- | Gets the Uri for the file relative to the session's root directory. +getDocUri :: FilePath -> Session Uri +getDocUri file = do + rootDir <- asks rootDir + let fp = rootDir file + return $ filePathToUri fp + +-- | The current text contents of a document. +documentContents :: TextDocumentIdentifier -> Session (Maybe Rope) +documentContents (TextDocumentIdentifier uri) = do + vfs <- asks vfs >>= liftIO . readTVarIO + pure $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to _file_text + +-- | Adds the current version to the document, as tracked by the session. +getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier +getVersionedDoc (TextDocumentIdentifier uri) = do + vfs <- asks vfs >>= liftIO . readTVarIO + let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion + pure $ VersionedTextDocumentIdentifier uri ver diff --git a/test/Language/LSP/ClientSpec.hs b/test/Language/LSP/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/LSP/ClientSpec.hs @@ -0,0 +1,175 @@ +module Language.LSP.ClientSpec where + +import Control.Arrow ((>>>)) +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.Extra (whenMaybeM, whileJustM, whileM) +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (parseMaybe) +import Data.ByteString (ByteString, hGetSome) +import Data.ByteString.Builder.Extra (defaultChunkSize) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Coerce (coerce) +import Data.Maybe (fromJust) +import Data.Tuple.Extra (thd3) +import Language.LSP.Client +import Language.LSP.Client.Decoding (getNextMessage) +import Language.LSP.Client.Encoding (encode) +import Language.LSP.Client.Session +import Language.LSP.Client.Session qualified as LSP +import Language.LSP.Types +import Language.LSP.Types qualified as LSP +import Language.LSP.Types.Lens qualified as LSP +import System.IO +import System.Process (createPipe) +import Test.Hspec hiding (shouldReturn) +import Test.Hspec qualified as Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import UnliftIO (MonadIO (..), MonadUnliftIO, fromEither, newTVarIO, race, readTVarIO) +import UnliftIO.Concurrent +import Prelude hiding (log) + +shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () +shouldReturn a expected = a >>= liftIO . flip Hspec.shouldBe expected + +withTimeout :: forall m a. MonadUnliftIO m => Int -> m a -> m a +withTimeout delay a = fromEither =<< race timeout a + where + timeout = do + threadDelay delay + pure $ AssertionFailed "Timeout exceeded" + +diagnostic :: Int -> Diagnostic +diagnostic i = + Diagnostic + { _range = + Range + { _start = Position{_line = 0, _character = 0} + , _end = Position{_line = 0, _character = 0} + } + , _severity = Nothing + , _code = Just $ InL $ fromIntegral i + , _source = Nothing + , _message = "" + , _tags = Nothing + , _relatedInformation = Nothing + } + +-- | LSP server that does not read input, and sends dummy diagnostics once per second +diagServer :: IO (Handle, Handle, ThreadId) +diagServer = do + (inRead, inWrite) <- createPipe + hSetBuffering inRead LineBuffering + hSetBuffering inWrite LineBuffering + (outRead, outWrite) <- createPipe + hSetBuffering outRead LineBuffering + hSetBuffering outWrite LineBuffering + threadId <- forkIO $ forM_ [1 ..] $ \i -> do + threadDelay 1_000 + let message = + NotificationMessage + "2.0" + STextDocumentPublishDiagnostics + PublishDiagnosticsParams + { _uri = Uri "" + , _version = Nothing + , _diagnostics = List [diagnostic i] + } + LazyByteString.hPut outWrite $ encode message + pure (inWrite, outRead, threadId) + +-- | LSP server that accepts requests and answers them with a delay +reqServer :: IO (Handle, Handle, ThreadId) +reqServer = do + (inRead, inWrite) <- createPipe + hSetBuffering inRead LineBuffering + hSetBuffering inWrite LineBuffering + (outRead, outWrite) <- createPipe + hSetBuffering outRead LineBuffering + hSetBuffering outWrite LineBuffering + lock <- newMVar () + threadId <- forkIO $ forever $ do + bytes <- liftIO $ getNextMessage inRead + let obj = fromJust $ Aeson.decode bytes + idMaybe = parseMaybe (.: "id") obj + message :: ResponseMessage 'Shutdown + message = ResponseMessage "2.0" idMaybe (Right Empty) + forkIO $ do + threadDelay 1_000 + takeMVar lock + LazyByteString.hPut outWrite $ encode message + putMVar lock () + pure (inWrite, outRead, threadId) + +-- | LSP server that reads messages, and does nothing else +notifServer :: IO (Handle, Handle, ThreadId) +notifServer = do + (inRead, inWrite) <- createPipe + hSetBuffering inRead LineBuffering + hSetBuffering inWrite LineBuffering + (outRead, _) <- createPipe + hSetBuffering outRead LineBuffering + threadId <- forkIO $ forever $ do + liftIO $ getNextMessage inRead + pure (inWrite, outRead, threadId) + +-- | LSP client that waits for queries +client :: Handle -> Handle -> IO (Session () -> IO (), ThreadId) +client serverInput serverOutput = do + i <- newEmptyMVar + o <- newEmptyMVar + threadId <- forkIO $ runSessionWithHandles serverOutput serverInput $ forever $ do + a <- takeMVar i + a >>= putMVar o + pure (putMVar i >>> (*> readMVar o), threadId) + +getAvailableContents :: Handle -> IO ByteString +getAvailableContents h = whileJustM $ whenMaybeM (hReady h) (hGetSome h defaultChunkSize) + +spec :: Spec +spec = do + prop "concurrently handles actions and server messages" $ again $ do + bracket + diagServer + (killThread . thd3) + $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do + diagnostics <- newTVarIO @_ @[Diagnostic] [] + let getDiagnostics = readTVarIO diagnostics + setDiagnostics = writeTVarIO diagnostics + receiveNotification LSP.STextDocumentPublishDiagnostics $ \msg -> + setDiagnostics $ coerce $ msg ^. LSP.params . LSP.diagnostics + -- We allow up to 0.1 s to receive the first batch of diagnostics + withTimeout 100_000 $ whileM $ do + threadDelay 1_000 + null <$> getDiagnostics + [d1] <- getDiagnostics + -- We allow up to 0.1 s to receive the next batch of diagnostics + withTimeout 100_000 $ whileM $ do + threadDelay 1_000 + [d2] <- getDiagnostics + pure $ d2._code == d1._code + prop "answers requests correctly" $ again $ do + bracket + reqServer + (killThread . thd3) + $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do + req1Done <- newEmptyMVar + req1Id <- sendRequest SShutdown Empty (putMVar req1Done . (._id)) + req2Done <- newEmptyMVar + req2Id <- sendRequest SShutdown Empty (putMVar req2Done . (._id)) + withTimeout 100_000 $ takeMVar req1Done `shouldReturn` Just req1Id + withTimeout 100_000 $ takeMVar req2Done `shouldReturn` Just req2Id + prop "opens and changes virtual documents correctly" $ do + bracket + notifServer + (killThread . thd3) + $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do + doc <- LSP.createDoc "TestFile.hs" "haskell" "" + LSP.documentContents doc `shouldReturn` Just "" + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "foo\n\nbar"] + LSP.documentContents doc `shouldReturn` Just "foo\n\nbar" + closeDoc doc + LSP.documentContents doc `shouldReturn` Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-prepositive-qualified-module #-}