{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Language.LSP.Server.Control (
  -- * Running
  runServerWith,
  runServerWithConfig,
  ServerConfig (..),
  LspServerLog (..),

  -- ** Using standard 'IO' 'Handle's
  runServer,

  -- ** Using 'Handle's
  runServerWithHandles,
  prependHeader,
  parseHeaders,

  -- **  Using websockets
  WebsocketConfig (..),
  withWebsocket,
  withWebsocketRunServer,
) where

import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
import Colog.Core qualified as L
import Control.Applicative ((<|>))
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM.TChan
import Control.Exception (catchJust, finally, throwIO)
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 Language.LSP.Logging (defaultClientLogger)
import Language.LSP.Protocol.Message
import Language.LSP.Server.Core
import Language.LSP.Server.Processing qualified as Processing
import Language.LSP.VFS
import Network.WebSockets qualified as WS
import Prettyprinter
import System.IO
import System.IO.Error (isResourceVanishedError)

data LspServerLog
  = LspProcessingLog Processing.LspProcessingLog
  | DecodeInitializeError String
  | HeaderParseFail [String] String
  | EOF
  | BrokenPipeWhileSending TL.Text -- truncated outgoing message (including header)
  | Starting
  | ServerStopped
  | ParsedMsg T.Text
  | SendMsg TL.Text
  | WebsocketLog WebsocketLog
  deriving (Int -> LspServerLog -> ShowS
[LspServerLog] -> ShowS
LspServerLog -> [Char]
(Int -> LspServerLog -> ShowS)
-> (LspServerLog -> [Char])
-> ([LspServerLog] -> ShowS)
-> Show LspServerLog
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LspServerLog -> ShowS
showsPrec :: Int -> LspServerLog -> ShowS
$cshow :: LspServerLog -> [Char]
show :: LspServerLog -> [Char]
$cshowList :: [LspServerLog] -> ShowS
showList :: [LspServerLog] -> ShowS
Show)

instance Pretty LspServerLog where
  pretty :: forall ann. LspServerLog -> Doc ann
pretty LspServerLog
ServerStopped = Doc ann
"Server stopped"
  pretty (LspProcessingLog LspProcessingLog
l) = LspProcessingLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. LspProcessingLog -> Doc ann
pretty LspProcessingLog
l
  pretty (DecodeInitializeError [Char]
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ann
"Got error while decoding initialize:"
      , [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
err
      ]
  pretty (HeaderParseFail [[Char]]
ctxs [Char]
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ann
"Failed to parse message header:"
      , [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" > " [[Char]]
ctxs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
": " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
err
      ]
  pretty LspServerLog
EOF = Doc ann
"Got EOF"
  pretty (BrokenPipeWhileSending Text
msg) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ann
"Broken pipe while sending (client likely closed output handle):"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg)
      ]
  pretty LspServerLog
Starting = Doc ann
"Server starting"
  pretty (ParsedMsg Text
msg) = Doc ann
"---> " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg
  pretty (SendMsg Text
msg) = Doc ann
"<--2-- " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg
  pretty (WebsocketLog WebsocketLog
msg) = Doc ann
"Websocket:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> WebsocketLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. WebsocketLog -> Doc ann
pretty WebsocketLog
msg

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

{- | Convenience function for 'runServerWithHandles' which:
     (1) reads from stdin;
     (2) writes to stdout; and
     (3) logs to stderr and to the client, with some basic filtering.
-}
runServer :: forall config. ServerDefinition config -> IO Int
runServer :: forall config. ServerDefinition config -> IO Int
runServer =
  LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
runServerWithHandles
    LogAction IO (WithSeverity LspServerLog)
defaultIOLogger
    LogAction (LspM config) (WithSeverity LspServerLog)
forall config. LogAction (LspM config) (WithSeverity LspServerLog)
defaultLspLogger
    Handle
stdin
    Handle
stdout

defaultIOLogger :: LogAction IO (WithSeverity LspServerLog)
defaultIOLogger :: LogAction IO (WithSeverity LspServerLog)
defaultIOLogger = (WithSeverity LspServerLog -> [Char])
-> LogAction IO [Char] -> LogAction IO (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap (Doc (Any @(*)) -> [Char]
forall a. Show a => a -> [Char]
show (Doc (Any @(*)) -> [Char])
-> (WithSeverity LspServerLog -> Doc (Any @(*)))
-> WithSeverity LspServerLog
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSeverity LspServerLog -> Doc (Any @(*))
forall {a} {ann}. Pretty a => WithSeverity a -> Doc ann
prettyMsg) LogAction IO [Char]
forall (m :: * -> *). MonadIO m => LogAction m [Char]
L.logStringStderr
 where
  prettyMsg :: WithSeverity a -> Doc ann
prettyMsg WithSeverity a
l = Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Severity -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (WithSeverity a -> Severity
forall msg. WithSeverity msg -> Severity
L.getSeverity WithSeverity a
l) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"] " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (WithSeverity a -> a
forall msg. WithSeverity msg -> msg
L.getMsg WithSeverity a
l)

defaultLspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
defaultLspLogger :: forall config. LogAction (LspM config) (WithSeverity LspServerLog)
defaultLspLogger =
  let clientLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
clientLogger = (WithSeverity LspServerLog -> WithSeverity Text)
-> LogAction (LspM config) (WithSeverity Text)
-> LogAction (LspM config) (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap ((LspServerLog -> Text)
-> WithSeverity LspServerLog -> WithSeverity Text
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Text
T.pack ([Char] -> Text)
-> (LspServerLog -> [Char]) -> LspServerLog -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (Any @(*)) -> [Char]
forall a. Show a => a -> [Char]
show (Doc (Any @(*)) -> [Char])
-> (LspServerLog -> Doc (Any @(*))) -> LspServerLog -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspServerLog -> Doc (Any @(*))
forall a ann. Pretty a => a -> Doc ann
forall ann. LspServerLog -> Doc ann
pretty)) LogAction (LspM config) (WithSeverity Text)
forall c (m :: * -> *).
MonadLsp c m =>
LogAction m (WithSeverity Text)
defaultClientLogger
   in LogAction (LspM config) (WithSeverity LspServerLog)
clientLogger LogAction (LspM config) (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
forall a. Semigroup a => a -> a -> a
<> (forall x. IO x -> LspM config x)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> LogAction m a -> LogAction n a
L.hoistLogAction IO x -> LspM config x
forall x. IO x -> LspM config x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO LogAction IO (WithSeverity LspServerLog)
defaultIOLogger

{- | Starts a language server over the specified handles.
 This function will return once the @exit@ notification is received.
-}
runServerWithHandles ::
  -- | The logger to use outside the main body of the server where we can't assume the ability to send messages.
  LogAction IO (WithSeverity LspServerLog) ->
  -- | The logger to use once the server has started and can successfully send messages.
  LogAction (LspM config) (WithSeverity LspServerLog) ->
  -- | Handle to read client input from.
  Handle ->
  -- | Handle to write output to.
  Handle ->
  ServerDefinition config ->
  IO Int -- exit code
runServerWithHandles :: forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
runServerWithHandles LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger Handle
hin Handle
hout ServerDefinition config
serverDefinition = do
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hin TextEncoding
utf8

  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hout BufferMode
NoBuffering
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hout TextEncoding
utf8

  let
    clientIn :: IO StrictByteString
clientIn = Handle -> Int -> IO StrictByteString
BS.hGetSome Handle
hin Int
defaultChunkSize

    clientOut :: ByteString -> IO ()
clientOut ByteString
out =
      (IOError -> Maybe IOError) -> IO () -> (IOError -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust
        (\IOError
e -> if IOError -> Bool
isResourceVanishedError IOError
e then IOError -> Maybe IOError
forall a. a -> Maybe a
Just IOError
e else Maybe IOError
forall a. Maybe a
Nothing)
        (Handle -> ByteString -> IO ()
BSL.hPut Handle
hout ByteString
out IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
hout)
        ( \IOError
e -> do
            let txt :: Text
txt = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
TL.take Int64
400 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TL.decodeUtf8 ByteString
out -- limit size
            LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> LspServerLog
BrokenPipeWhileSending (Text -> Text
TL.fromStrict Text
txt) LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
            IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
        )

  LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> (ByteString -> IO ())
-> ServerDefinition config
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> (ByteString -> IO ())
-> ServerDefinition config
-> IO Int
runServerWith LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger IO StrictByteString
clientIn ByteString -> IO ()
clientOut ServerDefinition config
serverDefinition

{- | Starts listening and sending requests and responses
 using the specified I/O.

 Assumes that the client sends (and wants to receive) the Content-Length
 header. If you do not want this to be the case, use 'runServerWithConfig'
-}
runServerWith ::
  -- | The logger to use outside the main body of the server where we can't assume the ability to send messages.
  LogAction IO (WithSeverity LspServerLog) ->
  -- | The logger to use once the server has started and can successfully send messages.
  LogAction (LspM config) (WithSeverity LspServerLog) ->
  -- | Client input.
  IO BS.StrictByteString ->
  -- | Function to provide output to.
  (BSL.LazyByteString -> IO ()) ->
  ServerDefinition config ->
  IO Int -- exit code
runServerWith :: forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> (ByteString -> IO ())
-> ServerDefinition config
-> IO Int
runServerWith LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger IO StrictByteString
inwards ByteString -> IO ()
outwards =
  ServerConfig config -> ServerDefinition config -> IO Int
forall config.
ServerConfig config -> ServerDefinition config -> IO Int
runServerWithConfig ServerConfig{prepareOutwards :: ByteString -> ByteString
prepareOutwards = ByteString -> ByteString
prependHeader, parseInwards :: Parser StrictByteString
parseInwards = Parser StrictByteString
parseHeaders, IO StrictByteString
LogAction IO (WithSeverity LspServerLog)
LogAction (LspM config) (WithSeverity LspServerLog)
ByteString -> IO ()
ioLogger :: LogAction IO (WithSeverity LspServerLog)
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
inwards :: IO StrictByteString
outwards :: ByteString -> IO ()
outwards :: ByteString -> IO ()
inwards :: IO StrictByteString
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
ioLogger :: LogAction IO (WithSeverity LspServerLog)
..}

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

data ServerConfig config = ServerConfig
  { forall config.
ServerConfig config -> LogAction IO (WithSeverity LspServerLog)
ioLogger :: LogAction IO (WithSeverity LspServerLog)
  -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages.
  , forall config.
ServerConfig config
-> LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
  -- ^ The logger to use once the server has started and can successfully send messages.
  , forall config. ServerConfig config -> IO StrictByteString
inwards :: IO BS.StrictByteString
  -- ^ Client input.
  , forall config. ServerConfig config -> ByteString -> IO ()
outwards :: BSL.LazyByteString -> IO ()
  -- ^ Function to provide output to.
  , forall config. ServerConfig config -> ByteString -> ByteString
prepareOutwards :: BSL.LazyByteString -> BSL.LazyByteString
  -- ^ how to prepare an outgoing response for sending. This can be used, to e.g. prepend the Content-Length header, c.f. 'prependHeader'
  , forall config. ServerConfig config -> Parser StrictByteString
parseInwards :: Attoparsec.Parser BS.StrictByteString
  -- ^ how to parse the input. This can be used to consume the Content-Length and Content-Type headers, c.f. 'parseHeaders'
  }

runServerWithConfig ::
  ServerConfig config ->
  ServerDefinition config ->
  IO Int
runServerWithConfig :: forall config.
ServerConfig config -> ServerDefinition config -> IO Int
runServerWithConfig ServerConfig{IO StrictByteString
Parser StrictByteString
LogAction IO (WithSeverity LspServerLog)
LogAction (LspM config) (WithSeverity LspServerLog)
ByteString -> IO ()
ByteString -> ByteString
prepareOutwards :: forall config. ServerConfig config -> ByteString -> ByteString
parseInwards :: forall config. ServerConfig config -> Parser StrictByteString
outwards :: forall config. ServerConfig config -> ByteString -> IO ()
inwards :: forall config. ServerConfig config -> IO StrictByteString
lspLogger :: forall config.
ServerConfig config
-> LogAction (LspM config) (WithSeverity LspServerLog)
ioLogger :: forall config.
ServerConfig config -> LogAction IO (WithSeverity LspServerLog)
ioLogger :: LogAction IO (WithSeverity LspServerLog)
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
inwards :: IO StrictByteString
outwards :: ByteString -> IO ()
prepareOutwards :: ByteString -> ByteString
parseInwards :: Parser StrictByteString
..} ServerDefinition config
serverDefinition = do
  LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspServerLog
Starting LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  TChan FromServerMessage
cout <- STM (TChan FromServerMessage) -> IO (TChan FromServerMessage)
forall a. STM a -> IO a
atomically STM (TChan FromServerMessage)
forall a. STM (TChan a)
newTChan :: IO (TChan FromServerMessage)
  IO () -> (Async () -> IO Int) -> IO Int
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (LogAction IO (WithSeverity LspServerLog)
-> TChan FromServerMessage
-> (ByteString -> IO ())
-> (ByteString -> ByteString)
-> IO ()
sendServer LogAction IO (WithSeverity LspServerLog)
ioLogger TChan FromServerMessage
cout ByteString -> IO ()
outwards ByteString -> ByteString
prepareOutwards) ((Async () -> IO Int) -> IO Int) -> (Async () -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Async ()
sendServerAsync -> do
    let sendMsg :: FromServerMessage -> IO ()
sendMsg = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (FromServerMessage -> STM ()) -> FromServerMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan FromServerMessage -> FromServerMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan FromServerMessage
cout
    Int
res <- LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> Parser StrictByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> Parser StrictByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
-> IO Int
ioLoop LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger IO StrictByteString
inwards Parser StrictByteString
parseInwards ServerDefinition config
serverDefinition VFS
emptyVFS FromServerMessage -> IO ()
sendMsg (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
sendServerAsync)
    LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspServerLog
ServerStopped LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
res

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

ioLoop ::
  forall config.
  LogAction IO (WithSeverity LspServerLog) ->
  LogAction (LspM config) (WithSeverity LspServerLog) ->
  IO BS.StrictByteString ->
  Attoparsec.Parser BS.StrictByteString ->
  ServerDefinition config ->
  VFS ->
  (FromServerMessage -> IO ()) ->
  IO () ->
  IO Int
ioLoop :: forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> Parser StrictByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
-> IO Int
ioLoop LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger IO StrictByteString
clientIn Parser StrictByteString
parser ServerDefinition config
serverDefinition VFS
vfs FromServerMessage -> IO ()
sendMsg IO ()
waitSenderFinish = do
  Maybe (StrictByteString, StrictByteString)
minitialize <- LogAction IO (WithSeverity LspServerLog)
-> IO StrictByteString
-> Result StrictByteString
-> IO (Maybe (StrictByteString, StrictByteString))
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspServerLog)
-> IO StrictByteString
-> Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
parseOne LogAction IO (WithSeverity LspServerLog)
ioLogger IO StrictByteString
clientIn (Parser StrictByteString
-> StrictByteString -> Result StrictByteString
forall a. Parser a -> StrictByteString -> Result a
parse Parser StrictByteString
parser StrictByteString
"")
  case Maybe (StrictByteString, StrictByteString)
minitialize of
    Maybe (StrictByteString, StrictByteString)
Nothing -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
    Just (StrictByteString
msg, StrictByteString
remainder) -> do
      case ByteString
-> Either
     [Char] (TRequestMessage @'ClientToServer 'Method_Initialize)
forall a. FromJSON a => ByteString -> Either [Char] a
J.eitherDecode (ByteString
 -> Either
      [Char] (TRequestMessage @'ClientToServer 'Method_Initialize))
-> ByteString
-> Either
     [Char] (TRequestMessage @'ClientToServer 'Method_Initialize)
forall a b. (a -> b) -> a -> b
$ StrictByteString -> ByteString
BSL.fromStrict StrictByteString
msg of
        Left [Char]
err -> do
          LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [Char] -> LspServerLog
DecodeInitializeError [Char]
err LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
          Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
        Right TRequestMessage @'ClientToServer 'Method_Initialize
initialize -> do
          Maybe (LanguageContextEnv config)
mInitResp <- LogAction IO (WithSeverity LspProcessingLog)
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Maybe (LanguageContextEnv config))
forall config.
LogAction IO (WithSeverity LspProcessingLog)
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Maybe (LanguageContextEnv config))
Processing.initializeRequestHandler LogAction IO (WithSeverity LspProcessingLog)
pioLogger ServerDefinition config
serverDefinition VFS
vfs FromServerMessage -> IO ()
sendMsg IO ()
waitSenderFinish TMessage @'ClientToServer @'Request 'Method_Initialize
TRequestMessage @'ClientToServer 'Method_Initialize
initialize
          case Maybe (LanguageContextEnv config)
mInitResp of
            Maybe (LanguageContextEnv config)
Nothing -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
            Just LanguageContextEnv config
env -> LanguageContextEnv config -> LspT config IO Int -> IO Int
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspT config IO Int -> IO Int) -> LspT config IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Result StrictByteString -> LspT config IO Int
loop (Parser StrictByteString
-> StrictByteString -> Result StrictByteString
forall a. Parser a -> StrictByteString -> Result a
parse Parser StrictByteString
parser StrictByteString
remainder)
 where
  pioLogger :: LogAction IO (WithSeverity LspProcessingLog)
pioLogger = (WithSeverity LspProcessingLog -> WithSeverity LspServerLog)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction IO (WithSeverity LspProcessingLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap ((LspProcessingLog -> LspServerLog)
-> WithSeverity LspProcessingLog -> WithSeverity LspServerLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspProcessingLog -> LspServerLog
LspProcessingLog) LogAction IO (WithSeverity LspServerLog)
ioLogger
  pLogger :: LogAction (LspM config) (WithSeverity LspProcessingLog)
pLogger = (WithSeverity LspProcessingLog -> WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspProcessingLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap ((LspProcessingLog -> LspServerLog)
-> WithSeverity LspProcessingLog -> WithSeverity LspServerLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspProcessingLog -> LspServerLog
LspProcessingLog) LogAction (LspM config) (WithSeverity LspServerLog)
logger

  loop :: Result StrictByteString -> LspT config IO Int
loop = Result StrictByteString -> LspT config IO Int
go
   where
    go :: Result StrictByteString -> LspT config IO Int
go Result StrictByteString
r = do
      Bool
b <- LspM config Bool
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
m Bool
isExiting
      if Bool
b
        then Int -> LspT config IO Int
forall a. a -> LspM config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
        else do
          Maybe (StrictByteString, StrictByteString)
res <- LogAction (LspM config) (WithSeverity LspServerLog)
-> IO StrictByteString
-> Result StrictByteString
-> LspM config (Maybe (StrictByteString, StrictByteString))
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspServerLog)
-> IO StrictByteString
-> Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
parseOne LogAction (LspM config) (WithSeverity LspServerLog)
logger IO StrictByteString
clientIn Result StrictByteString
r
          case Maybe (StrictByteString, StrictByteString)
res of
            Maybe (StrictByteString, StrictByteString)
Nothing -> Int -> LspT config IO Int
forall a. a -> LspM config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
            Just (StrictByteString
msg, StrictByteString
remainder) -> do
              LogAction (LspM config) (WithSeverity LspProcessingLog)
-> ByteString -> LspM config ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog) -> ByteString -> m ()
Processing.processMessage LogAction (LspM config) (WithSeverity LspProcessingLog)
pLogger (ByteString -> LspM config ()) -> ByteString -> LspM config ()
forall a b. (a -> b) -> a -> b
$ StrictByteString -> ByteString
BSL.fromStrict StrictByteString
msg
              Result StrictByteString -> LspT config IO Int
go (Parser StrictByteString
-> StrictByteString -> Result StrictByteString
forall a. Parser a -> StrictByteString -> Result a
parse Parser StrictByteString
parser StrictByteString
remainder)

parseOne ::
  MonadIO m =>
  LogAction m (WithSeverity LspServerLog) ->
  IO BS.StrictByteString ->
  Result BS.StrictByteString ->
  m (Maybe (BS.ByteString, BS.ByteString))
parseOne :: forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspServerLog)
-> IO StrictByteString
-> Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
parseOne LogAction m (WithSeverity LspServerLog)
logger IO StrictByteString
clientIn = Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
go
 where
  go :: Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
go (Fail StrictByteString
_ [[Char]]
ctxs [Char]
err) = do
    LogAction m (WithSeverity LspServerLog)
logger LogAction m (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [[Char]] -> [Char] -> LspServerLog
HeaderParseFail [[Char]]
ctxs [Char]
err LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
    Maybe (StrictByteString, StrictByteString)
-> m (Maybe (StrictByteString, StrictByteString))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (StrictByteString, StrictByteString)
forall a. Maybe a
Nothing
  go (Partial StrictByteString -> Result StrictByteString
c) = do
    StrictByteString
bs <- IO StrictByteString -> m StrictByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StrictByteString
clientIn
    Result StrictByteString
-> m (Maybe (StrictByteString, StrictByteString))
go (StrictByteString -> Result StrictByteString
c StrictByteString
bs)
  go (Done StrictByteString
remainder StrictByteString
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
    Maybe (StrictByteString, StrictByteString)
-> m (Maybe (StrictByteString, StrictByteString))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StrictByteString, StrictByteString)
 -> m (Maybe (StrictByteString, StrictByteString)))
-> Maybe (StrictByteString, StrictByteString)
-> m (Maybe (StrictByteString, StrictByteString))
forall a b. (a -> b) -> a -> b
$ (StrictByteString, StrictByteString)
-> Maybe (StrictByteString, StrictByteString)
forall a. a -> Maybe a
Just (StrictByteString
msg, StrictByteString
remainder)

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

data WebsocketLog
  = WebsocketShutDown
  | WebsocketNewConnection
  | WebsocketConnectionClosed
  | WebsocketPing
  | WebsocketStarted
  | WebsocketIncomingRequest
  | WebsocketOutgoingResponse
  deriving stock (Int -> WebsocketLog -> ShowS
[WebsocketLog] -> ShowS
WebsocketLog -> [Char]
(Int -> WebsocketLog -> ShowS)
-> (WebsocketLog -> [Char])
-> ([WebsocketLog] -> ShowS)
-> Show WebsocketLog
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WebsocketLog -> ShowS
showsPrec :: Int -> WebsocketLog -> ShowS
$cshow :: WebsocketLog -> [Char]
show :: WebsocketLog -> [Char]
$cshowList :: [WebsocketLog] -> ShowS
showList :: [WebsocketLog] -> ShowS
Show)

instance Pretty WebsocketLog where
  pretty :: forall ann. WebsocketLog -> Doc ann
pretty WebsocketLog
l = case WebsocketLog
l of
    WebsocketLog
WebsocketPing -> Doc ann
"Ping"
    WebsocketLog
WebsocketStarted -> Doc ann
"Started Server, waiting for connections"
    WebsocketLog
WebsocketShutDown -> Doc ann
"Shut down server"
    WebsocketLog
WebsocketNewConnection -> Doc ann
"New connection established"
    WebsocketLog
WebsocketIncomingRequest -> Doc ann
"Received request"
    WebsocketLog
WebsocketConnectionClosed -> Doc ann
"Closed connection to client"
    WebsocketLog
WebsocketOutgoingResponse -> Doc ann
"Sent response"

-- | 'host' and 'port' of the websocket server to set up
data WebsocketConfig = WebsocketConfig
  { WebsocketConfig -> [Char]
host :: !String
  -- ^ the host of the websocket server, e.g. @"localhost"@
  , WebsocketConfig -> Int
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 :: forall r.
LogAction IO (WithSeverity LspServerLog)
-> WebsocketConfig
-> (IO StrictByteString -> (ByteString -> IO ()) -> IO r)
-> IO ()
withWebsocket LogAction IO (WithSeverity LspServerLog)
logger WebsocketConfig
conf IO StrictByteString -> (ByteString -> IO ()) -> IO r
startLspServer = do
  let wsLogger :: LogAction IO (WithSeverity WebsocketLog)
wsLogger = (WithSeverity WebsocketLog -> WithSeverity LspServerLog)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction IO (WithSeverity WebsocketLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap ((WebsocketLog -> LspServerLog)
-> WithSeverity WebsocketLog -> WithSeverity LspServerLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WebsocketLog -> LspServerLog
WebsocketLog) LogAction IO (WithSeverity LspServerLog)
logger

  [Char] -> Int -> ServerApp -> IO ()
WS.runServer (WebsocketConfig -> [Char]
host WebsocketConfig
conf) (WebsocketConfig -> Int
port WebsocketConfig
conf) (ServerApp -> IO ()) -> ServerApp -> IO ()
forall a b. (a -> b) -> a -> b
$ \PendingConnection
pending -> do
    Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pending
    LogAction IO (WithSeverity WebsocketLog)
wsLogger LogAction IO (WithSeverity WebsocketLog)
-> WithSeverity WebsocketLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& WebsocketLog
WebsocketNewConnection WebsocketLog -> Severity -> WithSeverity WebsocketLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug

    Chan ByteString
outChan <- IO (Chan ByteString)
forall a. IO (Chan a)
newChan
    Chan StrictByteString
inChan <- IO (Chan StrictByteString)
forall a. IO (Chan a)
newChan

    let inwards :: IO StrictByteString
inwards = Chan StrictByteString -> IO StrictByteString
forall a. Chan a -> IO a
readChan Chan StrictByteString
inChan
        outwards :: ByteString -> IO ()
outwards = Chan ByteString -> ByteString -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ByteString
outChan

    Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Int
30 (LogAction IO (WithSeverity WebsocketLog)
wsLogger LogAction IO (WithSeverity WebsocketLog)
-> WithSeverity WebsocketLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& WebsocketLog
WebsocketPing WebsocketLog -> Severity -> WithSeverity WebsocketLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IO r -> (Async r -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IO StrictByteString -> (ByteString -> IO ()) -> IO r
startLspServer IO StrictByteString
inwards ByteString -> IO ()
outwards) ((Async r -> IO ()) -> IO ()) -> (Async r -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async r
lspAsync ->
        ( do
            Async r -> IO ()
forall a. Async a -> IO ()
link Async r
lspAsync

            IO (Any @(*)) -> IO (Any @(*)) -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
              ( IO () -> IO (Any @(*))
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO (Any @(*))) -> IO () -> IO (Any @(*))
forall a b. (a -> b) -> a -> b
$ do
                  ByteString
msg <- Chan ByteString -> IO ByteString
forall a. Chan a -> IO a
readChan Chan ByteString
outChan
                  LogAction IO (WithSeverity WebsocketLog)
wsLogger LogAction IO (WithSeverity WebsocketLog)
-> WithSeverity WebsocketLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& WebsocketLog
WebsocketOutgoingResponse WebsocketLog -> Severity -> WithSeverity WebsocketLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
                  Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn ByteString
msg
              )
              ( IO () -> IO (Any @(*))
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO (Any @(*))) -> IO () -> IO (Any @(*))
forall a b. (a -> b) -> a -> b
$ do
                  StrictByteString
msg <- Connection -> IO StrictByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn
                  LogAction IO (WithSeverity WebsocketLog)
wsLogger LogAction IO (WithSeverity WebsocketLog)
-> WithSeverity WebsocketLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& WebsocketLog
WebsocketIncomingRequest WebsocketLog -> Severity -> WithSeverity WebsocketLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
                  Chan StrictByteString -> StrictByteString -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan StrictByteString
inChan StrictByteString
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)
                  Chan StrictByteString -> StrictByteString -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan StrictByteString
inChan StrictByteString
""
              )
        )
          IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` do
            LogAction IO (WithSeverity WebsocketLog)
wsLogger LogAction IO (WithSeverity WebsocketLog)
-> WithSeverity WebsocketLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& WebsocketLog
WebsocketConnectionClosed WebsocketLog -> Severity -> WithSeverity WebsocketLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
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 :: forall config.
WebsocketConfig
-> ((ServerDefinition config -> IO Int) -> IO Int)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ()
withWebsocketRunServer WebsocketConfig
wsConf (ServerDefinition config -> IO Int) -> IO Int
withLspDefinition LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger =
  LogAction IO (WithSeverity LspServerLog)
-> WebsocketConfig
-> (IO StrictByteString -> (ByteString -> IO ()) -> IO Int)
-> IO ()
forall r.
LogAction IO (WithSeverity LspServerLog)
-> WebsocketConfig
-> (IO StrictByteString -> (ByteString -> IO ()) -> IO r)
-> IO ()
withWebsocket LogAction IO (WithSeverity LspServerLog)
ioLogger WebsocketConfig
wsConf ((IO StrictByteString -> (ByteString -> IO ()) -> IO Int) -> IO ())
-> (IO StrictByteString -> (ByteString -> IO ()) -> IO Int)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \IO StrictByteString
inwards ByteString -> IO ()
outwards -> do
    (ServerDefinition config -> IO Int) -> IO Int
withLspDefinition ((ServerDefinition config -> IO Int) -> IO Int)
-> (ServerDefinition config -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ServerDefinition config
lspDefinition ->
      ServerConfig config -> ServerDefinition config -> IO Int
forall config.
ServerConfig config -> ServerDefinition config -> IO Int
runServerWithConfig
        ServerConfig
          { LogAction IO (WithSeverity LspServerLog)
ioLogger :: LogAction IO (WithSeverity LspServerLog)
ioLogger :: LogAction IO (WithSeverity LspServerLog)
ioLogger
          , LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger
          , IO StrictByteString
inwards :: IO StrictByteString
inwards :: IO StrictByteString
inwards
          , ByteString -> IO ()
outwards :: ByteString -> IO ()
outwards :: ByteString -> IO ()
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 :: ByteString -> ByteString
prepareOutwards = ByteString -> ByteString
forall a. a -> a
id
          , parseInwards :: Parser StrictByteString
parseInwards = Parser StrictByteString
Attoparsec.takeByteString
          }
        ServerDefinition config
lspDefinition

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

-- | 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 :: LogAction IO (WithSeverity LspServerLog)
-> TChan FromServerMessage
-> (ByteString -> IO ())
-> (ByteString -> ByteString)
-> IO ()
sendServer LogAction IO (WithSeverity LspServerLog)
_logger TChan FromServerMessage
msgChan ByteString -> IO ()
clientOut ByteString -> ByteString
prepareMessage = IO ()
go
 where
  go :: IO ()
go = do
    FromServerMessage
msg <- STM FromServerMessage -> IO FromServerMessage
forall a. STM a -> IO a
atomically (STM FromServerMessage -> IO FromServerMessage)
-> STM FromServerMessage -> IO FromServerMessage
forall a b. (a -> b) -> a -> b
$ TChan FromServerMessage -> STM FromServerMessage
forall a. TChan a -> STM a
readTChan TChan FromServerMessage
msgChan

    -- We need to make sure we only send over the content of the message,
    -- and no other tags/wrapper stuff
    let str :: ByteString
str = FromServerMessage -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode FromServerMessage
msg
    let out :: ByteString
out = ByteString -> ByteString
prepareMessage ByteString
str

    ByteString -> IO ()
clientOut ByteString
out
    -- close the client sender when we send out the shutdown request's response
    case FromServerMessage
msg of
      FromServerRsp SMethod @'ClientToServer @'Request m
SMethod_Shutdown TResponseMessage @'ClientToServer m
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      FromServerMessage
_ -> IO ()
go

-- 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

-- | prepend a Content-Length header to the given message
prependHeader :: BSL.LazyByteString -> BSL.LazyByteString
prependHeader :: ByteString -> ByteString
prependHeader ByteString
str =
  [ByteString] -> ByteString
BSL.concat
    [ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Content-Length: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int64
BSL.length ByteString
str)
    , StrictByteString -> ByteString
BSL.fromStrict StrictByteString
_TWO_CRLF
    , ByteString
str
    ]

{- | parse Content-Length and Content-Type headers and then consume
  input with length of the Content-Length
-}
parseHeaders :: Attoparsec.Parser BS.StrictByteString
parseHeaders :: Parser StrictByteString
parseHeaders = do
  Parser StrictByteString () -> Parser StrictByteString ()
forall i a. Parser i a -> Parser i a
try Parser StrictByteString ()
contentType Parser StrictByteString ()
-> Parser StrictByteString () -> Parser StrictByteString ()
forall a.
Parser StrictByteString a
-> Parser StrictByteString a -> Parser StrictByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser StrictByteString ()
forall a. a -> Parser StrictByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Int
len <- Parser StrictByteString Int
contentLength
  Parser StrictByteString () -> Parser StrictByteString ()
forall i a. Parser i a -> Parser i a
try Parser StrictByteString ()
contentType Parser StrictByteString ()
-> Parser StrictByteString () -> Parser StrictByteString ()
forall a.
Parser StrictByteString a
-> Parser StrictByteString a -> Parser StrictByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser StrictByteString ()
forall a. a -> Parser StrictByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  StrictByteString
_ <- StrictByteString -> Parser StrictByteString
string StrictByteString
_ONE_CRLF
  Int -> Parser StrictByteString
Attoparsec.take Int
len
 where
  contentLength :: Parser StrictByteString Int
contentLength = do
    StrictByteString
_ <- StrictByteString -> Parser StrictByteString
string StrictByteString
"Content-Length: "
    Int
len <- Parser StrictByteString Int
forall a. Integral a => Parser a
decimal
    StrictByteString
_ <- StrictByteString -> Parser StrictByteString
string StrictByteString
_ONE_CRLF
    Int -> Parser StrictByteString Int
forall a. a -> Parser StrictByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
len

  contentType :: Parser StrictByteString ()
contentType = do
    StrictByteString
_ <- StrictByteString -> Parser StrictByteString
string StrictByteString
"Content-Type: "
    (Char -> Bool) -> Parser StrictByteString ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')
    StrictByteString
_ <- StrictByteString -> Parser StrictByteString
string StrictByteString
_ONE_CRLF
    () -> Parser StrictByteString ()
forall a. a -> Parser StrictByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

_ONE_CRLF :: BS.StrictByteString
_ONE_CRLF :: StrictByteString
_ONE_CRLF = StrictByteString
"\r\n"
_TWO_CRLF :: BS.StrictByteString
_TWO_CRLF :: StrictByteString
_TWO_CRLF = StrictByteString
"\r\n\r\n"