From 8a983bd025657407488aaff433715f4828e326d4 Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Mon, 18 Apr 2022 15:31:54 +0100
Subject: [PATCH 1/5] Modularise the server input and output
The goal here is to make the `Control` module as boring and dispensible
as possible, so that users can put the pieces together as they like.
Thisi s a step in that direction, tackling the server in/out threads.
---
lsp/lsp.cabal | 1 +
lsp/src/Language/LSP/Server.hs | 2 +
lsp/src/Language/LSP/Server/Control.hs | 171 ++++------------------
lsp/src/Language/LSP/Server/IO.hs | 122 +++++++++++++++
lsp/src/Language/LSP/Server/Processing.hs | 40 ++++-
5 files changed, 185 insertions(+), 151 deletions(-)
create mode 100644 lsp/src/Language/LSP/Server/IO.hs
diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal
index 8dd75683..9a7bc98e 100644
--- a/lsp/lsp.cabal
+++ b/lsp/lsp.cabal
@@ -48,6 +48,7 @@ library
Language.LSP.Server.Control
Language.LSP.Server.Core
Language.LSP.Server.Processing
+ Language.LSP.Server.IO
ghc-options: -Wall
build-depends:
diff --git a/lsp/src/Language/LSP/Server.hs b/lsp/src/Language/LSP/Server.hs
index 909a41d1..b8b78941 100644
--- a/lsp/src/Language/LSP/Server.hs
+++ b/lsp/src/Language/LSP/Server.hs
@@ -2,6 +2,7 @@
module Language.LSP.Server (
module Language.LSP.Server.Control,
+ module Language.LSP.Server.IO,
VFSData (..),
ServerDefinition (..),
@@ -63,3 +64,4 @@ module Language.LSP.Server (
import Language.LSP.Server.Control
import Language.LSP.Server.Core
+import Language.LSP.Server.IO
diff --git a/lsp/src/Language/LSP/Server/Control.hs b/lsp/src/Language/LSP/Server/Control.hs
index 5a7e772e..0c16610d 100644
--- a/lsp/src/Language/LSP/Server/Control.hs
+++ b/lsp/src/Language/LSP/Server/Control.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -14,58 +13,39 @@ module Language.LSP.Server.Control (
LspServerLog (..),
) where
-import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
+import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), cmap, (<&))
import Colog.Core qualified as L
import Control.Applicative ((<|>))
-import Control.Concurrent
+import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM.TChan
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.STM
import Data.Aeson qualified as J
-import Data.Attoparsec.ByteString qualified as Attoparsec
-import Data.Attoparsec.ByteString.Char8
import Data.ByteString qualified as BS
import Data.ByteString.Builder.Extra (defaultChunkSize)
-import Data.ByteString.Lazy qualified as BSL
-import Data.List
import Data.Text qualified as T
-import Data.Text.Lazy qualified as TL
-import Data.Text.Lazy.Encoding qualified as TL
import Data.Text.Prettyprint.Doc
import Language.LSP.Logging (defaultClientLogger)
import Language.LSP.Protocol.Message
import Language.LSP.Server.Core
+import Language.LSP.Server.IO qualified as IO
import Language.LSP.Server.Processing qualified as Processing
import Language.LSP.VFS
import System.IO
data LspServerLog
= LspProcessingLog Processing.LspProcessingLog
- | DecodeInitializeError String
- | HeaderParseFail [String] String
- | EOF
+ | LspIoLog IO.LspIoLog
| Starting
- | ParsedMsg T.Text
- | SendMsg TL.Text
+ | Stopping
deriving (Show)
instance Pretty LspServerLog where
pretty (LspProcessingLog l) = pretty l
- pretty (DecodeInitializeError err) =
- vsep
- [ "Got error while decoding initialize:"
- , pretty err
- ]
- pretty (HeaderParseFail ctxs err) =
- vsep
- [ "Failed to parse message header:"
- , pretty (intercalate " > " ctxs) <> ": " <+> pretty err
- ]
- pretty EOF = "Got EOF"
+ pretty (LspIoLog l) = pretty l
pretty Starting = "Starting server"
- pretty (ParsedMsg msg) = "---> " <> pretty msg
- pretty (SendMsg msg) = "<--2-- " <> pretty msg
+ pretty Stopping = "Stopping server"
-- ---------------------------------------------------------------------
@@ -115,7 +95,7 @@ runServerWithHandles ioLogger logger hin hout serverDefinition = do
clientIn = BS.hGetSome hin defaultChunkSize
clientOut out = do
- BSL.hPut hout out
+ BS.hPut hout out
hFlush hout
runServerWith ioLogger logger clientIn clientOut serverDefinition
@@ -131,129 +111,32 @@ runServerWith ::
-- | Client input.
IO BS.ByteString ->
-- | Function to provide output to.
- (BSL.ByteString -> IO ()) ->
+ (BS.ByteString -> IO ()) ->
ServerDefinition config ->
IO Int -- exit code
runServerWith ioLogger logger clientIn clientOut serverDefinition = do
ioLogger <& Starting `WithSeverity` Info
- cout <- atomically newTChan :: IO (TChan J.Value)
- _rhpid <- forkIO $ sendServer ioLogger cout clientOut
+ cout <- atomically newTChan
+ cin <- atomically newTChan
- let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg
+ let serverOut = IO.serverOut (cmap (fmap LspIoLog) ioLogger) (atomically $ readTChan cout) clientOut
+ serverIn = IO.serverIn (cmap (fmap LspIoLog) ioLogger) (atomically . writeTChan cin) clientIn
- initVFS $ \vfs -> do
- ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg
+ sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg
+ recvMsg = atomically $ readTChan cin
- return 1
+ processingLoop = initVFS $ \vfs ->
+ Processing.processingLoop
+ (cmap (fmap LspProcessingLog) ioLogger)
+ (cmap (fmap LspProcessingLog) logger)
+ vfs
+ serverDefinition
+ sendMsg
+ recvMsg
--- ---------------------------------------------------------------------
-
-ioLoop ::
- forall config.
- LogAction IO (WithSeverity LspServerLog) ->
- LogAction (LspM config) (WithSeverity LspServerLog) ->
- IO BS.ByteString ->
- ServerDefinition config ->
- VFS ->
- (FromServerMessage -> IO ()) ->
- IO ()
-ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do
- minitialize <- parseOne ioLogger clientIn (parse parser "")
- case minitialize of
- Nothing -> pure ()
- Just (msg, remainder) -> do
- case J.eitherDecode $ BSL.fromStrict msg of
- Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error
- Right initialize -> do
- mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg initialize
- case mInitResp of
- Nothing -> pure ()
- Just env -> runLspT env $ loop (parse parser remainder)
- where
- pioLogger = L.cmap (fmap LspProcessingLog) ioLogger
- pLogger = L.cmap (fmap LspProcessingLog) logger
-
- loop :: Result BS.ByteString -> LspM config ()
- loop = go
- where
- go r = do
- res <- parseOne logger clientIn r
- case res of
- Nothing -> pure ()
- Just (msg, remainder) -> do
- Processing.processMessage pLogger $ BSL.fromStrict msg
- go (parse parser remainder)
-
- parser = do
- try contentType <|> (return ())
- len <- contentLength
- try contentType <|> (return ())
- _ <- string _ONE_CRLF
- Attoparsec.take len
-
- contentLength = do
- _ <- string "Content-Length: "
- len <- decimal
- _ <- string _ONE_CRLF
- return len
-
- contentType = do
- _ <- string "Content-Type: "
- skipWhile (/= '\r')
- _ <- string _ONE_CRLF
- return ()
-
-parseOne ::
- MonadIO m =>
- LogAction m (WithSeverity LspServerLog) ->
- IO BS.ByteString ->
- Result BS.ByteString ->
- m (Maybe (BS.ByteString, BS.ByteString))
-parseOne logger clientIn = go
- where
- go (Fail _ ctxs err) = do
- logger <& HeaderParseFail ctxs err `WithSeverity` Error
- pure Nothing
- go (Partial c) = do
- bs <- liftIO clientIn
- if BS.null bs
- then do
- logger <& EOF `WithSeverity` Error
- pure Nothing
- else go (c bs)
- go (Done remainder msg) = do
- -- TODO: figure out how to re-enable
- -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447
- -- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug
- pure $ Just (msg, remainder)
-
--- ---------------------------------------------------------------------
-
--- | Simple server to make sure all output is serialised
-sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()
-sendServer _logger msgChan clientOut = do
- forever $ do
- msg <- atomically $ readTChan msgChan
-
- -- We need to make sure we only send over the content of the message,
- -- and no other tags/wrapper stuff
- let str = J.encode msg
-
- let out =
- BSL.concat
- [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)
- , BSL.fromStrict _TWO_CRLF
- , str
- ]
-
- clientOut out
-
--- TODO: figure out how to re-enable
--- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447
--- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug
+ -- Bind all the threads together so that any of them terminating will terminate everything
+ serverOut `Async.race_` serverIn `Async.race_` processingLoop
-_ONE_CRLF :: BS.ByteString
-_ONE_CRLF = "\r\n"
-_TWO_CRLF :: BS.ByteString
-_TWO_CRLF = "\r\n\r\n"
+ ioLogger <& Stopping `WithSeverity` Info
+ return 0
diff --git a/lsp/src/Language/LSP/Server/IO.hs b/lsp/src/Language/LSP/Server/IO.hs
new file mode 100644
index 00000000..386ed130
--- /dev/null
+++ b/lsp/src/Language/LSP/Server/IO.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Language.LSP.Server.IO (serverOut, serverIn, LspIoLog) where
+
+import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
+import Control.Applicative ((<|>))
+import Control.Monad
+import Data.Aeson qualified as J
+import Data.Attoparsec.ByteString qualified as Attoparsec
+import Data.Attoparsec.ByteString.Char8
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.List
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.Prettyprint.Doc
+
+data LspIoLog
+ = HeaderParseFail [String] String
+ | BodyParseFail String
+ | RecvMsg BS.ByteString
+ | SendMsg BS.ByteString
+ | EOF
+ deriving (Show)
+
+instance Pretty LspIoLog where
+ pretty (HeaderParseFail ctxs err) =
+ vsep
+ [ "Failed to parse message header:"
+ , pretty (intercalate " > " ctxs) <> ": " <+> pretty err
+ ]
+ pretty (BodyParseFail err) =
+ vsep
+ [ "Failed to parse message body:"
+ , pretty err
+ ]
+ pretty (RecvMsg msg) = "---> " <> pretty (T.decodeUtf8 msg)
+ pretty (SendMsg msg) = "<--- " <> pretty (T.decodeUtf8 msg)
+ pretty EOF = "Got EOF"
+
+-- | Process which receives messages and sends them. Output queue of messages ensures they are serialised.
+serverIn ::
+ LogAction IO (WithSeverity LspIoLog) ->
+ -- | Channel to send out messages on.
+ (J.Value -> IO ()) ->
+ -- | Action to pull in new messages (e.g. from a handle).
+ IO BS.ByteString ->
+ IO ()
+serverIn logger msgOut clientIn = do
+ bs <- clientIn
+ loop (parse parser bs)
+ where
+ loop :: Result BS.ByteString -> IO ()
+ loop (Fail _ ctxs err) = do
+ logger <& HeaderParseFail ctxs err `WithSeverity` Error
+ pure ()
+ loop (Partial c) = do
+ bs <- clientIn
+ if BS.null bs
+ then do
+ logger <& EOF `WithSeverity` Error
+ pure ()
+ else loop (c bs)
+ loop (Done remainder parsed) = do
+ logger <& RecvMsg parsed `WithSeverity` Debug
+ case J.eitherDecode (BSL.fromStrict parsed) of
+ -- Note: this is recoverable, because we can just discard the
+ -- message and keep going, whereas a header parse failure is
+ -- not recoverable
+ Left err -> logger <& BodyParseFail err `WithSeverity` Error
+ Right msg -> msgOut msg
+ loop (parse parser remainder)
+
+ parser = do
+ try contentType <|> (return ())
+ len <- contentLength
+ try contentType <|> (return ())
+ _ <- string _ONE_CRLF
+ Attoparsec.take len
+
+ contentLength = do
+ _ <- string "Content-Length: "
+ len <- decimal
+ _ <- string _ONE_CRLF
+ return len
+
+ contentType = do
+ _ <- string "Content-Type: "
+ skipWhile (/= '\r')
+ _ <- string _ONE_CRLF
+ return ()
+
+-- | Process which receives messages and sends them. Input queue of messages ensures they are serialised.
+serverOut ::
+ LogAction IO (WithSeverity LspIoLog) ->
+ -- | Channel to receive messages on.
+ IO J.Value ->
+ -- | Action to send messages out on (e.g. via a handle).
+ (BS.ByteString -> IO ()) ->
+ IO ()
+serverOut logger msgIn clientOut = forever $ do
+ msg <- msgIn
+
+ -- We need to make sure we only send over the content of the message,
+ -- and no other tags/wrapper stuff
+ let str = J.encode msg
+
+ let out =
+ BS.concat
+ [ T.encodeUtf8 $ T.pack $ "Content-Length: " ++ show (BSL.length str)
+ , _TWO_CRLF
+ , BSL.toStrict str
+ ]
+
+ clientOut out
+ logger <& SendMsg out `WithSeverity` Debug
+
+_ONE_CRLF :: BS.ByteString
+_ONE_CRLF = "\r\n"
+_TWO_CRLF :: BS.ByteString
+_TWO_CRLF = "\r\n\r\n"
diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs
index 7d7685df..8fc8aff3 100644
--- a/lsp/src/Language/LSP/Server/Processing.hs
+++ b/lsp/src/Language/LSP/Server/Processing.hs
@@ -43,6 +43,7 @@ import Data.Aeson hiding (
Null,
Options,
)
+import Data.Aeson qualified as J
import Data.Aeson.Lens ()
import Data.Aeson.Types hiding (
Error,
@@ -75,7 +76,8 @@ import System.Exit
data LspProcessingLog
= VfsLog VfsLog
| LspCore LspCoreLog
- | MessageProcessingError BSL.ByteString String
+ | DecodeInitializeError String
+ | MessageProcessingError Value String
| forall m. MissingHandler Bool (SClientMethod m)
| ProgressCancel ProgressToken
| Exiting
@@ -85,22 +87,46 @@ deriving instance Show LspProcessingLog
instance Pretty LspProcessingLog where
pretty (VfsLog l) = pretty l
pretty (LspCore l) = pretty l
- pretty (MessageProcessingError bs err) =
+ pretty (DecodeInitializeError err) =
+ vsep
+ [ "Got error while decoding initialize:"
+ , pretty err
+ ]
+ pretty (MessageProcessingError val err) =
vsep
[ "LSP: incoming message parse error:"
, pretty err
, "when processing"
- , pretty (TL.decodeUtf8 bs)
+ , viaShow val
]
pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m
pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid
pretty Exiting = "LSP: Got exit, exiting"
-processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m ()
-processMessage logger jsonStr = do
+processingLoop ::
+ LogAction IO (WithSeverity LspProcessingLog) ->
+ LogAction (LspM config) (WithSeverity LspProcessingLog) ->
+ VFS ->
+ ServerDefinition config ->
+ (Value -> IO ()) ->
+ IO Value ->
+ IO ()
+processingLoop ioLogger logger vfs serverDefinition sendMsg recvMsg = do
+ initMsg <- recvMsg
+ case fromJSON initMsg of
+ J.Error err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error
+ Success initialize -> do
+ mInitResp <- initializeRequestHandler ioLogger serverDefinition vfs (sendMsg . J.toJSON) initialize
+ case mInitResp of
+ Nothing -> pure ()
+ Just env -> runLspT env $ forever $ do
+ msg <- liftIO recvMsg
+ processMessage logger msg
+
+processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Value -> m ()
+processMessage logger val = do
pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState
join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do
- val <- except $ eitherDecode jsonStr
pending <- lift $ readTVar pendingResponsesVar
msg <- except $ parseEither (parser pending) val
lift $ case msg of
@@ -115,7 +141,7 @@ processMessage logger jsonStr = do
let (mhandler, newMap) = pickFromIxMap i rm
in (\(P.Pair m handler) -> (m, P.Pair handler (Const newMap))) <$> mhandler
- handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id
+ handleErrors = either (\e -> logger <& MessageProcessingError val e `WithSeverity` Error) id
-- | Call this to initialize the session
initializeRequestHandler ::
From dacb79382f6e2d64e99663e307456267644d53e4 Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Sun, 27 Aug 2023 12:35:09 +0100
Subject: [PATCH 2/5] Try making more test suites threaded
---
lsp-test/lsp-test.cabal | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal
index 143d1ab9..e73acda2 100644
--- a/lsp-test/lsp-test.cabal
+++ b/lsp-test/lsp-test.cabal
@@ -93,8 +93,7 @@ test-suite tests
hs-source-dirs: test
main-is: Test.hs
default-language: Haskell2010
- default-extensions: ImportQualifiedPost
- ghc-options: -W
+ ghc-options: -W -threaded -rtsopts -with-rtsopts=-N
other-modules: DummyServer
build-depends:
, aeson
@@ -120,6 +119,7 @@ test-suite func-test
default-language: Haskell2010
default-extensions: ImportQualifiedPost
main-is: FuncTest.hs
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
, base
, co-log-core
@@ -138,6 +138,7 @@ test-suite example
default-language: Haskell2010
default-extensions: ImportQualifiedPost
main-is: Test.hs
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
, base
, lsp-test
@@ -150,7 +151,7 @@ benchmark simple-bench
default-language: Haskell2010
default-extensions: ImportQualifiedPost
main-is: SimpleBench.hs
- ghc-options: -Wall -O2 -eventlog -rtsopts
+ ghc-options: -Wall -O2 -eventlog -threaded -rtsopts -with-rtsopts=-N
build-depends:
, base
, extra
From 132db9471931301f27548d72a9a5e52ab7885a75 Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Sun, 27 Aug 2023 13:32:23 +0100
Subject: [PATCH 3/5] WIP debug
---
lsp-test/test/DummyServer.hs | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs
index f44f4448..12dfba23 100644
--- a/lsp-test/test/DummyServer.hs
+++ b/lsp-test/test/DummyServer.hs
@@ -5,6 +5,7 @@
module DummyServer where
+import Colog.Core qualified as L
import Control.Monad
import Control.Monad.Reader
import Data.Aeson hiding (Null, defaultOptions)
@@ -26,6 +27,7 @@ import UnliftIO.Concurrent
withDummyServer :: ((Handle, Handle) -> IO ()) -> IO ()
withDummyServer f = do
+ let logger = L.cmap show L.logStringStderr
(hinRead, hinWrite) <- createPipe
(houtRead, houtWrite) <- createPipe
@@ -47,7 +49,7 @@ withDummyServer f = do
}
bracket
- (forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite definition)
+ (forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition)
killThread
(const $ f (hinWrite, houtRead))
From 372cd20b8adf119d961a766336d8b69f9de5e335 Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Sun, 27 Aug 2023 13:43:40 +0100
Subject: [PATCH 4/5] Fix
---
lsp-test/lsp-test.cabal | 1 +
1 file changed, 1 insertion(+)
diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal
index e73acda2..ec7c91c1 100644
--- a/lsp-test/lsp-test.cabal
+++ b/lsp-test/lsp-test.cabal
@@ -93,6 +93,7 @@ test-suite tests
hs-source-dirs: test
main-is: Test.hs
default-language: Haskell2010
+ default-extensions: ImportQualifiedPost
ghc-options: -W -threaded -rtsopts -with-rtsopts=-N
other-modules: DummyServer
build-depends:
From f8bb50075128de4e910fef21933ddf645c605a77 Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Sun, 27 Aug 2023 13:46:11 +0100
Subject: [PATCH 5/5] More fix
---
lsp-test/lsp-test.cabal | 1 +
1 file changed, 1 insertion(+)
diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal
index ec7c91c1..77b6d5f7 100644
--- a/lsp-test/lsp-test.cabal
+++ b/lsp-test/lsp-test.cabal
@@ -100,6 +100,7 @@ test-suite tests
, aeson
, base >=4.10 && <5
, containers
+ , co-log-core
, data-default
, directory
, filepath