use tls-unique as session ID, switch to TLS 1.2 in tls package fork (#230)

* use tls-unique as session ID, switch to TLS 1.2 in tls package fork

* Update src/Simplex/Messaging/Transport.hs

* Update src/Simplex/Messaging/Transport/WebSockets.hs

Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>

Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>

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

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}

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)

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