From f69b8516cb4d913170b88999a0508ab870c703d0 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 28 Jul 2026 18:22:00 +0200 Subject: [PATCH] Extract Websocket module to avoid CPP Extract optional module that exposes an API for use with websockets. Only exported if the flag `websocket` is enabled. --- lsp/lsp.cabal | 13 +- lsp/src/Language/LSP/Server/Control.hs | 140 ----------------- .../Language/LSP/Server/Control/Websocket.hs | 147 ++++++++++++++++++ 3 files changed, 155 insertions(+), 145 deletions(-) create mode 100644 lsp/src/Language/LSP/Server/Control/Websocket.hs diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 3b32f0c3..162f147f 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -29,6 +29,10 @@ source-repository head common warnings ghc-options: -Wall -Wunused-packages -Wno-unticked-promoted-constructors +flag websocket + description: Enable WebSocket support + default: True + library import: warnings hs-source-dirs: src @@ -52,6 +56,10 @@ library Language.LSP.Server.Processing Language.LSP.Server.Progress + if flag(websocket) + other-modules: + Language.LSP.Server.Control.Websocket + build-depends: , aeson >=2 && <2.3 , async ^>=2.2 @@ -81,7 +89,6 @@ library , unordered-containers ^>=0.2 if flag(websocket) - cpp-options: -DENABLE_WEBSOCKET build-depends: websockets ^>=0.13 @@ -122,10 +129,6 @@ flag demo description: Build the demo executables default: False -flag websocket - description: Enable WebSocket support - default: True - test-suite lsp-test import: warnings type: exitcode-stdio-1.0 diff --git a/lsp/src/Language/LSP/Server/Control.hs b/lsp/src/Language/LSP/Server/Control.hs index eaa68d18..a6cdb59a 100644 --- a/lsp/src/Language/LSP/Server/Control.hs +++ b/lsp/src/Language/LSP/Server/Control.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,13 +17,6 @@ module Language.LSP.Server.Control ( runServerWithHandles, prependHeader, parseHeaders, - -#ifdef ENABLE_WEBSOCKET - -- ** Using websockets - WebsocketConfig (..), - withWebsocket, - withWebsocketRunServer, -#endif /* ENABLE_WEBSOCKET */ ) where import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) @@ -54,13 +46,6 @@ import Prettyprinter import System.IO import System.IO.Error (isResourceVanishedError) -#ifdef ENABLE_WEBSOCKET -import Control.Concurrent -import Control.Monad -import Control.Exception (finally) -import Network.WebSockets qualified as WS -#endif /* ENABLE_WEBSOCKET */ - data LspServerLog = LspProcessingLog Processing.LspProcessingLog | DecodeInitializeError String @@ -71,9 +56,6 @@ data LspServerLog | ServerStopped | ParsedMsg T.Text | SendMsg TL.Text -#ifdef ENABLE_WEBSOCKET - | WebsocketLog WebsocketLog -#endif /* ENABLE_WEBSOCKET */ deriving (Show) instance Pretty LspServerLog where @@ -98,9 +80,6 @@ instance Pretty LspServerLog where pretty Starting = "Server starting" pretty (ParsedMsg msg) = "---> " <> pretty msg pretty (SendMsg msg) = "<--2-- " <> pretty msg -#ifdef ENABLE_WEBSOCKET - pretty (WebsocketLog msg) = "Websocket:" <+> pretty msg -#endif /* ENABLE_WEBSOCKET */ -- --------------------------------------------------------------------- @@ -280,125 +259,6 @@ parseOne logger clientIn = go -- --------------------------------------------------------------------- -#ifdef ENABLE_WEBSOCKET - -data WebsocketLog - = WebsocketShutDown - | WebsocketNewConnection - | WebsocketConnectionClosed - | WebsocketPing - | WebsocketStarted - | WebsocketIncomingRequest - | WebsocketOutgoingResponse - deriving stock (Show) - -instance Pretty WebsocketLog where - pretty l = case l of - WebsocketPing -> "Ping" - WebsocketStarted -> "Started Server, waiting for connections" - WebsocketShutDown -> "Shut down server" - WebsocketNewConnection -> "New connection established" - WebsocketIncomingRequest -> "Received request" - WebsocketConnectionClosed -> "Closed connection to client" - WebsocketOutgoingResponse -> "Sent response" - --- | 'host' and 'port' of the websocket server to set up -data WebsocketConfig = WebsocketConfig - { host :: !String - -- ^ the host of the websocket server, e.g. @"localhost"@ - , port :: !Int - -- ^ the port of the websocket server, e.g. @8080@ - } - --- | Set up a websocket server, then call call the continuation (in our case this corresponds to the language server) after accepting a connection -withWebsocket :: - -- | The logger - LogAction IO (WithSeverity LspServerLog) -> - -- | The configuration of the websocket server - WebsocketConfig -> - -- | invoke the lsp server, passing communication functions - (IO BS.StrictByteString -> (BSL.LazyByteString -> IO ()) -> IO r) -> - IO () -withWebsocket logger conf startLspServer = do - let wsLogger = L.cmap (fmap WebsocketLog) logger - - WS.runServer (host conf) (port conf) $ \pending -> do - conn <- WS.acceptRequest pending - wsLogger <& WebsocketNewConnection `WithSeverity` Debug - - outChan <- newChan - inChan <- newChan - - let inwards = readChan inChan - outwards = writeChan outChan - - WS.withPingThread conn 30 (wsLogger <& WebsocketPing `WithSeverity` Debug) $ do - withAsync (startLspServer inwards outwards) $ \lspAsync -> - ( do - link lspAsync - - race_ - ( forever $ do - msg <- readChan outChan - wsLogger <& WebsocketOutgoingResponse `WithSeverity` Debug - WS.sendTextData conn msg - ) - ( forever $ do - msg <- WS.receiveData conn - wsLogger <& WebsocketIncomingRequest `WithSeverity` Debug - writeChan inChan msg - -- NOTE: since the parser assumes to consume messages - -- incrementally,we need to somehow signal that the - -- content has terminated - we do this by sending the - -- empty string (instead of parsing exactly the content - -- length, like in the stdio case) - writeChan inChan "" - ) - ) - `finally` do - wsLogger <& WebsocketConnectionClosed `WithSeverity` Debug - -{- | Given a 'WebsocketConfig', wait for connections using a websocket server. -The continuation passed is called for every new connection and can be used -to initialize state that is specific to that respective connection. - -This combines 'withWebsocket' and 'runServerWithConfig'. --} -withWebsocketRunServer :: - -- | Configuration for the websocket - WebsocketConfig -> - -- | How to set up a new 'ServerDefinition' for a specific configuration. z - -- This is passed as CPS'd 'IO' to allow for setting (- and cleaning) up - -- a server per websocket connection - ((ServerDefinition config -> IO Int) -> IO Int) -> - -- | The 'IO' logger - LogAction IO (WithSeverity LspServerLog) -> - -- | The logger that logs in 'LspM' to the client - LogAction (LspM config) (WithSeverity LspServerLog) -> - IO () -withWebsocketRunServer wsConf withLspDefinition ioLogger lspLogger = - withWebsocket ioLogger wsConf $ \inwards outwards -> do - withLspDefinition $ \lspDefinition -> - runServerWithConfig - ServerConfig - { ioLogger - , lspLogger - , inwards - , outwards - , -- NOTE: if you run the language server on websockets, you do not - -- need to prepend headers to requests and responses, because - -- the chunking is already handled by the websocket, i.e. there's - -- no situation where the client or the server has to rely on input/ - -- output chunking - prepareOutwards = id - , parseInwards = Attoparsec.takeByteString - } - lspDefinition - -#endif /* ENABLE_WEBSOCKET */ - --- --------------------------------------------------------------------- - -- | Simple server to make sure all output is serialised sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan FromServerMessage -> (BSL.LazyByteString -> IO ()) -> (BSL.LazyByteString -> BSL.LazyByteString) -> IO () sendServer _logger msgChan clientOut prepareMessage = go diff --git a/lsp/src/Language/LSP/Server/Control/Websocket.hs b/lsp/src/Language/LSP/Server/Control/Websocket.hs new file mode 100644 index 00000000..d287d07f --- /dev/null +++ b/lsp/src/Language/LSP/Server/Control/Websocket.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.LSP.Server.Control.Websocket ( + -- ** Using websockets + WebsocketConfig (..), + withWebsocket, + withWebsocketRunServer, +) where + +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Colog.Core qualified as L +import Control.Concurrent.Async +import Data.Attoparsec.ByteString qualified as Attoparsec +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Language.LSP.Server.Control +import Language.LSP.Server.Core +import Prettyprinter + +import Control.Concurrent +import Control.Exception (finally) +import Control.Monad +import Network.WebSockets qualified as WS + +data WebsocketServerLog + = WsLspServerLog LspServerLog + | WsWebsocketLog WebsocketLog + deriving (Show) + +instance Pretty WebsocketServerLog where + pretty (WsLspServerLog msg) = pretty msg + pretty (WsWebsocketLog msg) = "Websocket:" <+> pretty msg + +data WebsocketLog + = WebsocketShutDown + | WebsocketNewConnection + | WebsocketConnectionClosed + | WebsocketPing + | WebsocketStarted + | WebsocketIncomingRequest + | WebsocketOutgoingResponse + deriving stock (Show) + +instance Pretty WebsocketLog where + pretty l = case l of + WebsocketPing -> "Ping" + WebsocketStarted -> "Started Server, waiting for connections" + WebsocketShutDown -> "Shut down server" + WebsocketNewConnection -> "New connection established" + WebsocketIncomingRequest -> "Received request" + WebsocketConnectionClosed -> "Closed connection to client" + WebsocketOutgoingResponse -> "Sent response" + +-- | 'host' and 'port' of the websocket server to set up +data WebsocketConfig = WebsocketConfig + { host :: !String + -- ^ the host of the websocket server, e.g. @"localhost"@ + , port :: !Int + -- ^ the port of the websocket server, e.g. @8080@ + } + +-- | Set up a websocket server, then call call the continuation (in our case this corresponds to the language server) after accepting a connection +withWebsocket :: + -- | The logger + LogAction IO (WithSeverity WebsocketServerLog) -> + -- | The configuration of the websocket server + WebsocketConfig -> + -- | invoke the lsp server, passing communication functions + (IO BS.StrictByteString -> (BSL.LazyByteString -> IO ()) -> IO r) -> + IO () +withWebsocket logger conf startLspServer = do + let wsLogger = L.cmap (fmap WsWebsocketLog) logger + + WS.runServer (host conf) (port conf) $ \pending -> do + conn <- WS.acceptRequest pending + wsLogger <& WebsocketNewConnection `WithSeverity` Debug + + outChan <- newChan + inChan <- newChan + + let inwards = readChan inChan + outwards = writeChan outChan + + WS.withPingThread conn 30 (wsLogger <& WebsocketPing `WithSeverity` Debug) $ do + withAsync (startLspServer inwards outwards) $ \lspAsync -> + ( do + link lspAsync + + race_ + ( forever $ do + msg <- readChan outChan + wsLogger <& WebsocketOutgoingResponse `WithSeverity` Debug + WS.sendTextData conn msg + ) + ( forever $ do + msg <- WS.receiveData conn + wsLogger <& WebsocketIncomingRequest `WithSeverity` Debug + writeChan inChan msg + -- NOTE: since the parser assumes to consume messages + -- incrementally,we need to somehow signal that the + -- content has terminated - we do this by sending the + -- empty string (instead of parsing exactly the content + -- length, like in the stdio case) + writeChan inChan "" + ) + ) + `finally` do + wsLogger <& WebsocketConnectionClosed `WithSeverity` Debug + +{- | Given a 'WebsocketConfig', wait for connections using a websocket server. +The continuation passed is called for every new connection and can be used +to initialize state that is specific to that respective connection. + +This combines 'withWebsocket' and 'runServerWithConfig'. +-} +withWebsocketRunServer :: + -- | Configuration for the websocket + WebsocketConfig -> + {- | How to set up a new 'ServerDefinition' for a specific configuration. z + This is passed as CPS'd 'IO' to allow for setting (- and cleaning) up + a server per websocket connection + -} + ((ServerDefinition config -> IO Int) -> IO Int) -> + -- | The 'IO' logger + LogAction IO (WithSeverity WebsocketServerLog) -> + -- | The logger that logs in 'LspM' to the client + LogAction (LspM config) (WithSeverity WebsocketServerLog) -> + IO () +withWebsocketRunServer wsConf withLspDefinition ioLogger lspLogger = + withWebsocket ioLogger wsConf $ \inwards outwards -> do + withLspDefinition $ \lspDefinition -> + runServerWithConfig + ServerConfig + { ioLogger = L.cmap (fmap WsLspServerLog) ioLogger + , lspLogger = L.cmap (fmap WsLspServerLog) lspLogger + , inwards + , outwards + , -- NOTE: if you run the language server on websockets, you do not + -- need to prepend headers to requests and responses, because + -- the chunking is already handled by the websocket, i.e. there's + -- no situation where the client or the server has to rely on input/ + -- output chunking + prepareOutwards = id + , parseInwards = Attoparsec.takeByteString + } + lspDefinition