mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-19 06:45:09 +00:00
Evgeny
5ad6e5f2f3
* deps: use tls-2.0 * roll back RCP "cleanup" * use tls 1.9 --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
120 lines
3.7 KiB
Haskell
120 lines
3.7 KiB
Haskell
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
module Simplex.Messaging.Transport.WebSockets (WS (..)) where
|
|
|
|
import qualified Control.Exception as E
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import qualified Data.X509 as X
|
|
import qualified Network.TLS as T
|
|
import Network.WebSockets
|
|
import Network.WebSockets.Stream (Stream)
|
|
import qualified Network.WebSockets.Stream as S
|
|
import Simplex.Messaging.Transport
|
|
( ALPN,
|
|
TProxy,
|
|
Transport (..),
|
|
TransportConfig (..),
|
|
TransportError (..),
|
|
TransportPeer (..),
|
|
closeTLS,
|
|
smpBlockSize,
|
|
withTlsUnique,
|
|
)
|
|
import Simplex.Messaging.Transport.Buffer (trimCR)
|
|
import System.IO.Error (isEOFError)
|
|
|
|
data WS = WS
|
|
{ wsPeer :: TransportPeer,
|
|
tlsUniq :: ByteString,
|
|
wsALPN :: Maybe ALPN,
|
|
wsStream :: Stream,
|
|
wsConnection :: Connection,
|
|
wsTransportConfig :: TransportConfig,
|
|
wsServerCerts :: X.CertificateChain
|
|
}
|
|
|
|
websocketsOpts :: ConnectionOptions
|
|
websocketsOpts =
|
|
defaultConnectionOptions
|
|
{ connectionCompressionOptions = NoCompression,
|
|
connectionFramePayloadSizeLimit = SizeLimit $ fromIntegral smpBlockSize,
|
|
connectionMessageDataSizeLimit = SizeLimit 65536
|
|
}
|
|
|
|
instance Transport WS where
|
|
transportName :: TProxy WS -> String
|
|
transportName _ = "WebSockets"
|
|
|
|
transportPeer :: WS -> TransportPeer
|
|
transportPeer = wsPeer
|
|
|
|
transportConfig :: WS -> TransportConfig
|
|
transportConfig = wsTransportConfig
|
|
|
|
getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
|
|
getServerConnection = getWS TServer
|
|
|
|
getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
|
|
getClientConnection = getWS TClient
|
|
|
|
getServerCerts :: WS -> X.CertificateChain
|
|
getServerCerts = wsServerCerts
|
|
|
|
getSessionALPN :: WS -> Maybe ALPN
|
|
getSessionALPN = wsALPN
|
|
|
|
tlsUnique :: WS -> ByteString
|
|
tlsUnique = tlsUniq
|
|
|
|
closeConnection :: WS -> IO ()
|
|
closeConnection = S.close . wsStream
|
|
|
|
cGet :: WS -> Int -> IO ByteString
|
|
cGet c n = do
|
|
s <- receiveData (wsConnection c)
|
|
if B.length s == n
|
|
then pure s
|
|
else E.throwIO TEBadBlock
|
|
|
|
cPut :: WS -> ByteString -> IO ()
|
|
cPut = sendBinaryData . wsConnection
|
|
|
|
getLn :: WS -> IO ByteString
|
|
getLn c = do
|
|
s <- trimCR <$> receiveData (wsConnection c)
|
|
if B.null s || B.last s /= '\n'
|
|
then E.throwIO TEBadBlock
|
|
else pure $ B.init s
|
|
|
|
getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS
|
|
getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
|
|
where
|
|
connectWS tlsUniq = do
|
|
s <- makeTLSContextStream cxt
|
|
wsConnection <- connectPeer wsPeer s
|
|
wsALPN <- T.getNegotiatedProtocol cxt
|
|
pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
|
|
connectPeer :: TransportPeer -> Stream -> IO Connection
|
|
connectPeer TServer = acceptClientRequest
|
|
connectPeer TClient = sendClientRequest
|
|
acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
|
|
sendClientRequest s = newClientConnection s "" "/" websocketsOpts []
|
|
|
|
makeTLSContextStream :: T.Context -> IO Stream
|
|
makeTLSContextStream cxt =
|
|
S.makeStream readStream writeStream
|
|
where
|
|
readStream :: IO (Maybe ByteString)
|
|
readStream = (Just <$> T.recvData cxt) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
|
|
where
|
|
handleTlsEOF = \case
|
|
T.PostHandshake T.Error_EOF -> pure Nothing
|
|
e -> E.throwIO e
|
|
handleEOF e = if isEOFError e then pure Nothing else E.throwIO e
|
|
writeStream :: Maybe LB.ByteString -> IO ()
|
|
writeStream = maybe (closeTLS cxt) (T.sendData cxt)
|