{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}

-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Language.LSP.Server.Control
  (
  -- * Running
    runServer
  , runServerWith
  , runServerWithHandles
  , LspServerLog (..)
  ) where

import qualified Colog.Core as L
import           Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Monad
import           Control.Monad.STM
import           Control.Monad.IO.Class
import qualified Data.Aeson as J
import qualified Data.Attoparsec.ByteString as Attoparsec
import Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString as BS
import Data.ByteString.Builder.Extra (defaultChunkSize)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Text.Prettyprint.Doc
import           Data.List
import           Language.LSP.Server.Core
import qualified Language.LSP.Server.Processing as Processing
import           Language.LSP.Types
import           Language.LSP.VFS
import Language.LSP.Logging (defaultClientLogger)
import           System.IO

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

instance Pretty LspServerLog where
  pretty :: LspServerLog -> Doc ann
pretty (LspProcessingLog LspProcessingLog
l) = LspProcessingLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LspProcessingLog
l
  pretty (DecodeInitializeError String
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [
      Doc ann
"Got error while decoding initialize:"
      , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err
      ]
  pretty (HeaderParseFail [String]
ctxs String
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [
      Doc ann
"Failed to parse message header:"
      , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" > " [String]
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
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err
      ]
  pretty LspServerLog
EOF = Doc ann
"Got EOF"
  pretty LspServerLog
Starting = Doc ann
"Starting server"
  pretty (ParsedMsg Text
msg) = Doc ann
"---> " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> 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 a ann. Pretty a => a -> Doc ann
pretty Text
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 :: 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)
ioLogger
  LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger
  Handle
stdin
  Handle
stdout
  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 a ann. Pretty a => a -> Doc ann
pretty (WithSeverity a -> a
forall msg. WithSeverity msg -> msg
L.getMsg WithSeverity a
l)
    ioLogger :: LogAction IO (WithSeverity LspServerLog)
    ioLogger :: LogAction IO (WithSeverity LspServerLog)
ioLogger = (WithSeverity LspServerLog -> String)
-> LogAction IO String -> LogAction IO (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
L.cmap (Doc (Any @*) -> String
forall a. Show a => a -> String
show (Doc (Any @*) -> String)
-> (WithSeverity LspServerLog -> Doc (Any @*))
-> WithSeverity LspServerLog
-> String
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 String
forall (m :: * -> *). MonadIO m => LogAction m String
L.logStringStderr
    lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
    lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)
lspLogger =
      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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack (String -> Text)
-> (LspServerLog -> String) -> LspServerLog -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (Any @*) -> String
forall a. Show a => a -> String
show (Doc (Any @*) -> String)
-> (LspServerLog -> Doc (Any @*)) -> LspServerLog -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspServerLog -> Doc (Any @*)
forall a ann. Pretty a => a -> 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 forall x. IO x -> LspM config x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO LogAction IO (WithSeverity LspServerLog)
ioLogger

-- | Starts a language server over the specified handles.
-- This function will return once the @exit@ notification is received.
runServerWithHandles ::
    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.
    -> LogAction (LspM config) (WithSeverity LspServerLog)
    -- ^ The logger to use once the server has started and can successfully send messages.
    -> Handle
    -- ^ Handle to read client input from.
    -> Handle
    -- ^ Handle to write output to.
    -> ServerDefinition config
    -> IO Int         -- exit code
runServerWithHandles :: 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 ByteString
clientIn = Handle -> Int -> IO ByteString
BS.hGetSome Handle
hin Int
defaultChunkSize

    clientOut :: ByteString -> IO ()
clientOut ByteString
out = do
      Handle -> ByteString -> IO ()
BSL.hPut Handle
hout ByteString
out
      Handle -> IO ()
hFlush Handle
hout

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

-- | Starts listening and sending requests and responses
-- using the specified I/O.
runServerWith ::
    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.
    -> LogAction (LspM config) (WithSeverity LspServerLog)
    -- ^ The logger to use once the server has started and can successfully send messages.
    -> IO BS.ByteString
    -- ^ Client input.
    -> (BSL.ByteString -> IO ())
    -- ^ Function to provide output to.
    -> ServerDefinition config
    -> IO Int         -- exit code
runServerWith :: LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> (ByteString -> IO ())
-> ServerDefinition config
-> IO Int
runServerWith LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger IO ByteString
clientIn ByteString -> IO ()
clientOut 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 Value
cout <- STM (TChan Value) -> IO (TChan Value)
forall a. STM a -> IO a
atomically STM (TChan Value)
forall a. STM (TChan a)
newTChan :: IO (TChan J.Value)
  ThreadId
_rhpid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity LspServerLog)
-> TChan Value -> (ByteString -> IO ()) -> IO ()
sendServer LogAction IO (WithSeverity LspServerLog)
ioLogger TChan Value
cout ByteString -> IO ()
clientOut

  let sendMsg :: a -> IO ()
sendMsg a
msg = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Value
cout (Value -> STM ()) -> Value -> STM ()
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
J.toJSON a
msg

  (VFS -> IO ()) -> IO ()
forall r. (VFS -> IO r) -> IO r
initVFS ((VFS -> IO ()) -> IO ()) -> (VFS -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> do
    LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
ioLoop LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger IO ByteString
clientIn ServerDefinition config
serverDefinition VFS
vfs FromServerMessage -> IO ()
forall a. ToJSON a => a -> IO ()
sendMsg

  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1

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

ioLoop ::
  forall config
  .  LogAction IO (WithSeverity LspServerLog)
  -> LogAction (LspM config) (WithSeverity LspServerLog)
  -> IO BS.ByteString
  -> ServerDefinition config
  -> VFS
  -> (FromServerMessage -> IO ())
  -> IO ()
ioLoop :: LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> IO ()
ioLoop LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM config) (WithSeverity LspServerLog)
logger IO ByteString
clientIn ServerDefinition config
serverDefinition VFS
vfs FromServerMessage -> IO ()
sendMsg = do
  Maybe (ByteString, ByteString)
minitialize <- LogAction IO (WithSeverity LspServerLog)
-> IO ByteString
-> Result ByteString
-> IO (Maybe (ByteString, ByteString))
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspServerLog)
-> IO ByteString
-> Result ByteString
-> m (Maybe (ByteString, ByteString))
parseOne LogAction IO (WithSeverity LspServerLog)
ioLogger IO ByteString
clientIn (Parser ByteString -> ByteString -> Result ByteString
forall a. Parser a -> ByteString -> Result a
parse Parser ByteString
parser ByteString
"")
  case Maybe (ByteString, ByteString)
minitialize of
    Maybe (ByteString, ByteString)
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (ByteString
msg,ByteString
remainder) -> do
      case ByteString
-> Either String (RequestMessage @'FromClient 'Initialize)
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode (ByteString
 -> Either String (RequestMessage @'FromClient 'Initialize))
-> ByteString
-> Either String (RequestMessage @'FromClient 'Initialize)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
msg of
        Left String
err -> LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String -> LspServerLog
DecodeInitializeError String
err LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
        Right RequestMessage @'FromClient 'Initialize
initialize -> do
          Maybe (LanguageContextEnv config)
mInitResp <- ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> Message @'FromClient @'Request 'Initialize
-> IO (Maybe (LanguageContextEnv config))
forall config.
ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> Message @'FromClient @'Request 'Initialize
-> IO (Maybe (LanguageContextEnv config))
Processing.initializeRequestHandler ServerDefinition config
serverDefinition VFS
vfs FromServerMessage -> IO ()
sendMsg Message @'FromClient @'Request 'Initialize
RequestMessage @'FromClient 'Initialize
initialize
          case Maybe (LanguageContextEnv config)
mInitResp of
            Maybe (LanguageContextEnv config)
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just LanguageContextEnv config
env -> LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspT config IO () -> IO ()) -> LspT config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Result ByteString -> LspT config IO ()
loop (Parser ByteString -> ByteString -> Result ByteString
forall a. Parser a -> ByteString -> Result a
parse Parser ByteString
parser ByteString
remainder)
  where

    loop :: Result BS.ByteString -> LspM config ()
    loop :: Result ByteString -> LspT config IO ()
loop = Result ByteString -> LspT config IO ()
go
      where
        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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspProcessingLog -> LspServerLog
LspProcessingLog) LogAction (LspM config) (WithSeverity LspServerLog)
logger
        go :: Result ByteString -> LspT config IO ()
go Result ByteString
r = do
          Maybe (ByteString, ByteString)
res <- LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> Result ByteString
-> LspM config (Maybe (ByteString, ByteString))
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspServerLog)
-> IO ByteString
-> Result ByteString
-> m (Maybe (ByteString, ByteString))
parseOne LogAction (LspM config) (WithSeverity LspServerLog)
logger IO ByteString
clientIn Result ByteString
r
          case Maybe (ByteString, ByteString)
res of
            Maybe (ByteString, ByteString)
Nothing -> () -> LspT config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (ByteString
msg,ByteString
remainder) -> do
              LogAction (LspM config) (WithSeverity LspProcessingLog)
-> ByteString -> LspT config IO ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog) -> ByteString -> m ()
Processing.processMessage LogAction (LspM config) (WithSeverity LspProcessingLog)
pLogger (ByteString -> LspT config IO ())
-> ByteString -> LspT config IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
msg
              Result ByteString -> LspT config IO ()
go (Parser ByteString -> ByteString -> Result ByteString
forall a. Parser a -> ByteString -> Result a
parse Parser ByteString
parser ByteString
remainder)

    parser :: Parser ByteString
parser = do
      ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"Content-Length: "
      Int
len <- Parser Int
forall a. Integral a => Parser a
decimal
      ByteString
_ <- ByteString -> Parser ByteString
string ByteString
_TWO_CRLF
      Int -> Parser ByteString
Attoparsec.take Int
len

parseOne ::
  MonadIO m
  => LogAction m (WithSeverity LspServerLog)
  -> IO BS.ByteString
  -> Result BS.ByteString
  -> m (Maybe (BS.ByteString,BS.ByteString))
parseOne :: LogAction m (WithSeverity LspServerLog)
-> IO ByteString
-> Result ByteString
-> m (Maybe (ByteString, ByteString))
parseOne LogAction m (WithSeverity LspServerLog)
logger IO ByteString
clientIn = Result ByteString -> m (Maybe (ByteString, ByteString))
go
  where
    go :: Result ByteString -> m (Maybe (ByteString, ByteString))
go (Fail ByteString
_ [String]
ctxs String
err) = do
      LogAction m (WithSeverity LspServerLog)
logger LogAction m (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [String] -> String -> LspServerLog
HeaderParseFail [String]
ctxs String
err LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
      Maybe (ByteString, ByteString)
-> m (Maybe (ByteString, ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
    go (Partial ByteString -> Result ByteString
c) = do
      ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
clientIn
      if ByteString -> Bool
BS.null ByteString
bs
        then do
          LogAction m (WithSeverity LspServerLog)
logger LogAction m (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspServerLog
EOF LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
          Maybe (ByteString, ByteString)
-> m (Maybe (ByteString, ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
        else Result ByteString -> m (Maybe (ByteString, ByteString))
go (ByteString -> Result ByteString
c ByteString
bs)
    go (Done ByteString
remainder ByteString
msg) = do
      LogAction m (WithSeverity LspServerLog)
logger LogAction m (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> LspServerLog
ParsedMsg (ByteString -> Text
T.decodeUtf8 ByteString
msg) LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
      Maybe (ByteString, ByteString)
-> m (Maybe (ByteString, ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ByteString, ByteString)
 -> m (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> m (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
msg,ByteString
remainder)

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

-- | Simple server to make sure all output is serialised
sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()
sendServer :: LogAction IO (WithSeverity LspServerLog)
-> TChan Value -> (ByteString -> IO ()) -> IO ()
sendServer LogAction IO (WithSeverity LspServerLog)
logger TChan Value
msgChan ByteString -> IO ()
clientOut = do
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Value
msg <- STM Value -> IO Value
forall a. STM a -> IO a
atomically (STM Value -> IO Value) -> STM Value -> IO Value
forall a b. (a -> b) -> a -> b
$ TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan TChan Value
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 = Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode Value
msg

    let out :: ByteString
out = [ByteString] -> ByteString
BSL.concat
                [ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Content-Length: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BSL.length ByteString
str)
                , ByteString -> ByteString
BSL.fromStrict ByteString
_TWO_CRLF
                , ByteString
str ]

    ByteString -> IO ()
clientOut ByteString
out
    LogAction IO (WithSeverity LspServerLog)
logger LogAction IO (WithSeverity LspServerLog)
-> WithSeverity LspServerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> LspServerLog
SendMsg (ByteString -> Text
TL.decodeUtf8 ByteString
str) LspServerLog -> Severity -> WithSeverity LspServerLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug

-- |
--
--
_TWO_CRLF :: BS.ByteString
_TWO_CRLF :: ByteString
_TWO_CRLF = ByteString
"\r\n\r\n"