Skip to content

Commit fe620f1

Browse files
michaelpjmichaelpj
committed
Modularise the server input and output
The goal here is to make the `Control` module as boring and dispensible as possible, so that users can put the pieces together as they like. Thisi s a step in that direction, tackling the server in/out threads.
1 parent 9b1d6ba commit fe620f1

File tree

5 files changed

+189
-156
lines changed

5 files changed

+189
-156
lines changed

‎lsp/lsp.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ library
4848
Language.LSP.Server.Control
4949
Language.LSP.Server.Core
5050
Language.LSP.Server.Processing
51+
Language.LSP.Server.IO
5152

5253
ghc-options: -Wall
5354
build-depends:

‎lsp/src/Language/LSP/Server.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
{-# LANGUAGE TypeOperators #-}
2-
3-
module Language.LSP.Server (
4-
module Language.LSP.Server.Control,
5-
VFSData (..),
6-
ServerDefinition (..),
2+
module Language.LSP.Server
3+
( module Language.LSP.Server.Control
4+
, module Language.LSP.Server.IO
5+
, VFSData(..)
6+
, ServerDefinition(..)
77

88
-- * Handlers
99
Handlers (..),
@@ -63,3 +63,4 @@ module Language.LSP.Server (
6363

6464
import Language.LSP.Server.Control
6565
import Language.LSP.Server.Core
66+
import Language.LSP.Server.IO

‎lsp/src/Language/LSP/Server/Control.hs‎

Lines changed: 27 additions & 144 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE LambdaCase #-}
21
{-# LANGUAGE OverloadedStrings #-}
32
{-# LANGUAGE RankNTypes #-}
43
{-# LANGUAGE ScopedTypeVariables #-}
@@ -14,58 +13,39 @@ module Language.LSP.Server.Control (
1413
LspServerLog (..),
1514
) where
1615

17-
import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
16+
import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), cmap, (<&))
1817
import Colog.Core qualified as L
1918
import Control.Applicative ((<|>))
20-
import Control.Concurrent
19+
import Control.Concurrent.Async qualified as Async
2120
import Control.Concurrent.STM.TChan
2221
import Control.Monad
2322
import Control.Monad.IO.Class
2423
import Control.Monad.STM
2524
import Data.Aeson qualified as J
26-
import Data.Attoparsec.ByteString qualified as Attoparsec
27-
import Data.Attoparsec.ByteString.Char8
2825
import Data.ByteString qualified as BS
2926
import Data.ByteString.Builder.Extra (defaultChunkSize)
30-
import Data.ByteString.Lazy qualified as BSL
31-
import Data.List
3227
import Data.Text qualified as T
33-
import Data.Text.Lazy qualified as TL
34-
import Data.Text.Lazy.Encoding qualified as TL
3528
import Data.Text.Prettyprint.Doc
3629
import Language.LSP.Logging (defaultClientLogger)
3730
import Language.LSP.Protocol.Message
3831
import Language.LSP.Server.Core
32+
import Language.LSP.Server.IO qualified as IO
3933
import Language.LSP.Server.Processing qualified as Processing
4034
import Language.LSP.VFS
4135
import System.IO
4236

4337
data LspServerLog
4438
= LspProcessingLog Processing.LspProcessingLog
45-
| DecodeInitializeError String
46-
| HeaderParseFail [String] String
47-
| EOF
39+
| LspIoLog IO.LspIoLog
4840
| Starting
49-
| ParsedMsg T.Text
50-
| SendMsg TL.Text
41+
| Stopping
5142
deriving (Show)
5243

5344
instance Pretty LspServerLog where
5445
pretty (LspProcessingLog l) = pretty l
55-
pretty (DecodeInitializeError err) =
56-
vsep
57-
[ "Got error while decoding initialize:"
58-
, pretty err
59-
]
60-
pretty (HeaderParseFail ctxs err) =
61-
vsep
62-
[ "Failed to parse message header:"
63-
, pretty (intercalate " > " ctxs) <> ": " <+> pretty err
64-
]
65-
pretty EOF = "Got EOF"
46+
pretty (LspIoLog l) = pretty l
6647
pretty Starting = "Starting server"
67-
pretty (ParsedMsg msg) = "---> " <> pretty msg
68-
pretty (SendMsg msg) = "<--2-- " <> pretty msg
48+
pretty Stopping = "Stopping server"
6949

7050
-- ---------------------------------------------------------------------
7151

@@ -115,7 +95,7 @@ runServerWithHandles ioLogger logger hin hout serverDefinition = do
11595
clientIn = BS.hGetSome hin defaultChunkSize
11696

11797
clientOut out = do
118-
BSL.hPut hout out
98+
BS.hPut hout out
11999
hFlush hout
120100

121101
runServerWith ioLogger logger clientIn clientOut serverDefinition
@@ -131,129 +111,32 @@ runServerWith ::
131111
-- | Client input.
132112
IO BS.ByteString ->
133113
-- | Function to provide output to.
134-
(BSL.ByteString -> IO ()) ->
114+
(BS.ByteString -> IO ()) ->
135115
ServerDefinition config ->
136116
IO Int -- exit code
137117
runServerWith ioLogger logger clientIn clientOut serverDefinition = do
138118
ioLogger <& Starting `WithSeverity` Info
139119

140-
cout <- atomically newTChan :: IO (TChan J.Value)
141-
_rhpid <- forkIO $ sendServer ioLogger cout clientOut
120+
cout <- atomically newTChan
121+
cin <- atomically newTChan
142122

143-
let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg
123+
let serverOut = IO.serverOut (cmap (fmap LspIoLog) ioLogger) (atomically $ readTChan cout) clientOut
124+
serverIn = IO.serverIn (cmap (fmap LspIoLog) ioLogger) (atomically . writeTChan cin) clientIn
144125

145-
initVFS $ \vfs -> do
146-
ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg
126+
sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg
127+
recvMsg = atomically $ readTChan cin
147128

148-
return 1
129+
processingLoop = initVFS $ \vfs ->
130+
Processing.processingLoop
131+
(cmap (fmap LspProcessingLog) ioLogger)
132+
(cmap (fmap LspProcessingLog) logger)
133+
vfs
134+
serverDefinition
135+
sendMsg
136+
recvMsg
149137

150-
-- ---------------------------------------------------------------------
151-
152-
ioLoop ::
153-
forall config.
154-
LogAction IO (WithSeverity LspServerLog) ->
155-
LogAction (LspM config) (WithSeverity LspServerLog) ->
156-
IO BS.ByteString ->
157-
ServerDefinition config ->
158-
VFS ->
159-
(FromServerMessage -> IO ()) ->
160-
IO ()
161-
ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do
162-
minitialize <- parseOne ioLogger clientIn (parse parser "")
163-
case minitialize of
164-
Nothing -> pure ()
165-
Just (msg, remainder) -> do
166-
case J.eitherDecode $ BSL.fromStrict msg of
167-
Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error
168-
Right initialize -> do
169-
mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg initialize
170-
case mInitResp of
171-
Nothing -> pure ()
172-
Just env -> runLspT env $ loop (parse parser remainder)
173-
where
174-
pioLogger = L.cmap (fmap LspProcessingLog) ioLogger
175-
pLogger = L.cmap (fmap LspProcessingLog) logger
176-
177-
loop :: Result BS.ByteString -> LspM config ()
178-
loop = go
179-
where
180-
go r = do
181-
res <- parseOne logger clientIn r
182-
case res of
183-
Nothing -> pure ()
184-
Just (msg, remainder) -> do
185-
Processing.processMessage pLogger $ BSL.fromStrict msg
186-
go (parse parser remainder)
187-
188-
parser = do
189-
try contentType <|> (return ())
190-
len <- contentLength
191-
try contentType <|> (return ())
192-
_ <- string _ONE_CRLF
193-
Attoparsec.take len
194-
195-
contentLength = do
196-
_ <- string "Content-Length: "
197-
len <- decimal
198-
_ <- string _ONE_CRLF
199-
return len
200-
201-
contentType = do
202-
_ <- string "Content-Type: "
203-
skipWhile (/= '\r')
204-
_ <- string _ONE_CRLF
205-
return ()
206-
207-
parseOne ::
208-
MonadIO m =>
209-
LogAction m (WithSeverity LspServerLog) ->
210-
IO BS.ByteString ->
211-
Result BS.ByteString ->
212-
m (Maybe (BS.ByteString, BS.ByteString))
213-
parseOne logger clientIn = go
214-
where
215-
go (Fail _ ctxs err) = do
216-
logger <& HeaderParseFail ctxs err `WithSeverity` Error
217-
pure Nothing
218-
go (Partial c) = do
219-
bs <- liftIO clientIn
220-
if BS.null bs
221-
then do
222-
logger <& EOF `WithSeverity` Error
223-
pure Nothing
224-
else go (c bs)
225-
go (Done remainder msg) = do
226-
-- TODO: figure out how to re-enable
227-
-- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447
228-
-- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug
229-
pure $ Just (msg, remainder)
230-
231-
-- ---------------------------------------------------------------------
232-
233-
-- | Simple server to make sure all output is serialised
234-
sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()
235-
sendServer _logger msgChan clientOut = do
236-
forever $ do
237-
msg <- atomically $ readTChan msgChan
238-
239-
-- We need to make sure we only send over the content of the message,
240-
-- and no other tags/wrapper stuff
241-
let str = J.encode msg
242-
243-
let out =
244-
BSL.concat
245-
[ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)
246-
, BSL.fromStrict _TWO_CRLF
247-
, str
248-
]
249-
250-
clientOut out
251-
252-
-- TODO: figure out how to re-enable
253-
-- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447
254-
-- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug
138+
-- Bind all the threads together so that any of them terminating will terminate everything
139+
serverOut `Async.race_` serverIn `Async.race_` processingLoop
255140

256-
_ONE_CRLF :: BS.ByteString
257-
_ONE_CRLF = "\r\n"
258-
_TWO_CRLF :: BS.ByteString
259-
_TWO_CRLF = "\r\n\r\n"
141+
ioLogger <& Stopping `WithSeverity` Info
142+
return 0

‎lsp/src/Language/LSP/Server/IO.hs‎

Lines changed: 122 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,122 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
4+
module Language.LSP.Server.IO (serverOut, serverIn, LspIoLog) where
5+
6+
import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
7+
import Control.Applicative ((<|>))
8+
import Control.Monad
9+
import Data.Aeson qualified as J
10+
import Data.Attoparsec.ByteString qualified as Attoparsec
11+
import Data.Attoparsec.ByteString.Char8
12+
import Data.ByteString qualified as BS
13+
import Data.ByteString.Lazy qualified as BSL
14+
import Data.List
15+
import Data.Text qualified as T
16+
import Data.Text.Encoding qualified as T
17+
import Data.Text.Prettyprint.Doc
18+
19+
data LspIoLog
20+
= HeaderParseFail [String] String
21+
| BodyParseFail String
22+
| RecvMsg BS.ByteString
23+
| SendMsg BS.ByteString
24+
| EOF
25+
deriving (Show)
26+
27+
instance Pretty LspIoLog where
28+
pretty (HeaderParseFail ctxs err) =
29+
vsep
30+
[ "Failed to parse message header:"
31+
, pretty (intercalate " > " ctxs) <> ": " <+> pretty err
32+
]
33+
pretty (BodyParseFail err) =
34+
vsep
35+
[ "Failed to parse message body:"
36+
, pretty err
37+
]
38+
pretty (RecvMsg msg) = "---> " <> pretty (T.decodeUtf8 msg)
39+
pretty (SendMsg msg) = "<--- " <> pretty (T.decodeUtf8 msg)
40+
pretty EOF = "Got EOF"
41+
42+
-- | Process which receives messages and sends them. Output queue of messages ensures they are serialised.
43+
serverIn ::
44+
LogAction IO (WithSeverity LspIoLog) ->
45+
-- | Channel to send out messages on.
46+
(J.Value -> IO ()) ->
47+
-- | Action to pull in new messages (e.g. from a handle).
48+
IO BS.ByteString ->
49+
IO ()
50+
serverIn logger msgOut clientIn = do
51+
bs <- clientIn
52+
loop (parse parser bs)
53+
where
54+
loop :: Result BS.ByteString -> IO ()
55+
loop (Fail _ ctxs err) = do
56+
logger <& HeaderParseFail ctxs err `WithSeverity` Error
57+
pure ()
58+
loop (Partial c) = do
59+
bs <- clientIn
60+
if BS.null bs
61+
then do
62+
logger <& EOF `WithSeverity` Error
63+
pure ()
64+
else loop (c bs)
65+
loop (Done remainder parsed) = do
66+
logger <& RecvMsg parsed `WithSeverity` Debug
67+
case J.eitherDecode (BSL.fromStrict parsed) of
68+
-- Note: this is recoverable, because we can just discard the
69+
-- message and keep going, whereas a header parse failure is
70+
-- not recoverable
71+
Left err -> logger <& BodyParseFail err `WithSeverity` Error
72+
Right msg -> msgOut msg
73+
loop (parse parser remainder)
74+
75+
parser = do
76+
try contentType <|> (return ())
77+
len <- contentLength
78+
try contentType <|> (return ())
79+
_ <- string _ONE_CRLF
80+
Attoparsec.take len
81+
82+
contentLength = do
83+
_ <- string "Content-Length: "
84+
len <- decimal
85+
_ <- string _ONE_CRLF
86+
return len
87+
88+
contentType = do
89+
_ <- string "Content-Type: "
90+
skipWhile (/= '\r')
91+
_ <- string _ONE_CRLF
92+
return ()
93+
94+
-- | Process which receives messages and sends them. Input queue of messages ensures they are serialised.
95+
serverOut ::
96+
LogAction IO (WithSeverity LspIoLog) ->
97+
-- | Channel to receive messages on.
98+
IO J.Value ->
99+
-- | Action to send messages out on (e.g. via a handle).
100+
(BS.ByteString -> IO ()) ->
101+
IO ()
102+
serverOut logger msgIn clientOut = forever $ do
103+
msg <- msgIn
104+
105+
-- We need to make sure we only send over the content of the message,
106+
-- and no other tags/wrapper stuff
107+
let str = J.encode msg
108+
109+
let out =
110+
BS.concat
111+
[ T.encodeUtf8 $ T.pack $ "Content-Length: " ++ show (BSL.length str)
112+
, _TWO_CRLF
113+
, BSL.toStrict str
114+
]
115+
116+
clientOut out
117+
logger <& SendMsg out `WithSeverity` Debug
118+
119+
_ONE_CRLF :: BS.ByteString
120+
_ONE_CRLF = "\r\n"
121+
_TWO_CRLF :: BS.ByteString
122+
_TWO_CRLF = "\r\n\r\n"

0 commit comments

Comments
 (0)