diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 026383b29..56082e2c9 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -146,7 +146,7 @@ clientDisconnected c@Client {subscriptions, connected} = do | otherwise = Just c' sameClientSession :: Client -> Client -> Bool -sameClientSession Client {sessionId = s} Client {sessionId = s'} = False -- TODO replace with s == s' +sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s' cancelSub :: MonadUnliftIO m => Sub -> m () cancelSub = \case diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index ae87563b6..c7ded0a36 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -29,17 +29,19 @@ module Simplex.Messaging.Transport Transport (..), TProxy (..), ATransport (..), + TransportPeer (..), - -- * Transport over TLS 1.3 + -- * Transport over TLS 1.2 runTransportServer, runTransportClient, loadTLSServerParams, + withTlsUnique, - -- * TLS 1.3 Transport + -- * TLS 1.2 Transport TLS (..), closeTLS, - -- * SMP encrypted transport + -- * SMP transport THandle (..), TransportError (..), serverHandshake, @@ -55,9 +57,10 @@ module Simplex.Messaging.Transport ) where -import Control.Applicative (optional, (<|>)) +import Control.Applicative ((<|>)) import Control.Monad.Except import Control.Monad.IO.Unlift +import Control.Monad.Trans.Except (throwE) import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) @@ -67,7 +70,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import Data.Default (def) import Data.Functor (($>)) -import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.String @@ -78,7 +80,7 @@ import Generic.Random (genericArbitraryU) import Network.Socket import qualified Network.TLS as T import qualified Network.TLS.Extra as TE -import Simplex.Messaging.Parsers (base64P, parseAll, parseRead1, parseString) +import Simplex.Messaging.Parsers (parseAll, parseRead1, parseString) import Simplex.Messaging.Util (bshow) import System.Exit (exitFailure) import System.IO.Error @@ -96,12 +98,17 @@ class Transport c where transportName :: TProxy c -> String - -- | Upgrade client TLS context to connection (used in the server) + transportPeer :: c -> TransportPeer + + -- | Upgrade server TLS context to connection (used in the server) getServerConnection :: T.Context -> IO c - -- | Upgrade server TLS context to connection (used in the client) + -- | Upgrade client TLS context to connection (used in the client) getClientConnection :: T.Context -> IO c + -- | tls-unique channel binding per RFC5929 + tlsUnique :: c -> ByteString + -- | Close connection closeConnection :: c -> IO () @@ -118,32 +125,37 @@ class Transport c where putLn :: c -> ByteString -> IO () putLn c = cPut c . (<> "\r\n") +data TransportPeer = TClient | TServer + deriving (Eq, Show) + data TProxy c = TProxy data ATransport = forall c. Transport c => ATransport (TProxy c) --- * Transport over TLS 1.3 +-- * Transport over TLS 1.2 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar. -- -- All accepted connections are passed to the passed function. -runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m () +runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m () runTransportServer started port serverParams server = do clients <- newTVarIO S.empty E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) - $ \sock -> forever $ do - c <- liftIO $ acceptConnection sock - tid <- forkFinally (server c) (const $ liftIO $ closeConnection c) - atomically . modifyTVar clients $ S.insert tid + $ \sock -> forever $ connectClients sock clients `E.catch` \(_ :: E.SomeException) -> pure () where + connectClients :: Socket -> TVar (Set ThreadId) -> m () + connectClients sock clients = do + c <- liftIO $ acceptConnection sock + tid <- server c `forkFinally` const (liftIO $ closeConnection c) + atomically . modifyTVar clients $ S.insert tid closeServer :: TVar (Set ThreadId) -> Socket -> IO () closeServer clients sock = do readTVarIO clients >>= mapM_ killThread close sock void . atomically $ tryPutTMVar started False - acceptConnection :: Transport c => Socket -> IO c + acceptConnection :: Socket -> IO c acceptConnection sock = do (newSock, _) <- accept sock ctx <- connectTLS "server" serverParams newSock @@ -211,9 +223,15 @@ loadTLSServerParams certificateFile privateKeyFile = T.serverSupported = supportedParameters } --- * TLS 1.3 Transport +-- * TLS 1.2 Transport -data TLS = TLS {tlsContext :: T.Context, buffer :: TVar ByteString, getLock :: TMVar ()} +data TLS = TLS + { tlsContext :: T.Context, + tlsPeer :: TransportPeer, + tlsUniq :: ByteString, + buffer :: TVar ByteString, + getLock :: TMVar () + } connectTLS :: T.TLSParams p => String -> p -> Socket -> IO T.Context connectTLS party params sock = @@ -222,11 +240,21 @@ connectTLS party params sock = `E.catch` \(e :: E.SomeException) -> putStrLn (party <> " exception: " <> show e) >> E.throwIO e pure ctx -newTLS :: T.Context -> IO TLS -newTLS tlsContext = do - buffer <- newTVarIO "" - getLock <- newTMVarIO () - pure TLS {tlsContext, buffer, getLock} +getTLS :: TransportPeer -> T.Context -> IO TLS +getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS + where + newTLS tlsUniq = do + buffer <- newTVarIO "" + getLock <- newTMVarIO () + pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, buffer, getLock} + +withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c +withTlsUnique peer cxt f = + cxtFinished peer cxt + >>= maybe (closeTLS cxt >> ioe_EOF) f + where + cxtFinished TServer = T.getPeerFinished + cxtFinished TClient = T.getFinished closeTLS :: T.Context -> IO () closeTLS ctx = @@ -244,17 +272,19 @@ clientParams = supportedParameters :: T.Supported supportedParameters = def - { T.supportedVersions = [T.TLS13], - T.supportedCiphers = [TE.cipher_TLS13_CHACHA20POLY1305_SHA256], + { T.supportedVersions = [T.TLS12], + T.supportedCiphers = [TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256], T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)], T.supportedSecureRenegotiation = False, T.supportedGroups = [T.X448, T.X25519] } instance Transport TLS where - transportName _ = "TLS 1.3" - getServerConnection = newTLS - getClientConnection = newTLS + transportName _ = "TLS 1.2" + transportPeer = tlsPeer + getServerConnection = getTLS TServer + getClientConnection = getTLS TClient + tlsUnique = tlsUniq closeConnection tls = closeTLS $ tlsContext tls cGet :: TLS -> Int -> IO ByteString @@ -339,13 +369,10 @@ data Handshake = Handshake serializeHandshake :: Handshake -> ByteString serializeHandshake Handshake {sessionId, smpVersion} = - encode sessionId <> " " <> serializeSMPVersion smpVersion <> " " + sessionId <> " " <> serializeSMPVersion smpVersion <> " " handshakeP :: Parser Handshake -handshakeP = Handshake <$> base64OrEmptyP <* A.space <*> smpVersionP <* A.space - -base64OrEmptyP :: Parser ByteString -base64OrEmptyP = fromMaybe "" <$> optional base64P +handshakeP = Handshake <$> A.takeWhile (/= ' ') <* A.space <*> smpVersionP <* A.space -- | Error of SMP encrypted transport over TCP. data TransportError @@ -407,9 +434,9 @@ tGetBlock THandle {connection = c, blockSize} = -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a serverHandshake :: Transport c => c -> Int -> ExceptT TransportError IO (THandle c) serverHandshake c blockSize = do - let th = transportHandle c blockSize + let th@THandle {sessionId} = tHandle c blockSize _ <- getPeerHello th - sendHelloToPeer th "" + sendHelloToPeer th sessionId pure th -- | Client SMP transport handshake. @@ -417,10 +444,12 @@ serverHandshake c blockSize = do -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a clientHandshake :: forall c. Transport c => c -> Int -> ExceptT TransportError IO (THandle c) clientHandshake c blockSize = do - let th = transportHandle c blockSize + let th@THandle {sessionId} = tHandle c blockSize sendHelloToPeer th "" - Handshake {sessionId} <- getPeerHello th - pure (th :: THandle c) {sessionId} + Handshake {sessionId = sessId} <- getPeerHello th + if sessionId == sessId + then pure th + else throwE TEBadSession sendHelloToPeer :: Transport c => THandle c -> ByteString -> ExceptT TransportError IO () sendHelloToPeer th sessionId = @@ -433,10 +462,6 @@ getPeerHello th = ExceptT $ parseHandshake <$> tGetBlock th parseHandshake :: ByteString -> Either TransportError Handshake parseHandshake = first (const $ TEHandshake PARSE) . A.parseOnly handshakeP -transportHandle :: c -> Int -> THandle c -transportHandle c blockSize = do - THandle - { connection = c, - sessionId = "", - blockSize - } +tHandle :: Transport c => c -> Int -> THandle c +tHandle c blockSize = + THandle {connection = c, sessionId = encode $ tlsUnique c, blockSize} diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs index e979f52f4..962cae7a9 100644 --- a/src/Simplex/Messaging/Transport/WebSockets.hs +++ b/src/Simplex/Messaging/Transport/WebSockets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module Simplex.Messaging.Transport.WebSockets (WS (..)) where @@ -11,9 +12,22 @@ 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 (TProxy, Transport (..), TransportError (..), closeTLS, trimCR) +import Simplex.Messaging.Transport + ( TProxy, + Transport (..), + TransportError (..), + TransportPeer (..), + closeTLS, + trimCR, + withTlsUnique, + ) -data WS = WS {wsStream :: Stream, wsConnection :: Connection} +data WS = WS + { wsPeer :: TransportPeer, + tlsUniq :: ByteString, + wsStream :: Stream, + wsConnection :: Connection + } websocketsOpts :: ConnectionOptions websocketsOpts = @@ -27,21 +41,17 @@ instance Transport WS where transportName :: TProxy WS -> String transportName _ = "WebSockets" + transportPeer :: WS -> TransportPeer + transportPeer = wsPeer + getServerConnection :: T.Context -> IO WS - getServerConnection ctx = do - s <- makeTLSContextStream ctx - WS s <$> acceptClientRequest s - where - acceptClientRequest :: Stream -> IO Connection - acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest + getServerConnection = getWS TServer getClientConnection :: T.Context -> IO WS - getClientConnection ctx = do - s <- makeTLSContextStream ctx - WS s <$> sendClientRequest s - where - sendClientRequest :: Stream -> IO Connection - sendClientRequest s = newClientConnection s "" "/" websocketsOpts [] + getClientConnection = getWS TClient + + tlsUnique :: WS -> ByteString + tlsUnique = tlsUniq closeConnection :: WS -> IO () closeConnection = S.close . wsStream @@ -63,16 +73,27 @@ instance Transport WS where then E.throwIO TEBadBlock else pure $ B.init s -makeTLSContextStream :: T.Context -> IO S.Stream -makeTLSContextStream tlsContext = +getWS :: TransportPeer -> T.Context -> IO WS +getWS wsPeer cxt = withTlsUnique wsPeer cxt connectWS + where + connectWS tlsUniq = do + s <- makeTLSContextStream cxt + wsConnection <- connectPeer wsPeer s + pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection} + 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 tlsContext) `E.catch` \case + (Just <$> T.recvData cxt) `E.catch` \case T.Error_EOF -> pure Nothing e -> E.throwIO e writeStream :: Maybe BL.ByteString -> IO () - writeStream = \case - Nothing -> closeTLS tlsContext - Just bs -> T.sendData tlsContext bs + writeStream = maybe (closeTLS cxt) (T.sendData cxt) diff --git a/stack.yaml b/stack.yaml index 945175a35..3ab1f0d98 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,6 +39,11 @@ extra-deps: - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + # - ../hs-tls/core + - github: simplex-chat/hs-tls + commit: cea6d52c512716ff09adcac86ebc95bb0b3bb797 + subdirs: + - core # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a