Skip to content

Extract Websocket module to avoid CPP #644

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
fendor merged 1 commit into from
Aug 10, 2026
+155 −145
Merged

Extract Websocket module to avoid CPP #644

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
13 changes: 8 additions & 5 deletions lsp/lsp.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -81,7 +89,6 @@ library
, unordered-containers ^>=0.2

if flag(websocket)
cpp-options: -DENABLE_WEBSOCKET
build-depends:
websockets ^>=0.13

Expand Down Expand Up @@ -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
Expand Down
140 changes: 0 additions & 140 deletions lsp/src/Language/LSP/Server/Control.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
Expand All @@ -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 (..), (<&))
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 */

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -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
Expand Down
147 changes: 147 additions & 0 deletions lsp/src/Language/LSP/Server/Control/Websocket.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Loading