{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Simplex.Messaging.Transport
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module defines basic TCP server and client and SMP protocol encrypted transport over TCP.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
module Simplex.Messaging.Transport
  ( -- * SMP transport parameters
    SMPVersion,
    VersionSMP,
    VersionRangeSMP,
    THandleSMP,
    alpnSupportedSMPHandshakes,
    supportedClientSMPRelayVRange,
    supportedServerSMPRelayVRange,
    supportedProxyClientSMPRelayVRange,
    proxiedSMPRelayVRange,
    minClientSMPRelayVersion,
    minServerSMPRelayVersion,
    currentClientSMPRelayVersion,
    currentServerSMPRelayVersion,
    authCmdsSMPVersion,
    sendingProxySMPVersion,
    sndAuthKeySMPVersion,
    deletedEventSMPVersion,
    encryptedBlockSMPVersion,
    blockedEntitySMPVersion,
    shortLinksSMPVersion,
    serviceCertsSMPVersion,
    newNtfCredsSMPVersion,
    clientNoticesSMPVersion,
    simplexMQVersion,
    smpBlockSize,
    TransportConfig (..),

    -- * Transport connection class
    Transport (..),
    TProxy (..),
    ATransport (..),
    ASrvTransport,
    TransportPeer (..),
    STransportPeer (..),
    TransportPeerI (..),
    getServerVerifyKey,

    -- * TLS Transport
    TLS (..),
    SessionId,
    ServiceId,
    EntityId (..),
    pattern NoEntity,
    ALPN,
    connectTLS,
    closeTLS,
    defaultSupportedParams,
    defaultSupportedParamsHTTPS,
    withTlsUnique,

    -- * SMP transport
    THandle (..),
    THandleParams (..),
    THandleAuth (..),
    CertChainPubKey (..),
    ServiceCredentials (..),
    THClientService' (..),
    THClientService,
    THPeerClientService,
    SMPServiceRole (..),
    TSbChainKeys (..),
    TransportError (..),
    HandshakeError (..),
    smpServerHandshake,
    smpClientHandshake,
    tPutBlock,
    tGetBlock,
    sendHandshake,
    getHandshake,
    smpTHParamsSetVersion,
  )
where

import Control.Applicative (optional)
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except (throwE)
import qualified Data.Aeson.TH as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.Bitraversable (bimapM)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Default (def)
import Data.Functor (($>))
import Data.Kind (Type)
import Data.Tuple (swap)
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Word (Word16)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import GHC.IO.Handle.Internals (ioe_EOF)
import Network.Socket
import qualified Network.TLS as T
import qualified Network.TLS.Extra as TE
import qualified Paths_simplexmq as SMQ
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
import Simplex.Messaging.Transport.Buffer
import Simplex.Messaging.Transport.Shared
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.IO.Error (isEOFError)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E

-- * Transport parameters

smpBlockSize :: Int
smpBlockSize :: Int
smpBlockSize = Int
16384

-- SMP protocol version history:
-- 1 - binary protocol encoding (1/1/2022)
-- 2 - message flags (used to control notifications, 6/6/2022)
-- 3 - encrypt message timestamp and flags together with the body when delivered to the recipient (7/5/2022)
-- 4 - support command batching (7/17/2022)
-- 5 - basic auth for SMP servers (11/12/2022)
-- 6 - allow creating queues without subscribing (9/10/2023)
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
-- 8 - SMP proxy for sender commands (6/03/2024)
-- 9 - faster handshake: SKEY command for sender to secure queue (6/30/2024)
-- 10 - DELD event to subscriber when queue is deleted via another connnection (9/11/2024)
-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024)
-- 12 - BLOCKED error for blocked queues (1/11/2025)
-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
-- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
-- 16 - service certificates (5/31/2025)
-- 17 - create notification credentials with NEW (7/12/2025)
-- 18 - support client notices (10/10/2025)

data SMPVersion

instance VersionScope SMPVersion

type VersionSMP = Version SMPVersion

type VersionRangeSMP = VersionRange SMPVersion

pattern VersionSMP :: Word16 -> VersionSMP
pattern $mVersionSMP :: forall {r}. VersionSMP -> (Word16 -> r) -> ((# #) -> r) -> r
$bVersionSMP :: Word16 -> VersionSMP
VersionSMP v = Version v

_subModeSMPVersion :: VersionSMP
_subModeSMPVersion :: VersionSMP
_subModeSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
6

authCmdsSMPVersion :: VersionSMP
authCmdsSMPVersion :: VersionSMP
authCmdsSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
7

sendingProxySMPVersion :: VersionSMP
sendingProxySMPVersion :: VersionSMP
sendingProxySMPVersion = Word16 -> VersionSMP
VersionSMP Word16
8

sndAuthKeySMPVersion :: VersionSMP
sndAuthKeySMPVersion :: VersionSMP
sndAuthKeySMPVersion = Word16 -> VersionSMP
VersionSMP Word16
9

deletedEventSMPVersion :: VersionSMP
deletedEventSMPVersion :: VersionSMP
deletedEventSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
10

encryptedBlockSMPVersion :: VersionSMP
encryptedBlockSMPVersion :: VersionSMP
encryptedBlockSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
11

blockedEntitySMPVersion :: VersionSMP
blockedEntitySMPVersion :: VersionSMP
blockedEntitySMPVersion = Word16 -> VersionSMP
VersionSMP Word16
12

proxyServerHandshakeSMPVersion :: VersionSMP
proxyServerHandshakeSMPVersion :: VersionSMP
proxyServerHandshakeSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
14

shortLinksSMPVersion :: VersionSMP
shortLinksSMPVersion :: VersionSMP
shortLinksSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
15

serviceCertsSMPVersion :: VersionSMP
serviceCertsSMPVersion :: VersionSMP
serviceCertsSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
16

newNtfCredsSMPVersion :: VersionSMP
newNtfCredsSMPVersion :: VersionSMP
newNtfCredsSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
17

clientNoticesSMPVersion :: VersionSMP
clientNoticesSMPVersion :: VersionSMP
clientNoticesSMPVersion = Word16 -> VersionSMP
VersionSMP Word16
18

minClientSMPRelayVersion :: VersionSMP
minClientSMPRelayVersion :: VersionSMP
minClientSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
6

minServerSMPRelayVersion :: VersionSMP
minServerSMPRelayVersion :: VersionSMP
minServerSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
6

currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
18

legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
6

currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
18

-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
-- SMP proxy sets it to lower than its current version
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = Word16 -> VersionSMP
VersionSMP Word16
17

-- minimal supported protocol version is 6
-- TODO remove code that supports sending commands without batching
supportedClientSMPRelayVRange :: VersionRangeSMP
supportedClientSMPRelayVRange :: VersionRangeSMP
supportedClientSMPRelayVRange = VersionSMP -> VersionSMP -> VersionRangeSMP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMP
minClientSMPRelayVersion VersionSMP
currentClientSMPRelayVersion

legacyServerSMPRelayVRange :: VersionRangeSMP
legacyServerSMPRelayVRange :: VersionRangeSMP
legacyServerSMPRelayVRange = VersionSMP -> VersionSMP -> VersionRangeSMP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMP
minServerSMPRelayVersion VersionSMP
legacyServerSMPRelayVersion

supportedServerSMPRelayVRange :: VersionRangeSMP
supportedServerSMPRelayVRange :: VersionRangeSMP
supportedServerSMPRelayVRange = VersionSMP -> VersionSMP -> VersionRangeSMP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMP
minServerSMPRelayVersion VersionSMP
currentServerSMPRelayVersion

supportedProxyClientSMPRelayVRange :: VersionRangeSMP
supportedProxyClientSMPRelayVRange :: VersionRangeSMP
supportedProxyClientSMPRelayVRange = VersionSMP -> VersionSMP -> VersionRangeSMP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMP
minServerSMPRelayVersion VersionSMP
currentServerSMPRelayVersion

proxiedSMPRelayVRange :: VersionRangeSMP
proxiedSMPRelayVRange :: VersionRangeSMP
proxiedSMPRelayVRange = VersionSMP -> VersionSMP -> VersionRangeSMP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMP
sendingProxySMPVersion VersionSMP
proxiedSMPRelayVersion

alpnSupportedSMPHandshakes :: [ALPN]
alpnSupportedSMPHandshakes :: [ALPN]
alpnSupportedSMPHandshakes = [ALPN
"smp/1"]

simplexMQVersion :: String
simplexMQVersion :: String
simplexMQVersion = Version -> String
showVersion Version
SMQ.version

-- * Transport connection class

data TransportConfig = TransportConfig
  { TransportConfig -> Bool
logTLSErrors :: Bool,
    TransportConfig -> Maybe Int
transportTimeout :: Maybe Int
  }

class Typeable c => Transport (c :: TransportPeer -> Type) where
  transport :: forall p. ATransport p
  transport = TProxy c p -> ATransport p
forall (p :: TransportPeer) (c :: TransportPeer -> *).
Transport c =>
TProxy c p -> ATransport p
ATransport (forall (c :: TransportPeer -> *) (p :: TransportPeer). TProxy c p
TProxy @c @p)

  transportName :: TProxy c p -> String

  transportConfig :: c p -> TransportConfig

  -- | Upgrade TLS context to connection
  getTransportConnection :: TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (c p)

  -- | Whether TLS certificate chain was provided to peer
  -- It is always True for the server.
  -- It is True for the client when server requested it AND non-empty chain is sent.
  certificateSent :: c p -> Bool

  -- | TLS certificate chain, server's in the client, client's in the server (empty chain for non-service clients)
  getPeerCertChain :: c p -> X.CertificateChain

  -- | tls-unique channel binding per RFC5929
  tlsUnique :: c p -> SessionId

  -- | ALPN value negotiated for the session
  getSessionALPN :: c p -> Maybe ALPN

  -- | Close connection
  closeConnection :: c p -> IO ()

  -- | Read fixed number of bytes from connection
  cGet :: c p -> Int -> IO ByteString

  -- | Write bytes to connection
  cPut :: c p -> ByteString -> IO ()

  -- | Receive ByteString from connection, allowing LF or CRLF termination.
  getLn :: c p -> IO ByteString

  -- | Send ByteString to connection terminating it with CRLF.
  putLn :: c p -> ByteString -> IO ()
  putLn c p
c = c p -> ALPN -> IO ()
forall (p :: TransportPeer). c p -> ALPN -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> ALPN -> IO ()
cPut c p
c (ALPN -> IO ()) -> (ALPN -> ALPN) -> ALPN -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> ALPN
"\r\n")

data TransportPeer = TClient | TServer
  deriving (TransportPeer -> TransportPeer -> Bool
(TransportPeer -> TransportPeer -> Bool)
-> (TransportPeer -> TransportPeer -> Bool) -> Eq TransportPeer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportPeer -> TransportPeer -> Bool
== :: TransportPeer -> TransportPeer -> Bool
$c/= :: TransportPeer -> TransportPeer -> Bool
/= :: TransportPeer -> TransportPeer -> Bool
Eq, Int -> TransportPeer -> ShowS
[TransportPeer] -> ShowS
TransportPeer -> String
(Int -> TransportPeer -> ShowS)
-> (TransportPeer -> String)
-> ([TransportPeer] -> ShowS)
-> Show TransportPeer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportPeer -> ShowS
showsPrec :: Int -> TransportPeer -> ShowS
$cshow :: TransportPeer -> String
show :: TransportPeer -> String
$cshowList :: [TransportPeer] -> ShowS
showList :: [TransportPeer] -> ShowS
Show)

data STransportPeer (p :: TransportPeer) where
  STClient :: STransportPeer 'TClient
  STServer :: STransportPeer 'TServer

class TransportPeerI p where sTransportPeer :: STransportPeer p

instance TransportPeerI 'TClient where sTransportPeer :: STransportPeer 'TClient
sTransportPeer = STransportPeer 'TClient
STClient

instance TransportPeerI 'TServer where sTransportPeer :: STransportPeer 'TServer
sTransportPeer = STransportPeer 'TServer
STServer

data TProxy (c :: TransportPeer -> Type) (p :: TransportPeer) = TProxy

data ATransport p = forall c. Transport c => ATransport (TProxy c p)

type ASrvTransport = ATransport 'TServer

getServerVerifyKey :: Transport c => c 'TClient -> Either String C.APublicVerifyKey
getServerVerifyKey :: forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient -> Either String APublicVerifyKey
getServerVerifyKey c 'TClient
c =
  case c 'TClient -> CertificateChain
forall (p :: TransportPeer). c p -> CertificateChain
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> CertificateChain
getPeerCertChain c 'TClient
c of
    X.CertificateChain (SignedExact Certificate
server : [SignedExact Certificate]
_ca) -> SignedExact Certificate -> Either String APublicVerifyKey
getCertVerifyKey SignedExact Certificate
server
    CertificateChain
_ -> String -> Either String APublicVerifyKey
forall a b. a -> Either a b
Left String
"no certificate chain"

getCertVerifyKey :: X.SignedCertificate -> Either String C.APublicVerifyKey
getCertVerifyKey :: SignedExact Certificate -> Either String APublicVerifyKey
getCertVerifyKey SignedExact Certificate
cert = PubKey -> Either String APublicVerifyKey
forall k. CryptoPublicKey k => PubKey -> Either String k
C.x509ToPublic' (PubKey -> Either String APublicVerifyKey)
-> PubKey -> Either String APublicVerifyKey
forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
X.certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X.signedObject (Signed Certificate -> Certificate)
-> Signed Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X.getSigned SignedExact Certificate
cert

-- * TLS Transport

data TLS (p :: TransportPeer) = TLS
  { forall (p :: TransportPeer). TLS p -> Context
tlsContext :: T.Context,
    forall (p :: TransportPeer). TLS p -> ALPN
tlsUniq :: ByteString,
    forall (p :: TransportPeer). TLS p -> TBuffer
tlsBuffer :: TBuffer,
    forall (p :: TransportPeer). TLS p -> Maybe ALPN
tlsALPN :: Maybe ALPN,
    forall (p :: TransportPeer). TLS p -> Bool
tlsCertSent :: Bool, -- see comment for certificateSent
    forall (p :: TransportPeer). TLS p -> CertificateChain
tlsPeerCert :: X.CertificateChain,
    forall (p :: TransportPeer). TLS p -> TransportConfig
tlsTransportConfig :: TransportConfig
  }

type ALPN = ByteString

connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context
connectTLS :: forall p.
TLSParams p =>
Maybe String -> TransportConfig -> p -> Socket -> IO Context
connectTLS Maybe String
host_ TransportConfig {Bool
$sel:logTLSErrors:TransportConfig :: TransportConfig -> Bool
logTLSErrors :: Bool
logTLSErrors} p
params Socket
sock =
  IO Context
-> (Context -> IO ()) -> (Context -> IO Context) -> IO Context
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError (Socket -> p -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
T.contextNew Socket
sock p
params) Context -> IO ()
closeTLS ((Context -> IO Context) -> IO Context)
-> (Context -> IO Context) -> IO Context
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
    IO () -> IO ()
logHandshakeErrors (Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
T.handshake Context
ctx) IO () -> Context -> IO Context
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Context
ctx
  where
    logHandshakeErrors :: IO () -> IO ()
logHandshakeErrors = if Bool
logTLSErrors then (IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` SomeException -> IO ()
logThrow) else IO () -> IO ()
forall a. a -> a
id
    logThrow :: SomeException -> IO ()
logThrow SomeException
e = String -> IO ()
putStrLn (String
"TLS error" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
host String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
e
    host :: String
host = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
h -> String
" (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
h String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")") Maybe String
host_

getTLS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (TLS p)
getTLS :: forall (p :: TransportPeer).
TransportPeerI p =>
TransportConfig
-> Bool -> CertificateChain -> Context -> IO (TLS p)
getTLS TransportConfig
cfg Bool
tlsCertSent CertificateChain
tlsPeerCert Context
cxt = forall (c :: TransportPeer -> *) (p :: TransportPeer).
TransportPeerI p =>
Context -> (ALPN -> IO (c p)) -> IO (c p)
withTlsUnique @TLS @p Context
cxt ALPN -> IO (TLS p)
newTLS
  where
    newTLS :: ALPN -> IO (TLS p)
newTLS ALPN
tlsUniq = do
      TBuffer
tlsBuffer <- IO TBuffer
newTBuffer
      Maybe ALPN
tlsALPN <- Context -> IO (Maybe ALPN)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe ALPN)
T.getNegotiatedProtocol Context
cxt
      TLS p -> IO (TLS p)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TLS {$sel:tlsContext:TLS :: Context
tlsContext = Context
cxt, Maybe ALPN
$sel:tlsALPN:TLS :: Maybe ALPN
tlsALPN :: Maybe ALPN
tlsALPN, $sel:tlsTransportConfig:TLS :: TransportConfig
tlsTransportConfig = TransportConfig
cfg, Bool
$sel:tlsCertSent:TLS :: Bool
tlsCertSent :: Bool
tlsCertSent, CertificateChain
$sel:tlsPeerCert:TLS :: CertificateChain
tlsPeerCert :: CertificateChain
tlsPeerCert, ALPN
$sel:tlsUniq:TLS :: ALPN
tlsUniq :: ALPN
tlsUniq, TBuffer
$sel:tlsBuffer:TLS :: TBuffer
tlsBuffer :: TBuffer
tlsBuffer}

withTlsUnique :: forall c p. TransportPeerI p => T.Context -> (ByteString -> IO (c p)) -> IO (c p)
withTlsUnique :: forall (c :: TransportPeer -> *) (p :: TransportPeer).
TransportPeerI p =>
Context -> (ALPN -> IO (c p)) -> IO (c p)
withTlsUnique Context
cxt ALPN -> IO (c p)
f =
  Context -> IO (Maybe ALPN)
cxtFinished Context
cxt
    IO (Maybe ALPN) -> (Maybe ALPN -> IO (c p)) -> IO (c p)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (c p) -> (ALPN -> IO (c p)) -> Maybe ALPN -> IO (c p)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Context -> IO ()
closeTLS Context
cxt IO () -> IO (c p) -> IO (c p)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (c p)
forall a. IO a
ioe_EOF) ALPN -> IO (c p)
f
  where
    cxtFinished :: Context -> IO (Maybe ALPN)
cxtFinished = case forall (p :: TransportPeer). TransportPeerI p => STransportPeer p
sTransportPeer @p of
      STransportPeer p
STServer -> Context -> IO (Maybe ALPN)
T.getPeerFinished
      STransportPeer p
STClient -> Context -> IO (Maybe ALPN)
T.getFinished

closeTLS :: T.Context -> IO ()
closeTLS :: Context -> IO ()
closeTLS Context
ctx =
  Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
T.bye Context
ctx -- sometimes socket was closed before 'TLS.bye' so we catch the 'Broken pipe' error here
    IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` Context -> IO ()
T.contextClose Context
ctx
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

defaultSupportedParams :: T.Supported
defaultSupportedParams :: Supported
defaultSupportedParams =
  Supported
forall a. Default a => a
def
    { T.supportedVersions = [T.TLS13, T.TLS12],
      T.supportedCiphers =
        [ TE.cipher_TLS13_CHACHA20POLY1305_SHA256, -- for TLS13
          TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- for TLS12
        ],
      T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
      T.supportedGroups = [T.X448, T.X25519],
      T.supportedSecureRenegotiation = False
    }

-- | A selection of extra parameters to accomodate browser chains
defaultSupportedParamsHTTPS :: T.Supported
defaultSupportedParamsHTTPS :: Supported
defaultSupportedParamsHTTPS =
  Supported
defaultSupportedParams
    { T.supportedCiphers = TE.ciphersuite_strong,
      T.supportedGroups = [T.X25519, T.X448, T.FFDHE4096, T.FFDHE6144, T.FFDHE8192, T.P521],
      T.supportedHashSignatures =
        [ (T.HashIntrinsic, T.SignatureEd448),
          (T.HashIntrinsic, T.SignatureEd25519),
          (T.HashSHA256, T.SignatureECDSA),
          (T.HashSHA384, T.SignatureECDSA),
          (T.HashSHA512, T.SignatureECDSA),
          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA512),
          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA384),
          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA256),
          (T.HashSHA512, T.SignatureRSA),
          (T.HashSHA384, T.SignatureRSA),
          (T.HashSHA256, T.SignatureRSA)
        ]
    }

instance Transport TLS where
  transportName :: forall (p :: TransportPeer). TProxy TLS p -> String
transportName TProxy TLS p
_ = String
"TLS"
  {-# INLINE transportName #-}
  transportConfig :: forall (p :: TransportPeer). TLS p -> TransportConfig
transportConfig = TLS p -> TransportConfig
forall (p :: TransportPeer). TLS p -> TransportConfig
tlsTransportConfig
  {-# INLINE transportConfig #-}
  getTransportConnection :: forall (p :: TransportPeer).
TransportPeerI p =>
TransportConfig
-> Bool -> CertificateChain -> Context -> IO (TLS p)
getTransportConnection = TransportConfig
-> Bool -> CertificateChain -> Context -> IO (TLS p)
forall (p :: TransportPeer).
TransportPeerI p =>
TransportConfig
-> Bool -> CertificateChain -> Context -> IO (TLS p)
getTLS
  {-# INLINE getTransportConnection #-}
  certificateSent :: forall (p :: TransportPeer). TLS p -> Bool
certificateSent = TLS p -> Bool
forall (p :: TransportPeer). TLS p -> Bool
tlsCertSent
  {-# INLINE certificateSent #-}
  getPeerCertChain :: forall (p :: TransportPeer). TLS p -> CertificateChain
getPeerCertChain = TLS p -> CertificateChain
forall (p :: TransportPeer). TLS p -> CertificateChain
tlsPeerCert
  {-# INLINE getPeerCertChain #-}
  getSessionALPN :: forall (p :: TransportPeer). TLS p -> Maybe ALPN
getSessionALPN = TLS p -> Maybe ALPN
forall (p :: TransportPeer). TLS p -> Maybe ALPN
tlsALPN
  {-# INLINE getSessionALPN #-}
  tlsUnique :: forall (p :: TransportPeer). TLS p -> ALPN
tlsUnique = TLS p -> ALPN
forall (p :: TransportPeer). TLS p -> ALPN
tlsUniq
  {-# INLINE tlsUnique #-}
  closeConnection :: forall (p :: TransportPeer). TLS p -> IO ()
closeConnection TLS p
tls = Context -> IO ()
closeTLS (Context -> IO ()) -> Context -> IO ()
forall a b. (a -> b) -> a -> b
$ TLS p -> Context
forall (p :: TransportPeer). TLS p -> Context
tlsContext TLS p
tls
  {-# INLINE closeConnection #-}

  -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
  -- this function may return less than requested number of bytes
  cGet :: TLS p -> Int -> IO ByteString
  cGet :: forall (p :: TransportPeer). TLS p -> Int -> IO ALPN
cGet TLS {Context
$sel:tlsContext:TLS :: forall (p :: TransportPeer). TLS p -> Context
tlsContext :: Context
tlsContext, TBuffer
$sel:tlsBuffer:TLS :: forall (p :: TransportPeer). TLS p -> TBuffer
tlsBuffer :: TBuffer
tlsBuffer, $sel:tlsTransportConfig:TLS :: forall (p :: TransportPeer). TLS p -> TransportConfig
tlsTransportConfig = TransportConfig {$sel:transportTimeout:TransportConfig :: TransportConfig -> Maybe Int
transportTimeout = Maybe Int
t_}} Int
n =
    TBuffer -> Int -> Maybe Int -> IO ALPN -> IO ALPN
getBuffered TBuffer
tlsBuffer Int
n Maybe Int
t_ (Context -> IO ALPN
forall (m :: * -> *). MonadIO m => Context -> m ALPN
T.recvData Context
tlsContext)

  cPut :: TLS p -> ByteString -> IO ()
  cPut :: forall (p :: TransportPeer). TLS p -> ALPN -> IO ()
cPut TLS {Context
$sel:tlsContext:TLS :: forall (p :: TransportPeer). TLS p -> Context
tlsContext :: Context
tlsContext, $sel:tlsTransportConfig:TLS :: forall (p :: TransportPeer). TLS p -> TransportConfig
tlsTransportConfig = TransportConfig {$sel:transportTimeout:TransportConfig :: TransportConfig -> Maybe Int
transportTimeout = Maybe Int
t_}} =
    Maybe Int -> IO () -> IO ()
forall a. Maybe Int -> IO a -> IO a
withTimedErr Maybe Int
t_ (IO () -> IO ()) -> (ALPN -> IO ()) -> ALPN -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
T.sendData Context
tlsContext (ByteString -> IO ()) -> (ALPN -> ByteString) -> ALPN -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALPN -> ByteString
LB.fromStrict

  getLn :: TLS p -> IO ByteString
  getLn :: forall (p :: TransportPeer). TLS p -> IO ALPN
getLn TLS {Context
$sel:tlsContext:TLS :: forall (p :: TransportPeer). TLS p -> Context
tlsContext :: Context
tlsContext, TBuffer
$sel:tlsBuffer:TLS :: forall (p :: TransportPeer). TLS p -> TBuffer
tlsBuffer :: TBuffer
tlsBuffer} = do
    TBuffer -> IO ALPN -> IO ALPN
getLnBuffered TBuffer
tlsBuffer (Context -> IO ALPN
forall (m :: * -> *). MonadIO m => Context -> m ALPN
T.recvData Context
tlsContext) IO ALPN -> [Handler IO ALPN] -> IO ALPN
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`E.catches` [(TLSException -> IO ALPN) -> Handler IO ALPN
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler TLSException -> IO ALPN
forall {a}. TLSException -> IO a
handleTlsEOF, (IOError -> IO ALPN) -> Handler IO ALPN
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler IOError -> IO ALPN
forall {m :: * -> *} {a}. MonadIO m => IOError -> m a
handleEOF]
    where
      handleTlsEOF :: TLSException -> IO a
handleTlsEOF = \case
        T.PostHandshake TLSError
T.Error_EOF -> TransportError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO TransportError
TEBadBlock
        TLSException
e -> TLSException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO TLSException
e
      handleEOF :: IOError -> m a
handleEOF IOError
e = if IOError -> Bool
isEOFError IOError
e then TransportError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO TransportError
TEBadBlock else IOError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO IOError
e

-- * SMP transport

-- | The handle for SMP encrypted transport connection over Transport.
data THandle v c p = THandle
  { forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> c p
connection :: c p,
    forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params :: THandleParams v p
  }

type THandleSMP c p = THandle SMPVersion c p

data THandleParams v p = THandleParams
  { forall v (p :: TransportPeer). THandleParams v p -> ALPN
sessionId :: SessionId,
    forall v (p :: TransportPeer). THandleParams v p -> Int
blockSize :: Int,
    -- | server protocol version range
    forall v (p :: TransportPeer). THandleParams v p -> VersionRange v
thServerVRange :: VersionRange v,
    -- | agreed server protocol version
    forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion :: Version v,
    -- | peer public key for command authorization and shared secrets for entity ID encryption
    forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth :: Maybe (THandleAuth p),
    -- | do NOT send session ID in transmission, but include it into signed message
    -- based on protocol version
    forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId :: Bool,
    -- | keys for additional transport encryption
    forall v (p :: TransportPeer).
THandleParams v p -> Maybe TSbChainKeys
encryptBlock :: Maybe TSbChainKeys,
    -- | send multiple transmissions in a single block
    -- based on protocol version
    forall v (p :: TransportPeer). THandleParams v p -> Bool
batch :: Bool,
    -- | include service signature (or '0' if it is absent), based on protocol version
    forall v (p :: TransportPeer). THandleParams v p -> Bool
serviceAuth :: Bool
  }

data THandleAuth (p :: TransportPeer) where
  THAuthClient ::
    { THandleAuth 'TClient -> PublicKeyX25519
peerServerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
      THandleAuth 'TClient -> CertChainPubKey
peerServerCertKey :: CertChainPubKey, -- the key here is peerServerCertKey signed with server certificate
      THandleAuth 'TClient -> Maybe THClientService
clientService :: Maybe THClientService,
      THandleAuth 'TClient -> Maybe DhSecretX25519
sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
    } ->
    THandleAuth 'TClient
  THAuthServer ::
    { THandleAuth 'TServer -> PrivateKeyX25519
serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
      THandleAuth 'TServer -> Maybe THPeerClientService
peerClientService :: Maybe THPeerClientService,
      THandleAuth 'TServer -> Maybe DhSecretX25519
sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
    } ->
    THandleAuth 'TServer

type THClientService = THClientService' C.PrivateKeyEd25519

type THPeerClientService = THClientService' C.PublicKeyEd25519

data THClientService' k = THClientService
  { forall k. THClientService' k -> ServiceId
serviceId :: ServiceId,
    forall k. THClientService' k -> SMPServiceRole
serviceRole :: SMPServiceRole,
    forall k. THClientService' k -> Fingerprint
serviceCertHash :: XV.Fingerprint,
    forall k. THClientService' k -> k
serviceKey :: k
  }

data TSbChainKeys = TSbChainKeys
  { TSbChainKeys -> TVar SbChainKey
sndKey :: TVar C.SbChainKey,
    TSbChainKeys -> TVar SbChainKey
rcvKey :: TVar C.SbChainKey
  }

-- | TLS-unique channel binding
type SessionId = ByteString

type ServiceId = EntityId

-- this type is used for server entities only
newtype EntityId = EntityId {ServiceId -> ALPN
unEntityId :: ByteString}
  deriving (ServiceId -> ServiceId -> Bool
(ServiceId -> ServiceId -> Bool)
-> (ServiceId -> ServiceId -> Bool) -> Eq ServiceId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServiceId -> ServiceId -> Bool
== :: ServiceId -> ServiceId -> Bool
$c/= :: ServiceId -> ServiceId -> Bool
/= :: ServiceId -> ServiceId -> Bool
Eq, Eq ServiceId
Eq ServiceId =>
(ServiceId -> ServiceId -> Ordering)
-> (ServiceId -> ServiceId -> Bool)
-> (ServiceId -> ServiceId -> Bool)
-> (ServiceId -> ServiceId -> Bool)
-> (ServiceId -> ServiceId -> Bool)
-> (ServiceId -> ServiceId -> ServiceId)
-> (ServiceId -> ServiceId -> ServiceId)
-> Ord ServiceId
ServiceId -> ServiceId -> Bool
ServiceId -> ServiceId -> Ordering
ServiceId -> ServiceId -> ServiceId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ServiceId -> ServiceId -> Ordering
compare :: ServiceId -> ServiceId -> Ordering
$c< :: ServiceId -> ServiceId -> Bool
< :: ServiceId -> ServiceId -> Bool
$c<= :: ServiceId -> ServiceId -> Bool
<= :: ServiceId -> ServiceId -> Bool
$c> :: ServiceId -> ServiceId -> Bool
> :: ServiceId -> ServiceId -> Bool
$c>= :: ServiceId -> ServiceId -> Bool
>= :: ServiceId -> ServiceId -> Bool
$cmax :: ServiceId -> ServiceId -> ServiceId
max :: ServiceId -> ServiceId -> ServiceId
$cmin :: ServiceId -> ServiceId -> ServiceId
min :: ServiceId -> ServiceId -> ServiceId
Ord, Int -> ServiceId -> ShowS
[ServiceId] -> ShowS
ServiceId -> String
(Int -> ServiceId -> ShowS)
-> (ServiceId -> String)
-> ([ServiceId] -> ShowS)
-> Show ServiceId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServiceId -> ShowS
showsPrec :: Int -> ServiceId -> ShowS
$cshow :: ServiceId -> String
show :: ServiceId -> String
$cshowList :: [ServiceId] -> ShowS
showList :: [ServiceId] -> ShowS
Show)
  deriving newtype (Parser ServiceId
ALPN -> Either String ServiceId
ServiceId -> ALPN
(ServiceId -> ALPN)
-> (ALPN -> Either String ServiceId)
-> Parser ServiceId
-> Encoding ServiceId
forall a.
(a -> ALPN) -> (ALPN -> Either String a) -> Parser a -> Encoding a
$csmpEncode :: ServiceId -> ALPN
smpEncode :: ServiceId -> ALPN
$csmpDecode :: ALPN -> Either String ServiceId
smpDecode :: ALPN -> Either String ServiceId
$csmpP :: Parser ServiceId
smpP :: Parser ServiceId
Encoding, Parser ServiceId
ALPN -> Either String ServiceId
ServiceId -> ALPN
(ServiceId -> ALPN)
-> (ALPN -> Either String ServiceId)
-> Parser ServiceId
-> StrEncoding ServiceId
forall a.
(a -> ALPN)
-> (ALPN -> Either String a) -> Parser a -> StrEncoding a
$cstrEncode :: ServiceId -> ALPN
strEncode :: ServiceId -> ALPN
$cstrDecode :: ALPN -> Either String ServiceId
strDecode :: ALPN -> Either String ServiceId
$cstrP :: Parser ServiceId
strP :: Parser ServiceId
StrEncoding)

pattern NoEntity :: EntityId
pattern $mNoEntity :: forall {r}. ServiceId -> ((# #) -> r) -> ((# #) -> r) -> r
$bNoEntity :: ServiceId
NoEntity = EntityId ""

data SMPServerHandshake = SMPServerHandshake
  { SMPServerHandshake -> VersionRangeSMP
smpVersionRange :: VersionRangeSMP,
    SMPServerHandshake -> ALPN
sessionId :: SessionId,
    -- pub key to agree shared secrets for command authorization and entity ID encryption.
    -- todo C.PublicKeyX25519
    SMPServerHandshake -> Maybe CertChainPubKey
authPubKey :: Maybe CertChainPubKey
  }

-- This is the third handshake message that SMP server sends to services
-- in response to them sending `clientService` field.
-- The client would wait for this message in case `clientService` was sent
-- (and it can only be sent once client knows that service supports it.)
data SMPServerHandshakeResponse
  = SMPServerHandshakeResponse {SMPServerHandshakeResponse -> ServiceId
serviceId :: ServiceId}
  | SMPServerHandshakeError {SMPServerHandshakeResponse -> TransportError
handshakeError :: TransportError}

data SMPClientHandshake = SMPClientHandshake
  { -- | agreed SMP server protocol version
    SMPClientHandshake -> VersionSMP
smpVersion :: VersionSMP,
    -- | server identity - CA certificate fingerprint
    SMPClientHandshake -> KeyHash
keyHash :: C.KeyHash,
    -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
    SMPClientHandshake -> Maybe PublicKeyX25519
authPubKey :: Maybe C.PublicKeyX25519,
    -- TODO [certs] remove proxyServer, as serviceInfo includes it as clientRole
    -- | Whether connecting client is a proxy server (send from SMP v12).
    -- This property, if True, disables additional transport encrytion inside TLS.
    -- (Proxy server connection already has additional encryption, so this layer is not needed there).
    SMPClientHandshake -> Bool
proxyServer :: Bool,
    -- | optional long-term service client certificate of a high-volume service using SMP server.
    -- This certificate MUST be used both in TLS and in protocol handshake.
    -- It signs the key that is used to authorize:
    -- - queue creation commands (in addition to authorization by queue key) - it creates association of the queue with this certificate,
    -- - "handover" subscription command (in addition to queue key) - it also creates association,
    -- - bulk subscription command CSUB.
    -- SHA512 hash of this certificate is stored to associate queues with this client.
    -- These certificates are used by the servers and services connecting to SMP servers:
    -- - chat relays,
    -- - notification servers,
    -- - high traffic chat bots,
    -- - high traffic business support clients.
    SMPClientHandshake -> Maybe SMPClientHandshakeService
clientService :: Maybe SMPClientHandshakeService
  }

data SMPClientHandshakeService = SMPClientHandshakeService
  { SMPClientHandshakeService -> SMPServiceRole
serviceRole :: SMPServiceRole,
    SMPClientHandshakeService -> CertChainPubKey
serviceCertKey :: CertChainPubKey
  }

data ServiceCredentials = ServiceCredentials
  { ServiceCredentials -> SMPServiceRole
serviceRole :: SMPServiceRole,
    ServiceCredentials -> Credential
serviceCreds :: T.Credential,
    ServiceCredentials -> Fingerprint
serviceCertHash :: XV.Fingerprint,
    ServiceCredentials -> APrivateSignKey
serviceSignKey :: C.APrivateSignKey
  }

data SMPServiceRole = SRMessaging | SRNotifier | SRProxy deriving (SMPServiceRole -> SMPServiceRole -> Bool
(SMPServiceRole -> SMPServiceRole -> Bool)
-> (SMPServiceRole -> SMPServiceRole -> Bool) -> Eq SMPServiceRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPServiceRole -> SMPServiceRole -> Bool
== :: SMPServiceRole -> SMPServiceRole -> Bool
$c/= :: SMPServiceRole -> SMPServiceRole -> Bool
/= :: SMPServiceRole -> SMPServiceRole -> Bool
Eq, Int -> SMPServiceRole -> ShowS
[SMPServiceRole] -> ShowS
SMPServiceRole -> String
(Int -> SMPServiceRole -> ShowS)
-> (SMPServiceRole -> String)
-> ([SMPServiceRole] -> ShowS)
-> Show SMPServiceRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPServiceRole -> ShowS
showsPrec :: Int -> SMPServiceRole -> ShowS
$cshow :: SMPServiceRole -> String
show :: SMPServiceRole -> String
$cshowList :: [SMPServiceRole] -> ShowS
showList :: [SMPServiceRole] -> ShowS
Show)

instance Encoding SMPClientHandshake where
  smpEncode :: SMPClientHandshake -> ALPN
smpEncode SMPClientHandshake {$sel:smpVersion:SMPClientHandshake :: SMPClientHandshake -> VersionSMP
smpVersion = VersionSMP
v, KeyHash
$sel:keyHash:SMPClientHandshake :: SMPClientHandshake -> KeyHash
keyHash :: KeyHash
keyHash, Maybe PublicKeyX25519
$sel:authPubKey:SMPClientHandshake :: SMPClientHandshake -> Maybe PublicKeyX25519
authPubKey :: Maybe PublicKeyX25519
authPubKey, Bool
$sel:proxyServer:SMPClientHandshake :: SMPClientHandshake -> Bool
proxyServer :: Bool
proxyServer, Maybe SMPClientHandshakeService
$sel:clientService:SMPClientHandshake :: SMPClientHandshake -> Maybe SMPClientHandshakeService
clientService :: Maybe SMPClientHandshakeService
clientService} =
    (VersionSMP, KeyHash) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (VersionSMP
v, KeyHash
keyHash)
      ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> VersionSMP -> Maybe PublicKeyX25519 -> ALPN
forall a. Encoding a => VersionSMP -> Maybe a -> ALPN
encodeAuthEncryptCmds VersionSMP
v Maybe PublicKeyX25519
authPubKey
      ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> VersionSMP -> ALPN -> ALPN -> ALPN
forall a. VersionSMP -> a -> a -> a
ifHasProxy VersionSMP
v (Bool -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode Bool
proxyServer) ALPN
""
      ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> VersionSMP -> ALPN -> ALPN -> ALPN
forall a. VersionSMP -> a -> a -> a
ifHasService VersionSMP
v (Maybe SMPClientHandshakeService -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode Maybe SMPClientHandshakeService
clientService) ALPN
""
  smpP :: Parser SMPClientHandshake
smpP = do
    (VersionSMP
v, KeyHash
keyHash) <- Parser (VersionSMP, KeyHash)
forall a. Encoding a => Parser a
smpP
    -- TODO drop SMP v6: remove special parser and make key non-optional
    Maybe PublicKeyX25519
authPubKey <- VersionSMP
-> Parser PublicKeyX25519 -> Parser (Maybe PublicKeyX25519)
forall a. VersionSMP -> Parser a -> Parser (Maybe a)
authEncryptCmdsP VersionSMP
v Parser PublicKeyX25519
forall a. Encoding a => Parser a
smpP
    Bool
proxyServer <- VersionSMP
-> Parser ALPN Bool -> Parser ALPN Bool -> Parser ALPN Bool
forall a. VersionSMP -> a -> a -> a
ifHasProxy VersionSMP
v Parser ALPN Bool
forall a. Encoding a => Parser a
smpP (Bool -> Parser ALPN Bool
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
    Maybe SMPClientHandshakeService
clientService <- VersionSMP
-> Parser ALPN (Maybe SMPClientHandshakeService)
-> Parser ALPN (Maybe SMPClientHandshakeService)
-> Parser ALPN (Maybe SMPClientHandshakeService)
forall a. VersionSMP -> a -> a -> a
ifHasService VersionSMP
v Parser ALPN (Maybe SMPClientHandshakeService)
forall a. Encoding a => Parser a
smpP (Maybe SMPClientHandshakeService
-> Parser ALPN (Maybe SMPClientHandshakeService)
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SMPClientHandshakeService
forall a. Maybe a
Nothing)
    SMPClientHandshake -> Parser SMPClientHandshake
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPClientHandshake {$sel:smpVersion:SMPClientHandshake :: VersionSMP
smpVersion = VersionSMP
v, KeyHash
$sel:keyHash:SMPClientHandshake :: KeyHash
keyHash :: KeyHash
keyHash, Maybe PublicKeyX25519
$sel:authPubKey:SMPClientHandshake :: Maybe PublicKeyX25519
authPubKey :: Maybe PublicKeyX25519
authPubKey, Bool
$sel:proxyServer:SMPClientHandshake :: Bool
proxyServer :: Bool
proxyServer, Maybe SMPClientHandshakeService
$sel:clientService:SMPClientHandshake :: Maybe SMPClientHandshakeService
clientService :: Maybe SMPClientHandshakeService
clientService}

instance Encoding SMPClientHandshakeService where
  smpEncode :: SMPClientHandshakeService -> ALPN
smpEncode SMPClientHandshakeService {SMPServiceRole
$sel:serviceRole:SMPClientHandshakeService :: SMPClientHandshakeService -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, CertChainPubKey
$sel:serviceCertKey:SMPClientHandshakeService :: SMPClientHandshakeService -> CertChainPubKey
serviceCertKey :: CertChainPubKey
serviceCertKey} =
    (SMPServiceRole, CertChainPubKey) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (SMPServiceRole
serviceRole, CertChainPubKey
serviceCertKey)
  smpP :: Parser SMPClientHandshakeService
smpP = do
    (SMPServiceRole
serviceRole, CertChainPubKey
serviceCertKey) <- Parser (SMPServiceRole, CertChainPubKey)
forall a. Encoding a => Parser a
smpP
    SMPClientHandshakeService -> Parser SMPClientHandshakeService
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPClientHandshakeService {SMPServiceRole
$sel:serviceRole:SMPClientHandshakeService :: SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, CertChainPubKey
$sel:serviceCertKey:SMPClientHandshakeService :: CertChainPubKey
serviceCertKey :: CertChainPubKey
serviceCertKey}

instance Encoding SMPServiceRole where
  smpEncode :: SMPServiceRole -> ALPN
smpEncode = \case
    SMPServiceRole
SRMessaging -> ALPN
"M"
    SMPServiceRole
SRNotifier -> ALPN
"N"
    SMPServiceRole
SRProxy -> ALPN
"P"
  smpP :: Parser SMPServiceRole
smpP =
    Parser Char
A.anyChar Parser Char
-> (Char -> Parser SMPServiceRole) -> Parser SMPServiceRole
forall a b. Parser ALPN a -> (a -> Parser ALPN b) -> Parser ALPN b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'M' -> SMPServiceRole -> Parser SMPServiceRole
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServiceRole
SRMessaging
      Char
'N' -> SMPServiceRole -> Parser SMPServiceRole
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServiceRole
SRNotifier
      Char
'P' -> SMPServiceRole -> Parser SMPServiceRole
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServiceRole
SRProxy
      Char
_ -> String -> Parser SMPServiceRole
forall a. String -> Parser ALPN a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad SMPServiceRole"

ifHasProxy :: VersionSMP -> a -> a -> a
ifHasProxy :: forall a. VersionSMP -> a -> a -> a
ifHasProxy VersionSMP
v a
a a
b = if VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
proxyServerHandshakeSMPVersion then a
a else a
b

ifHasService :: VersionSMP -> a -> a -> a
ifHasService :: forall a. VersionSMP -> a -> a -> a
ifHasService VersionSMP
v a
a a
b = if VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
serviceCertsSMPVersion then a
a else a
b

instance Encoding SMPServerHandshake where
  smpEncode :: SMPServerHandshake -> ALPN
smpEncode SMPServerHandshake {VersionRangeSMP
$sel:smpVersionRange:SMPServerHandshake :: SMPServerHandshake -> VersionRangeSMP
smpVersionRange :: VersionRangeSMP
smpVersionRange, ALPN
$sel:sessionId:SMPServerHandshake :: SMPServerHandshake -> ALPN
sessionId :: ALPN
sessionId, Maybe CertChainPubKey
$sel:authPubKey:SMPServerHandshake :: SMPServerHandshake -> Maybe CertChainPubKey
authPubKey :: Maybe CertChainPubKey
authPubKey} =
    (VersionRangeSMP, ALPN) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (VersionRangeSMP
smpVersionRange, ALPN
sessionId) ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> ALPN
auth
    where
      auth :: ALPN
auth = VersionSMP -> Maybe CertChainPubKey -> ALPN
forall a. Encoding a => VersionSMP -> Maybe a -> ALPN
encodeAuthEncryptCmds (VersionRangeSMP -> VersionSMP
forall v. VersionRange v -> Version v
maxVersion VersionRangeSMP
smpVersionRange) Maybe CertChainPubKey
authPubKey
  smpP :: Parser SMPServerHandshake
smpP = do
    (VersionRangeSMP
smpVersionRange, ALPN
sessionId) <- Parser (VersionRangeSMP, ALPN)
forall a. Encoding a => Parser a
smpP
    -- TODO drop SMP v6: remove special parser and make key non-optional
    Maybe CertChainPubKey
authPubKey <- VersionSMP
-> Parser CertChainPubKey -> Parser (Maybe CertChainPubKey)
forall a. VersionSMP -> Parser a -> Parser (Maybe a)
authEncryptCmdsP (VersionRangeSMP -> VersionSMP
forall v. VersionRange v -> Version v
maxVersion VersionRangeSMP
smpVersionRange) Parser CertChainPubKey
forall a. Encoding a => Parser a
smpP
    SMPServerHandshake -> Parser SMPServerHandshake
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServerHandshake {VersionRangeSMP
$sel:smpVersionRange:SMPServerHandshake :: VersionRangeSMP
smpVersionRange :: VersionRangeSMP
smpVersionRange, ALPN
$sel:sessionId:SMPServerHandshake :: ALPN
sessionId :: ALPN
sessionId, Maybe CertChainPubKey
$sel:authPubKey:SMPServerHandshake :: Maybe CertChainPubKey
authPubKey :: Maybe CertChainPubKey
authPubKey}

-- newtype for CertificateChain and a session key signed with this certificate
data CertChainPubKey = CertChainPubKey
  { CertChainPubKey -> CertificateChain
certChain :: X.CertificateChain,
    CertChainPubKey -> SignedExact PubKey
signedPubKey :: X.SignedExact X.PubKey
  }
  deriving (CertChainPubKey -> CertChainPubKey -> Bool
(CertChainPubKey -> CertChainPubKey -> Bool)
-> (CertChainPubKey -> CertChainPubKey -> Bool)
-> Eq CertChainPubKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CertChainPubKey -> CertChainPubKey -> Bool
== :: CertChainPubKey -> CertChainPubKey -> Bool
$c/= :: CertChainPubKey -> CertChainPubKey -> Bool
/= :: CertChainPubKey -> CertChainPubKey -> Bool
Eq, Int -> CertChainPubKey -> ShowS
[CertChainPubKey] -> ShowS
CertChainPubKey -> String
(Int -> CertChainPubKey -> ShowS)
-> (CertChainPubKey -> String)
-> ([CertChainPubKey] -> ShowS)
-> Show CertChainPubKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CertChainPubKey -> ShowS
showsPrec :: Int -> CertChainPubKey -> ShowS
$cshow :: CertChainPubKey -> String
show :: CertChainPubKey -> String
$cshowList :: [CertChainPubKey] -> ShowS
showList :: [CertChainPubKey] -> ShowS
Show)

instance Encoding CertChainPubKey where
  smpEncode :: CertChainPubKey -> ALPN
smpEncode CertChainPubKey {CertificateChain
$sel:certChain:CertChainPubKey :: CertChainPubKey -> CertificateChain
certChain :: CertificateChain
certChain, SignedExact PubKey
$sel:signedPubKey:CertChainPubKey :: CertChainPubKey -> SignedExact PubKey
signedPubKey :: SignedExact PubKey
signedPubKey} = (NonEmpty Large, SignedObject PubKey) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (CertificateChain -> NonEmpty Large
C.encodeCertChain CertificateChain
certChain, SignedExact PubKey -> SignedObject PubKey
forall a. SignedExact a -> SignedObject a
C.SignedObject SignedExact PubKey
signedPubKey)
  smpP :: Parser CertChainPubKey
smpP = do
    CertificateChain
certChain <- Parser CertificateChain
C.certChainP
    C.SignedObject SignedExact PubKey
signedPubKey <- Parser (SignedObject PubKey)
forall a. Encoding a => Parser a
smpP
    CertChainPubKey -> Parser CertChainPubKey
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CertChainPubKey {CertificateChain
$sel:certChain:CertChainPubKey :: CertificateChain
certChain :: CertificateChain
certChain, SignedExact PubKey
$sel:signedPubKey:CertChainPubKey :: SignedExact PubKey
signedPubKey :: SignedExact PubKey
signedPubKey}

encodeAuthEncryptCmds :: Encoding a => VersionSMP -> Maybe a -> ByteString
encodeAuthEncryptCmds :: forall a. Encoding a => VersionSMP -> Maybe a -> ALPN
encodeAuthEncryptCmds VersionSMP
v Maybe a
k
  | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
authCmdsSMPVersion = ALPN -> (a -> ALPN) -> Maybe a -> ALPN
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ALPN
"" a -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode Maybe a
k
  | Bool
otherwise = ALPN
""

authEncryptCmdsP :: VersionSMP -> Parser a -> Parser (Maybe a)
authEncryptCmdsP :: forall a. VersionSMP -> Parser a -> Parser (Maybe a)
authEncryptCmdsP VersionSMP
v Parser a
p = if VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
authCmdsSMPVersion then Parser a -> Parser ALPN (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser a
p else Maybe a -> Parser ALPN (Maybe a)
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

instance Encoding SMPServerHandshakeResponse where
  smpEncode :: SMPServerHandshakeResponse -> ALPN
smpEncode = \case
    SMPServerHandshakeResponse ServiceId
serviceId -> (Char, ServiceId) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (Char
'R', ServiceId
serviceId)
    SMPServerHandshakeError TransportError
handshakeError -> (Char, TransportError) -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode (Char
'E', TransportError
handshakeError)
  smpP :: Parser SMPServerHandshakeResponse
smpP =
    Parser Char
A.anyChar Parser Char
-> (Char -> Parser SMPServerHandshakeResponse)
-> Parser SMPServerHandshakeResponse
forall a b. Parser ALPN a -> (a -> Parser ALPN b) -> Parser ALPN b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'R' -> ServiceId -> SMPServerHandshakeResponse
SMPServerHandshakeResponse (ServiceId -> SMPServerHandshakeResponse)
-> Parser ServiceId -> Parser SMPServerHandshakeResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ServiceId
forall a. Encoding a => Parser a
smpP
      Char
'E' -> TransportError -> SMPServerHandshakeResponse
SMPServerHandshakeError (TransportError -> SMPServerHandshakeResponse)
-> Parser ALPN TransportError -> Parser SMPServerHandshakeResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ALPN TransportError
forall a. Encoding a => Parser a
smpP
      Char
_ -> String -> Parser SMPServerHandshakeResponse
forall a. String -> Parser ALPN a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad SMPServerHandshakeResponse"

-- | Error of SMP encrypted transport over TCP.
data TransportError
  = -- | error parsing transport block
    TEBadBlock
  | -- | incompatible client or server version
    TEVersion
  | -- | message does not fit in transport block
    TELargeMsg
  | -- | incorrect session ID
    TEBadSession
  | -- | absent server key for v7 entity
    -- This error happens when the server did not provide a DH key to authorize commands for the queue that should be authorized with a DH key.
    TENoServerAuth
  | -- | transport handshake error
    TEHandshake {TransportError -> HandshakeError
handshakeErr :: HandshakeError}
  deriving (TransportError -> TransportError -> Bool
(TransportError -> TransportError -> Bool)
-> (TransportError -> TransportError -> Bool) -> Eq TransportError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportError -> TransportError -> Bool
== :: TransportError -> TransportError -> Bool
$c/= :: TransportError -> TransportError -> Bool
/= :: TransportError -> TransportError -> Bool
Eq, ReadPrec [TransportError]
ReadPrec TransportError
Int -> ReadS TransportError
ReadS [TransportError]
(Int -> ReadS TransportError)
-> ReadS [TransportError]
-> ReadPrec TransportError
-> ReadPrec [TransportError]
-> Read TransportError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TransportError
readsPrec :: Int -> ReadS TransportError
$creadList :: ReadS [TransportError]
readList :: ReadS [TransportError]
$creadPrec :: ReadPrec TransportError
readPrec :: ReadPrec TransportError
$creadListPrec :: ReadPrec [TransportError]
readListPrec :: ReadPrec [TransportError]
Read, Int -> TransportError -> ShowS
[TransportError] -> ShowS
TransportError -> String
(Int -> TransportError -> ShowS)
-> (TransportError -> String)
-> ([TransportError] -> ShowS)
-> Show TransportError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportError -> ShowS
showsPrec :: Int -> TransportError -> ShowS
$cshow :: TransportError -> String
show :: TransportError -> String
$cshowList :: [TransportError] -> ShowS
showList :: [TransportError] -> ShowS
Show, Show TransportError
Typeable TransportError
(Typeable TransportError, Show TransportError) =>
(TransportError -> SomeException)
-> (SomeException -> Maybe TransportError)
-> (TransportError -> String)
-> Exception TransportError
SomeException -> Maybe TransportError
TransportError -> String
TransportError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: TransportError -> SomeException
toException :: TransportError -> SomeException
$cfromException :: SomeException -> Maybe TransportError
fromException :: SomeException -> Maybe TransportError
$cdisplayException :: TransportError -> String
displayException :: TransportError -> String
Exception)

-- | Transport handshake error.
data HandshakeError
  = -- | parsing error
    PARSE
  | -- | incorrect server identity
    IDENTITY
  | -- | v7 authentication failed
    BAD_AUTH
  | -- | error reading/creating service record
    BAD_SERVICE
  deriving (HandshakeError -> HandshakeError -> Bool
(HandshakeError -> HandshakeError -> Bool)
-> (HandshakeError -> HandshakeError -> Bool) -> Eq HandshakeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HandshakeError -> HandshakeError -> Bool
== :: HandshakeError -> HandshakeError -> Bool
$c/= :: HandshakeError -> HandshakeError -> Bool
/= :: HandshakeError -> HandshakeError -> Bool
Eq, ReadPrec [HandshakeError]
ReadPrec HandshakeError
Int -> ReadS HandshakeError
ReadS [HandshakeError]
(Int -> ReadS HandshakeError)
-> ReadS [HandshakeError]
-> ReadPrec HandshakeError
-> ReadPrec [HandshakeError]
-> Read HandshakeError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HandshakeError
readsPrec :: Int -> ReadS HandshakeError
$creadList :: ReadS [HandshakeError]
readList :: ReadS [HandshakeError]
$creadPrec :: ReadPrec HandshakeError
readPrec :: ReadPrec HandshakeError
$creadListPrec :: ReadPrec [HandshakeError]
readListPrec :: ReadPrec [HandshakeError]
Read, Int -> HandshakeError -> ShowS
[HandshakeError] -> ShowS
HandshakeError -> String
(Int -> HandshakeError -> ShowS)
-> (HandshakeError -> String)
-> ([HandshakeError] -> ShowS)
-> Show HandshakeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandshakeError -> ShowS
showsPrec :: Int -> HandshakeError -> ShowS
$cshow :: HandshakeError -> String
show :: HandshakeError -> String
$cshowList :: [HandshakeError] -> ShowS
showList :: [HandshakeError] -> ShowS
Show, Show HandshakeError
Typeable HandshakeError
(Typeable HandshakeError, Show HandshakeError) =>
(HandshakeError -> SomeException)
-> (SomeException -> Maybe HandshakeError)
-> (HandshakeError -> String)
-> Exception HandshakeError
SomeException -> Maybe HandshakeError
HandshakeError -> String
HandshakeError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: HandshakeError -> SomeException
toException :: HandshakeError -> SomeException
$cfromException :: SomeException -> Maybe HandshakeError
fromException :: SomeException -> Maybe HandshakeError
$cdisplayException :: HandshakeError -> String
displayException :: HandshakeError -> String
Exception)

instance Encoding TransportError where
  smpP :: Parser ALPN TransportError
smpP =
    (Char -> Bool) -> Parser ALPN
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ALPN
-> (ALPN -> Parser ALPN TransportError)
-> Parser ALPN TransportError
forall a b. Parser ALPN a -> (a -> Parser ALPN b) -> Parser ALPN b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ALPN
"BLOCK" -> TransportError -> Parser ALPN TransportError
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TEBadBlock
      ALPN
"VERSION" -> TransportError -> Parser ALPN TransportError
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TEVersion
      ALPN
"LARGE_MSG" -> TransportError -> Parser ALPN TransportError
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TELargeMsg
      ALPN
"SESSION" -> TransportError -> Parser ALPN TransportError
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TEBadSession
      ALPN
"NO_AUTH" -> TransportError -> Parser ALPN TransportError
forall a. a -> Parser ALPN a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TENoServerAuth
      ALPN
"HANDSHAKE" -> HandshakeError -> TransportError
TEHandshake (HandshakeError -> TransportError)
-> Parser ALPN HandshakeError -> Parser ALPN TransportError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Char
A.space Parser Char
-> Parser ALPN HandshakeError -> Parser ALPN HandshakeError
forall a b. Parser ALPN a -> Parser ALPN b -> Parser ALPN b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ALPN HandshakeError
forall a. Read a => Parser a
parseRead1)
      ALPN
_ -> String -> Parser ALPN TransportError
forall a. String -> Parser ALPN a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad TransportError"
  smpEncode :: TransportError -> ALPN
smpEncode = \case
    TransportError
TEBadBlock -> ALPN
"BLOCK"
    TransportError
TEVersion -> ALPN
"VERSION"
    TransportError
TELargeMsg -> ALPN
"LARGE_MSG"
    TransportError
TEBadSession -> ALPN
"SESSION"
    TransportError
TENoServerAuth -> ALPN
"NO_AUTH"
    TEHandshake HandshakeError
e -> ALPN
"HANDSHAKE " ALPN -> ALPN -> ALPN
forall a. Semigroup a => a -> a -> a
<> HandshakeError -> ALPN
forall a. Show a => a -> ALPN
bshow HandshakeError
e

-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
tPutBlock :: forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> ALPN -> IO (Either TransportError ())
tPutBlock THandle {$sel:connection:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> c p
connection = c p
c, $sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {Int
$sel:blockSize:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Int
blockSize :: Int
blockSize, Maybe TSbChainKeys
$sel:encryptBlock:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe TSbChainKeys
encryptBlock :: Maybe TSbChainKeys
encryptBlock}} ALPN
block = do
  Either CryptoError ALPN
block_ <- case Maybe TSbChainKeys
encryptBlock of
    Just TSbChainKeys {TVar SbChainKey
$sel:sndKey:TSbChainKeys :: TSbChainKeys -> TVar SbChainKey
sndKey :: TVar SbChainKey
sndKey} -> do
      (SbKey
sk, CbNonce
nonce) <- STM (SbKey, CbNonce) -> IO (SbKey, CbNonce)
forall a. STM a -> IO a
atomically (STM (SbKey, CbNonce) -> IO (SbKey, CbNonce))
-> STM (SbKey, CbNonce) -> IO (SbKey, CbNonce)
forall a b. (a -> b) -> a -> b
$ TVar SbChainKey
-> (SbChainKey -> ((SbKey, CbNonce), SbChainKey))
-> STM (SbKey, CbNonce)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SbChainKey
sndKey SbChainKey -> ((SbKey, CbNonce), SbChainKey)
C.sbcHkdf
      Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CryptoError ALPN -> IO (Either CryptoError ALPN))
-> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a b. (a -> b) -> a -> b
$ SbKey -> CbNonce -> ALPN -> Int -> Either CryptoError ALPN
C.sbEncrypt SbKey
sk CbNonce
nonce ALPN
block (Int
blockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16)
    Maybe TSbChainKeys
Nothing -> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CryptoError ALPN -> IO (Either CryptoError ALPN))
-> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a b. (a -> b) -> a -> b
$ ALPN -> Int -> Either CryptoError ALPN
C.pad ALPN
block Int
blockSize
  (CryptoError -> IO TransportError)
-> (ALPN -> IO ())
-> Either CryptoError ALPN
-> IO (Either TransportError ())
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM (IO TransportError -> CryptoError -> IO TransportError
forall a b. a -> b -> a
const (IO TransportError -> CryptoError -> IO TransportError)
-> IO TransportError -> CryptoError -> IO TransportError
forall a b. (a -> b) -> a -> b
$ TransportError -> IO TransportError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportError
TELargeMsg) (c p -> ALPN -> IO ()
forall (p :: TransportPeer). c p -> ALPN -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> ALPN -> IO ()
cPut c p
c) Either CryptoError ALPN
block_

-- | Receive block from SMP transport.
tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
tGetBlock :: forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> IO (Either TransportError ALPN)
tGetBlock THandle {$sel:connection:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> c p
connection = c p
c, $sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {Int
$sel:blockSize:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Int
blockSize :: Int
blockSize, Maybe TSbChainKeys
$sel:encryptBlock:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe TSbChainKeys
encryptBlock :: Maybe TSbChainKeys
encryptBlock}} = do
  ALPN
msg <- c p -> Int -> IO ALPN
forall (p :: TransportPeer). c p -> Int -> IO ALPN
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> Int -> IO ALPN
cGet c p
c Int
blockSize
  if ALPN -> Int
B.length ALPN
msg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
blockSize
    then
      (CryptoError -> TransportError)
-> Either CryptoError ALPN -> Either TransportError ALPN
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TransportError -> CryptoError -> TransportError
forall a b. a -> b -> a
const TransportError
TELargeMsg) (Either CryptoError ALPN -> Either TransportError ALPN)
-> IO (Either CryptoError ALPN) -> IO (Either TransportError ALPN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        case Maybe TSbChainKeys
encryptBlock of
          Just TSbChainKeys {TVar SbChainKey
$sel:rcvKey:TSbChainKeys :: TSbChainKeys -> TVar SbChainKey
rcvKey :: TVar SbChainKey
rcvKey} -> do
            (SbKey
sk, CbNonce
nonce) <- STM (SbKey, CbNonce) -> IO (SbKey, CbNonce)
forall a. STM a -> IO a
atomically (STM (SbKey, CbNonce) -> IO (SbKey, CbNonce))
-> STM (SbKey, CbNonce) -> IO (SbKey, CbNonce)
forall a b. (a -> b) -> a -> b
$ TVar SbChainKey
-> (SbChainKey -> ((SbKey, CbNonce), SbChainKey))
-> STM (SbKey, CbNonce)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SbChainKey
rcvKey SbChainKey -> ((SbKey, CbNonce), SbChainKey)
C.sbcHkdf
            Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CryptoError ALPN -> IO (Either CryptoError ALPN))
-> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a b. (a -> b) -> a -> b
$ SbKey -> CbNonce -> ALPN -> Either CryptoError ALPN
C.sbDecrypt SbKey
sk CbNonce
nonce ALPN
msg
          Maybe TSbChainKeys
Nothing -> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CryptoError ALPN -> IO (Either CryptoError ALPN))
-> Either CryptoError ALPN -> IO (Either CryptoError ALPN)
forall a b. (a -> b) -> a -> b
$ ALPN -> Either CryptoError ALPN
C.unPad ALPN
msg
    else IO (Either TransportError ALPN)
forall a. IO a
ioe_EOF

-- | Server SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpServerHandshake ::
  forall c. Transport c =>
  X.CertificateChain ->
  C.APrivateSignKey ->
  c 'TServer ->
  C.KeyPairX25519 ->
  C.KeyHash ->
  VersionRangeSMP ->
  (SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId) ->
  ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake :: forall (c :: TransportPeer -> *).
Transport c =>
CertificateChain
-> APrivateSignKey
-> c 'TServer
-> KeyPairX25519
-> KeyHash
-> VersionRangeSMP
-> (SMPServiceRole
    -> CertificateChain
    -> Fingerprint
    -> ExceptT TransportError IO ServiceId)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake CertificateChain
srvCert APrivateSignKey
srvSignKey c 'TServer
c (PublicKeyType PrivateKeyX25519
k, PrivateKeyX25519
pk) KeyHash
kh VersionRangeSMP
smpVRange SMPServiceRole
-> CertificateChain
-> Fingerprint
-> ExceptT TransportError IO ServiceId
getService = do
  let sk :: SignedExact PubKey
sk = APrivateSignKey -> PubKey -> SignedExact PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APrivateSignKey -> o -> SignedExact o
C.signX509 APrivateSignKey
srvSignKey (PubKey -> SignedExact PubKey) -> PubKey -> SignedExact PubKey
forall a b. (a -> b) -> a -> b
$ PublicKeyX25519 -> PubKey
forall (a :: Algorithm). PublicKey a -> PubKey
C.publicToX509 PublicKeyType PrivateKeyX25519
PublicKeyX25519
k
      smpVersionRange :: VersionRangeSMP
smpVersionRange = VersionRangeSMP
-> (ALPN -> VersionRangeSMP) -> Maybe ALPN -> VersionRangeSMP
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VersionRangeSMP
legacyServerSMPRelayVRange (VersionRangeSMP -> ALPN -> VersionRangeSMP
forall a b. a -> b -> a
const VersionRangeSMP
smpVRange) (Maybe ALPN -> VersionRangeSMP) -> Maybe ALPN -> VersionRangeSMP
forall a b. (a -> b) -> a -> b
$ c 'TServer -> Maybe ALPN
forall (p :: TransportPeer). c p -> Maybe ALPN
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> Maybe ALPN
getSessionALPN c 'TServer
c
  THandleSMP c 'TServer
-> SMPServerHandshake -> ExceptT TransportError IO ()
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake THandleSMP c 'TServer
th (SMPServerHandshake -> ExceptT TransportError IO ())
-> SMPServerHandshake -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ SMPServerHandshake {ALPN
$sel:sessionId:SMPServerHandshake :: ALPN
sessionId :: ALPN
sessionId, VersionRangeSMP
$sel:smpVersionRange:SMPServerHandshake :: VersionRangeSMP
smpVersionRange :: VersionRangeSMP
smpVersionRange, $sel:authPubKey:SMPServerHandshake :: Maybe CertChainPubKey
authPubKey = CertChainPubKey -> Maybe CertChainPubKey
forall a. a -> Maybe a
Just (CertificateChain -> SignedExact PubKey -> CertChainPubKey
CertChainPubKey CertificateChain
srvCert SignedExact PubKey
sk)}
  SMPClientHandshake {$sel:smpVersion:SMPClientHandshake :: SMPClientHandshake -> VersionSMP
smpVersion = VersionSMP
v, KeyHash
$sel:keyHash:SMPClientHandshake :: SMPClientHandshake -> KeyHash
keyHash :: KeyHash
keyHash, $sel:authPubKey:SMPClientHandshake :: SMPClientHandshake -> Maybe PublicKeyX25519
authPubKey = Maybe PublicKeyX25519
k', Bool
$sel:proxyServer:SMPClientHandshake :: SMPClientHandshake -> Bool
proxyServer :: Bool
proxyServer, Maybe SMPClientHandshakeService
$sel:clientService:SMPClientHandshake :: SMPClientHandshake -> Maybe SMPClientHandshakeService
clientService :: Maybe SMPClientHandshakeService
clientService} <- THandleSMP c 'TServer
-> ExceptT TransportError IO SMPClientHandshake
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> ExceptT TransportError IO smp
getHandshake THandleSMP c 'TServer
th
  Bool
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyHash
keyHash KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyHash
kh) (ExceptT TransportError IO () -> ExceptT TransportError IO ())
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> ExceptT TransportError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (TransportError -> ExceptT TransportError IO ())
-> TransportError -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
IDENTITY
  case VersionRangeSMP -> VersionSMP -> Maybe (Compatible VersionRangeSMP)
forall v a.
VersionRangeI v a =>
a -> Version v -> Maybe (Compatible a)
compatibleVRange' VersionRangeSMP
smpVersionRange VersionSMP
v of
    Just (Compatible VersionRangeSMP
vr) -> do
      Maybe THPeerClientService
service <- (SMPClientHandshakeService
 -> ExceptT TransportError IO THPeerClientService)
-> Maybe SMPClientHandshakeService
-> ExceptT TransportError IO (Maybe THPeerClientService)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM SMPClientHandshakeService
-> ExceptT TransportError IO THPeerClientService
getClientService Maybe SMPClientHandshakeService
clientService
      IO (THandleSMP c 'TServer)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
forall a. IO a -> ExceptT TransportError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (THandleSMP c 'TServer)
 -> ExceptT TransportError IO (THandleSMP c 'TServer))
-> IO (THandleSMP c 'TServer)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
forall a b. (a -> b) -> a -> b
$ THandleSMP c 'TServer
-> VersionSMP
-> VersionRangeSMP
-> PrivateKeyX25519
-> Maybe PublicKeyX25519
-> Bool
-> Maybe THPeerClientService
-> IO (THandleSMP c 'TServer)
forall (c :: TransportPeer -> *).
THandleSMP c 'TServer
-> VersionSMP
-> VersionRangeSMP
-> PrivateKeyX25519
-> Maybe PublicKeyX25519
-> Bool
-> Maybe THPeerClientService
-> IO (THandleSMP c 'TServer)
smpTHandleServer THandleSMP c 'TServer
th VersionSMP
v VersionRangeSMP
vr PrivateKeyX25519
pk Maybe PublicKeyX25519
k' Bool
proxyServer Maybe THPeerClientService
service
    Maybe (Compatible VersionRangeSMP)
Nothing -> TransportError -> ExceptT TransportError IO (THandleSMP c 'TServer)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TransportError
TEVersion
  where
    th :: THandleSMP c 'TServer
th@THandle {$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {ALPN
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ALPN
sessionId :: ALPN
sessionId}} = c 'TServer -> THandleSMP c 'TServer
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> THandleSMP c p
smpTHandle c 'TServer
c
    getClientService :: SMPClientHandshakeService -> ExceptT TransportError IO THPeerClientService
    getClientService :: SMPClientHandshakeService
-> ExceptT TransportError IO THPeerClientService
getClientService SMPClientHandshakeService {SMPServiceRole
$sel:serviceRole:SMPClientHandshakeService :: SMPClientHandshakeService -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, $sel:serviceCertKey:SMPClientHandshakeService :: SMPClientHandshakeService -> CertChainPubKey
serviceCertKey = CertChainPubKey CertificateChain
cc SignedExact PubKey
exact} = (TransportError -> ExceptT TransportError IO THPeerClientService)
-> ExceptT TransportError IO THPeerClientService
-> ExceptT TransportError IO THPeerClientService
forall e (m :: * -> *) a.
MonadError e m =>
(e -> m a) -> m a -> m a
handleError TransportError -> ExceptT TransportError IO THPeerClientService
sendErr (ExceptT TransportError IO THPeerClientService
 -> ExceptT TransportError IO THPeerClientService)
-> ExceptT TransportError IO THPeerClientService
-> ExceptT TransportError IO THPeerClientService
forall a b. (a -> b) -> a -> b
$ do
      Bool
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (c 'TServer -> CertificateChain
forall (p :: TransportPeer). c p -> CertificateChain
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> CertificateChain
getPeerCertChain c 'TServer
c CertificateChain -> CertificateChain -> Bool
forall a. Eq a => a -> a -> Bool
== CertificateChain
cc) (ExceptT TransportError IO () -> ExceptT TransportError IO ())
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> ExceptT TransportError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (TransportError -> ExceptT TransportError IO ())
-> TransportError -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
BAD_AUTH
      (SignedExact Certificate
idCert, PublicKeyEd25519
serviceKey) <- (String -> TransportError)
-> Either String (SignedExact Certificate, PublicKeyEd25519)
-> ExceptT
     TransportError IO (SignedExact Certificate, PublicKeyEd25519)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (TransportError -> String -> TransportError
forall a b. a -> b -> a
const (TransportError -> String -> TransportError)
-> TransportError -> String -> TransportError
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
BAD_AUTH) (Either String (SignedExact Certificate, PublicKeyEd25519)
 -> ExceptT
      TransportError IO (SignedExact Certificate, PublicKeyEd25519))
-> Either String (SignedExact Certificate, PublicKeyEd25519)
-> ExceptT
     TransportError IO (SignedExact Certificate, PublicKeyEd25519)
forall a b. (a -> b) -> a -> b
$ do
        (SignedExact Certificate
leafCert, SignedExact Certificate
idCert) <- case CertificateChain -> ChainCertificates
chainIdCaCerts CertificateChain
cc of
          CCSelf SignedExact Certificate
cert -> (SignedExact Certificate, SignedExact Certificate)
-> Either String (SignedExact Certificate, SignedExact Certificate)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedExact Certificate
cert, SignedExact Certificate
cert)
          CCValid {SignedExact Certificate
leafCert :: SignedExact Certificate
leafCert :: ChainCertificates -> SignedExact Certificate
leafCert, SignedExact Certificate
idCert :: SignedExact Certificate
idCert :: ChainCertificates -> SignedExact Certificate
idCert} -> (SignedExact Certificate, SignedExact Certificate)
-> Either String (SignedExact Certificate, SignedExact Certificate)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedExact Certificate
leafCert, SignedExact Certificate
idCert)
          ChainCertificates
_ -> String
-> Either String (SignedExact Certificate, SignedExact Certificate)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"bad certificate"
        APublicVerifyKey
serviceCertKey <- SignedExact Certificate -> Either String APublicVerifyKey
getCertVerifyKey SignedExact Certificate
leafCert
        (SignedExact Certificate
idCert,) (PublicKeyEd25519 -> (SignedExact Certificate, PublicKeyEd25519))
-> Either String PublicKeyEd25519
-> Either String (SignedExact Certificate, PublicKeyEd25519)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PubKey -> Either String PublicKeyEd25519
forall k. CryptoPublicKey k => PubKey -> Either String k
C.x509ToPublic' (PubKey -> Either String PublicKeyEd25519)
-> Either String PubKey -> Either String PublicKeyEd25519
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< APublicVerifyKey -> SignedExact PubKey -> Either String PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APublicVerifyKey -> SignedExact o -> Either String o
C.verifyX509 APublicVerifyKey
serviceCertKey SignedExact PubKey
exact)
      let fp :: Fingerprint
fp = SignedExact Certificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
XV.getFingerprint SignedExact Certificate
idCert HashALG
X.HashSHA256
      ServiceId
serviceId <- SMPServiceRole
-> CertificateChain
-> Fingerprint
-> ExceptT TransportError IO ServiceId
getService SMPServiceRole
serviceRole CertificateChain
cc Fingerprint
fp
      THandleSMP c 'TServer
-> SMPServerHandshakeResponse -> ExceptT TransportError IO ()
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake THandleSMP c 'TServer
th (SMPServerHandshakeResponse -> ExceptT TransportError IO ())
-> SMPServerHandshakeResponse -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ SMPServerHandshakeResponse {ServiceId
$sel:serviceId:SMPServerHandshakeResponse :: ServiceId
serviceId :: ServiceId
serviceId}
      THPeerClientService
-> ExceptT TransportError IO THPeerClientService
forall a. a -> ExceptT TransportError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure THClientService {ServiceId
$sel:serviceId:THClientService :: ServiceId
serviceId :: ServiceId
serviceId, SMPServiceRole
$sel:serviceRole:THClientService :: SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, $sel:serviceCertHash:THClientService :: Fingerprint
serviceCertHash = Fingerprint
fp, PublicKeyEd25519
$sel:serviceKey:THClientService :: PublicKeyEd25519
serviceKey :: PublicKeyEd25519
serviceKey}
    sendErr :: TransportError -> ExceptT TransportError IO THPeerClientService
sendErr TransportError
err = do
      THandleSMP c 'TServer
-> SMPServerHandshakeResponse -> ExceptT TransportError IO ()
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake THandleSMP c 'TServer
th (SMPServerHandshakeResponse -> ExceptT TransportError IO ())
-> SMPServerHandshakeResponse -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ SMPServerHandshakeError {$sel:handshakeError:SMPServerHandshakeResponse :: TransportError
handshakeError = TransportError
err}
      TransportError -> ExceptT TransportError IO THPeerClientService
forall a. TransportError -> ExceptT TransportError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TransportError
err

-- | Client SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleSMP c 'TClient)
smpClientHandshake :: forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRangeSMP
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandleSMP c 'TClient)
smpClientHandshake c 'TClient
c Maybe KeyPairX25519
ks_ keyHash :: KeyHash
keyHash@(C.KeyHash ALPN
kh) VersionRangeSMP
vRange Bool
proxyServer Maybe (ServiceCredentials, KeyPairEd25519)
serviceKeys_ = do
  SMPServerHandshake {$sel:sessionId:SMPServerHandshake :: SMPServerHandshake -> ALPN
sessionId = ALPN
sessId, VersionRangeSMP
$sel:smpVersionRange:SMPServerHandshake :: SMPServerHandshake -> VersionRangeSMP
smpVersionRange :: VersionRangeSMP
smpVersionRange, Maybe CertChainPubKey
$sel:authPubKey:SMPServerHandshake :: SMPServerHandshake -> Maybe CertChainPubKey
authPubKey :: Maybe CertChainPubKey
authPubKey} <- THandleSMP c 'TClient
-> ExceptT TransportError IO SMPServerHandshake
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> ExceptT TransportError IO smp
getHandshake THandleSMP c 'TClient
th
  Bool
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ALPN
sessionId ALPN -> ALPN -> Bool
forall a. Eq a => a -> a -> Bool
/= ALPN
sessId) (ExceptT TransportError IO () -> ExceptT TransportError IO ())
-> ExceptT TransportError IO () -> ExceptT TransportError IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> ExceptT TransportError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TransportError
TEBadSession
  -- Below logic downgrades version range in case the "client" is SMP proxy server and it is
  -- connected to the destination server of the version 11 or older.
  -- It disables transport encryption between SMP proxy and destination relay.
  --
  -- Prior to version v6.3 the version between proxy and destination was capped at 8,
  -- by mistake, which also disables transport encryption and the latest features.
  --
  -- Transport encryption between proxy and destination breaks clients with version 10 or earlier,
  -- because of a larger message size (see maxMessageLength).
  --
  -- To summarize:
  -- - proxy and relay version 12: the agreed version is 12, transport encryption disabled (see blockEncryption with proxyServer == True).
  -- - proxy is v 12, relay is 11: the agreed version is 10, because of this logic, transport encryption is disabled.
  let smpVRange :: VersionRangeSMP
smpVRange =
        if Bool
proxyServer Bool -> Bool -> Bool
&& VersionRangeSMP -> VersionSMP
forall v. VersionRange v -> Version v
maxVersion VersionRangeSMP
smpVersionRange VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
< VersionSMP
proxyServerHandshakeSMPVersion
          then VersionRangeSMP
vRange {maxVersion = max (minVersion vRange) deletedEventSMPVersion}
          else VersionRangeSMP
vRange
  case VersionRangeSMP
smpVersionRange VersionRangeSMP
-> VersionRangeSMP -> Maybe (Compatible VersionRangeSMP)
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible a)
`compatibleVRange` VersionRangeSMP
smpVRange of
    Just (Compatible VersionRangeSMP
vr) -> do
      Maybe (PublicKeyX25519, CertChainPubKey)
ck_ <- Maybe CertChainPubKey
-> (CertChainPubKey
    -> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey))
-> ExceptT
     TransportError IO (Maybe (PublicKeyX25519, CertChainPubKey))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe CertChainPubKey
authPubKey ((CertChainPubKey
  -> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey))
 -> ExceptT
      TransportError IO (Maybe (PublicKeyX25519, CertChainPubKey)))
-> (CertChainPubKey
    -> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey))
-> ExceptT
     TransportError IO (Maybe (PublicKeyX25519, CertChainPubKey))
forall a b. (a -> b) -> a -> b
$ \certKey :: CertChainPubKey
certKey@(CertChainPubKey CertificateChain
chain SignedExact PubKey
exact) ->
        (String -> TransportError)
-> Either String (PublicKeyX25519, CertChainPubKey)
-> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (TransportError -> String -> TransportError
forall a b. a -> b -> a
const (TransportError -> String -> TransportError)
-> TransportError -> String -> TransportError
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
BAD_AUTH) (Either String (PublicKeyX25519, CertChainPubKey)
 -> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey))
-> Either String (PublicKeyX25519, CertChainPubKey)
-> ExceptT TransportError IO (PublicKeyX25519, CertChainPubKey)
forall a b. (a -> b) -> a -> b
$ do
          case CertificateChain -> ChainCertificates
chainIdCaCerts CertificateChain
chain of
            CCValid {SignedExact Certificate
idCert :: ChainCertificates -> SignedExact Certificate
idCert :: SignedExact Certificate
idCert} | ALPN -> Fingerprint
XV.Fingerprint ALPN
kh Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SignedExact Certificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
XV.getFingerprint SignedExact Certificate
idCert HashALG
X.HashSHA256 -> () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ChainCertificates
_ -> String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"bad certificate"
          APublicVerifyKey
serverKey <- c 'TClient -> Either String APublicVerifyKey
forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient -> Either String APublicVerifyKey
getServerVerifyKey c 'TClient
c
          (,CertChainPubKey
certKey) (PublicKeyX25519 -> (PublicKeyX25519, CertChainPubKey))
-> Either String PublicKeyX25519
-> Either String (PublicKeyX25519, CertChainPubKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PubKey -> Either String PublicKeyX25519
forall k. CryptoPublicKey k => PubKey -> Either String k
C.x509ToPublic' (PubKey -> Either String PublicKeyX25519)
-> Either String PubKey -> Either String PublicKeyX25519
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< APublicVerifyKey -> SignedExact PubKey -> Either String PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APublicVerifyKey -> SignedExact o -> Either String o
C.verifyX509 APublicVerifyKey
serverKey SignedExact PubKey
exact)
      let v :: VersionSMP
v = VersionRangeSMP -> VersionSMP
forall v. VersionRange v -> Version v
maxVersion VersionRangeSMP
vr
          serviceKeys :: Maybe (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
serviceKeys = case Maybe (ServiceCredentials, KeyPairEd25519)
serviceKeys_ of
            Just (ServiceCredentials, KeyPairEd25519)
sks | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
serviceCertsSMPVersion Bool -> Bool -> Bool
&& c 'TClient -> Bool
forall (p :: TransportPeer). c p -> Bool
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> Bool
certificateSent c 'TClient
c -> (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
-> Maybe
     (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
forall a. a -> Maybe a
Just (ServiceCredentials, KeyPairEd25519)
(ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
sks
            Maybe (ServiceCredentials, KeyPairEd25519)
_ -> Maybe (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
forall a. Maybe a
Nothing
          clientService :: Maybe SMPClientHandshakeService
clientService = (ServiceCredentials, KeyPairEd25519) -> SMPClientHandshakeService
(ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
-> SMPClientHandshakeService
mkClientService ((ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
 -> SMPClientHandshakeService)
-> Maybe
     (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
-> Maybe SMPClientHandshakeService
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
serviceKeys
          hs :: SMPClientHandshake
hs = SMPClientHandshake {$sel:smpVersion:SMPClientHandshake :: VersionSMP
smpVersion = VersionSMP
v, KeyHash
$sel:keyHash:SMPClientHandshake :: KeyHash
keyHash :: KeyHash
keyHash, $sel:authPubKey:SMPClientHandshake :: Maybe PublicKeyX25519
authPubKey = (PublicKeyX25519, PrivateKeyX25519) -> PublicKeyX25519
forall a b. (a, b) -> a
fst ((PublicKeyX25519, PrivateKeyX25519) -> PublicKeyX25519)
-> Maybe (PublicKeyX25519, PrivateKeyX25519)
-> Maybe PublicKeyX25519
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KeyPairX25519
Maybe (PublicKeyX25519, PrivateKeyX25519)
ks_, Bool
$sel:proxyServer:SMPClientHandshake :: Bool
proxyServer :: Bool
proxyServer, Maybe SMPClientHandshakeService
$sel:clientService:SMPClientHandshake :: Maybe SMPClientHandshakeService
clientService :: Maybe SMPClientHandshakeService
clientService}
      THandleSMP c 'TClient
-> SMPClientHandshake -> ExceptT TransportError IO ()
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake THandleSMP c 'TClient
th SMPClientHandshake
hs
      Maybe THClientService
service <- ((ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
 -> ExceptT TransportError IO THClientService)
-> Maybe
     (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
-> ExceptT TransportError IO (Maybe THClientService)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO THClientService
(ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
-> ExceptT TransportError IO THClientService
getClientService Maybe (ServiceCredentials, (PublicKeyEd25519, PrivateKey 'Ed25519))
serviceKeys
      IO (THandleSMP c 'TClient)
-> ExceptT TransportError IO (THandleSMP c 'TClient)
forall a. IO a -> ExceptT TransportError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (THandleSMP c 'TClient)
 -> ExceptT TransportError IO (THandleSMP c 'TClient))
-> IO (THandleSMP c 'TClient)
-> ExceptT TransportError IO (THandleSMP c 'TClient)
forall a b. (a -> b) -> a -> b
$ THandleSMP c 'TClient
-> VersionSMP
-> VersionRangeSMP
-> Maybe PrivateKeyX25519
-> Maybe (PublicKeyX25519, CertChainPubKey)
-> Bool
-> Maybe THClientService
-> IO (THandleSMP c 'TClient)
forall (c :: TransportPeer -> *).
THandleSMP c 'TClient
-> VersionSMP
-> VersionRangeSMP
-> Maybe PrivateKeyX25519
-> Maybe (PublicKeyX25519, CertChainPubKey)
-> Bool
-> Maybe THClientService
-> IO (THandleSMP c 'TClient)
smpTHandleClient THandleSMP c 'TClient
th VersionSMP
v VersionRangeSMP
vr ((PublicKeyX25519, PrivateKeyX25519) -> PrivateKeyX25519
forall a b. (a, b) -> b
snd ((PublicKeyX25519, PrivateKeyX25519) -> PrivateKeyX25519)
-> Maybe (PublicKeyX25519, PrivateKeyX25519)
-> Maybe PrivateKeyX25519
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KeyPairX25519
Maybe (PublicKeyX25519, PrivateKeyX25519)
ks_) Maybe (PublicKeyX25519, CertChainPubKey)
ck_ Bool
proxyServer Maybe THClientService
service
    Maybe (Compatible VersionRangeSMP)
Nothing -> TransportError -> ExceptT TransportError IO (THandleSMP c 'TClient)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TransportError
TEVersion
  where
    th :: THandleSMP c 'TClient
th@THandle {$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {ALPN
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ALPN
sessionId :: ALPN
sessionId}} = c 'TClient -> THandleSMP c 'TClient
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> THandleSMP c p
smpTHandle c 'TClient
c
    mkClientService :: (ServiceCredentials, C.KeyPairEd25519) -> SMPClientHandshakeService
    mkClientService :: (ServiceCredentials, KeyPairEd25519) -> SMPClientHandshakeService
mkClientService (ServiceCredentials {SMPServiceRole
$sel:serviceRole:ServiceCredentials :: ServiceCredentials -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, Credential
$sel:serviceCreds:ServiceCredentials :: ServiceCredentials -> Credential
serviceCreds :: Credential
serviceCreds, APrivateSignKey
$sel:serviceSignKey:ServiceCredentials :: ServiceCredentials -> APrivateSignKey
serviceSignKey :: APrivateSignKey
serviceSignKey}, (PublicKeyType (PrivateKey 'Ed25519)
k, PrivateKey 'Ed25519
_)) =
      let sk :: SignedExact PubKey
sk = APrivateSignKey -> PubKey -> SignedExact PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APrivateSignKey -> o -> SignedExact o
C.signX509 APrivateSignKey
serviceSignKey (PubKey -> SignedExact PubKey) -> PubKey -> SignedExact PubKey
forall a b. (a -> b) -> a -> b
$ PublicKeyEd25519 -> PubKey
forall (a :: Algorithm). PublicKey a -> PubKey
C.publicToX509 PublicKeyType (PrivateKey 'Ed25519)
PublicKeyEd25519
k
       in SMPClientHandshakeService {SMPServiceRole
$sel:serviceRole:SMPClientHandshakeService :: SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, $sel:serviceCertKey:SMPClientHandshakeService :: CertChainPubKey
serviceCertKey = CertificateChain -> SignedExact PubKey -> CertChainPubKey
CertChainPubKey (Credential -> CertificateChain
forall a b. (a, b) -> a
fst Credential
serviceCreds) SignedExact PubKey
sk}
    getClientService :: (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO THClientService
    getClientService :: (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO THClientService
getClientService (ServiceCredentials {SMPServiceRole
$sel:serviceRole:ServiceCredentials :: ServiceCredentials -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, Fingerprint
$sel:serviceCertHash:ServiceCredentials :: ServiceCredentials -> Fingerprint
serviceCertHash :: Fingerprint
serviceCertHash}, (PublicKeyType (PrivateKey 'Ed25519)
_, PrivateKey 'Ed25519
pk)) =
      THandleSMP c 'TClient
-> ExceptT TransportError IO SMPServerHandshakeResponse
forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> ExceptT TransportError IO smp
getHandshake THandleSMP c 'TClient
th ExceptT TransportError IO SMPServerHandshakeResponse
-> (SMPServerHandshakeResponse
    -> ExceptT TransportError IO THClientService)
-> ExceptT TransportError IO THClientService
forall a b.
ExceptT TransportError IO a
-> (a -> ExceptT TransportError IO b)
-> ExceptT TransportError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SMPServerHandshakeResponse {ServiceId
$sel:serviceId:SMPServerHandshakeResponse :: SMPServerHandshakeResponse -> ServiceId
serviceId :: ServiceId
serviceId} -> THClientService -> ExceptT TransportError IO THClientService
forall a. a -> ExceptT TransportError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure THClientService {ServiceId
$sel:serviceId:THClientService :: ServiceId
serviceId :: ServiceId
serviceId, SMPServiceRole
$sel:serviceRole:THClientService :: SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, Fingerprint
$sel:serviceCertHash:THClientService :: Fingerprint
serviceCertHash :: Fingerprint
serviceCertHash, $sel:serviceKey:THClientService :: PrivateKey 'Ed25519
serviceKey = PrivateKey 'Ed25519
pk}
        SMPServerHandshakeError {TransportError
$sel:handshakeError:SMPServerHandshakeResponse :: SMPServerHandshakeResponse -> TransportError
handshakeError :: TransportError
handshakeError} -> TransportError -> ExceptT TransportError IO THClientService
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TransportError
handshakeError

smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer)
smpTHandleServer :: forall (c :: TransportPeer -> *).
THandleSMP c 'TServer
-> VersionSMP
-> VersionRangeSMP
-> PrivateKeyX25519
-> Maybe PublicKeyX25519
-> Bool
-> Maybe THPeerClientService
-> IO (THandleSMP c 'TServer)
smpTHandleServer THandleSMP c 'TServer
th VersionSMP
v VersionRangeSMP
vr PrivateKeyX25519
pk Maybe PublicKeyX25519
k_ Bool
proxyServer Maybe THPeerClientService
peerClientService = do
  let thAuth :: Maybe (THandleAuth 'TServer)
thAuth = THandleAuth 'TServer -> Maybe (THandleAuth 'TServer)
forall a. a -> Maybe a
Just THAuthServer {$sel:serverPrivKey:THAuthClient :: PrivateKeyX25519
serverPrivKey = PrivateKeyX25519
pk, Maybe THPeerClientService
$sel:peerClientService:THAuthClient :: Maybe THPeerClientService
peerClientService :: Maybe THPeerClientService
peerClientService, $sel:sessSecret':THAuthClient :: Maybe DhSecretX25519
sessSecret' = (PublicKeyX25519 -> PrivateKeyX25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
`C.dh'` PrivateKeyX25519
pk) (PublicKeyX25519 -> DhSecretX25519)
-> Maybe PublicKeyX25519 -> Maybe DhSecretX25519
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Maybe PublicKeyX25519
k_}
  Maybe (TVar SbChainKey, TVar SbChainKey)
be <- THandleSMP c 'TServer
-> VersionSMP
-> Bool
-> Maybe (THandleAuth 'TServer)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> Bool
-> Maybe (THandleAuth p)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
blockEncryption THandleSMP c 'TServer
th VersionSMP
v Bool
proxyServer Maybe (THandleAuth 'TServer)
thAuth
  THandleSMP c 'TServer -> IO (THandleSMP c 'TServer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (THandleSMP c 'TServer -> IO (THandleSMP c 'TServer))
-> THandleSMP c 'TServer -> IO (THandleSMP c 'TServer)
forall a b. (a -> b) -> a -> b
$ THandleSMP c 'TServer
-> VersionSMP
-> VersionRangeSMP
-> Maybe (THandleAuth 'TServer)
-> Maybe TSbChainKeys
-> THandleSMP c 'TServer
forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> VersionRangeSMP
-> Maybe (THandleAuth p)
-> Maybe TSbChainKeys
-> THandleSMP c p
smpTHandle_ THandleSMP c 'TServer
th VersionSMP
v VersionRangeSMP
vr Maybe (THandleAuth 'TServer)
thAuth (Maybe TSbChainKeys -> THandleSMP c 'TServer)
-> Maybe TSbChainKeys -> THandleSMP c 'TServer
forall a b. (a -> b) -> a -> b
$ (TVar SbChainKey -> TVar SbChainKey -> TSbChainKeys)
-> (TVar SbChainKey, TVar SbChainKey) -> TSbChainKeys
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TVar SbChainKey -> TVar SbChainKey -> TSbChainKeys
TSbChainKeys ((TVar SbChainKey, TVar SbChainKey) -> TSbChainKeys)
-> Maybe (TVar SbChainKey, TVar SbChainKey) -> Maybe TSbChainKeys
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TVar SbChainKey, TVar SbChainKey)
be

smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> IO (THandleSMP c 'TClient)
smpTHandleClient :: forall (c :: TransportPeer -> *).
THandleSMP c 'TClient
-> VersionSMP
-> VersionRangeSMP
-> Maybe PrivateKeyX25519
-> Maybe (PublicKeyX25519, CertChainPubKey)
-> Bool
-> Maybe THClientService
-> IO (THandleSMP c 'TClient)
smpTHandleClient THandleSMP c 'TClient
th VersionSMP
v VersionRangeSMP
vr Maybe PrivateKeyX25519
pk_ Maybe (PublicKeyX25519, CertChainPubKey)
ck_ Bool
proxyServer Maybe THClientService
clientService = do
  let thAuth :: Maybe (THandleAuth 'TClient)
thAuth = (PublicKeyX25519, CertChainPubKey) -> THandleAuth 'TClient
clientTHParams ((PublicKeyX25519, CertChainPubKey) -> THandleAuth 'TClient)
-> Maybe (PublicKeyX25519, CertChainPubKey)
-> Maybe (THandleAuth 'TClient)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Maybe (PublicKeyX25519, CertChainPubKey)
ck_
  Maybe (TVar SbChainKey, TVar SbChainKey)
be <- THandleSMP c 'TClient
-> VersionSMP
-> Bool
-> Maybe (THandleAuth 'TClient)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> Bool
-> Maybe (THandleAuth p)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
blockEncryption THandleSMP c 'TClient
th VersionSMP
v Bool
proxyServer Maybe (THandleAuth 'TClient)
thAuth
  -- swap is needed to use client's sndKey as server's rcvKey and vice versa
  THandleSMP c 'TClient -> IO (THandleSMP c 'TClient)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (THandleSMP c 'TClient -> IO (THandleSMP c 'TClient))
-> THandleSMP c 'TClient -> IO (THandleSMP c 'TClient)
forall a b. (a -> b) -> a -> b
$ THandleSMP c 'TClient
-> VersionSMP
-> VersionRangeSMP
-> Maybe (THandleAuth 'TClient)
-> Maybe TSbChainKeys
-> THandleSMP c 'TClient
forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> VersionRangeSMP
-> Maybe (THandleAuth p)
-> Maybe TSbChainKeys
-> THandleSMP c p
smpTHandle_ THandleSMP c 'TClient
th VersionSMP
v VersionRangeSMP
vr Maybe (THandleAuth 'TClient)
thAuth (Maybe TSbChainKeys -> THandleSMP c 'TClient)
-> Maybe TSbChainKeys -> THandleSMP c 'TClient
forall a b. (a -> b) -> a -> b
$ (TVar SbChainKey -> TVar SbChainKey -> TSbChainKeys)
-> (TVar SbChainKey, TVar SbChainKey) -> TSbChainKeys
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TVar SbChainKey -> TVar SbChainKey -> TSbChainKeys
TSbChainKeys ((TVar SbChainKey, TVar SbChainKey) -> TSbChainKeys)
-> ((TVar SbChainKey, TVar SbChainKey)
    -> (TVar SbChainKey, TVar SbChainKey))
-> (TVar SbChainKey, TVar SbChainKey)
-> TSbChainKeys
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar SbChainKey, TVar SbChainKey)
-> (TVar SbChainKey, TVar SbChainKey)
forall a b. (a, b) -> (b, a)
swap ((TVar SbChainKey, TVar SbChainKey) -> TSbChainKeys)
-> Maybe (TVar SbChainKey, TVar SbChainKey) -> Maybe TSbChainKeys
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TVar SbChainKey, TVar SbChainKey)
be
  where
    clientTHParams :: (PublicKeyX25519, CertChainPubKey) -> THandleAuth 'TClient
clientTHParams (PublicKeyX25519
k, CertChainPubKey
ck) =
      THAuthClient
        { $sel:peerServerPubKey:THAuthClient :: PublicKeyX25519
peerServerPubKey = PublicKeyX25519
k,
          $sel:peerServerCertKey:THAuthClient :: CertChainPubKey
peerServerCertKey = CertChainPubKey -> CertChainPubKey
forceCertChain CertChainPubKey
ck,
          Maybe THClientService
$sel:clientService:THAuthClient :: Maybe THClientService
clientService :: Maybe THClientService
clientService,
          $sel:sessSecret:THAuthClient :: Maybe DhSecretX25519
sessSecret = PublicKeyX25519 -> PrivateKeyX25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
k (PrivateKeyX25519 -> DhSecretX25519)
-> Maybe PrivateKeyX25519 -> Maybe DhSecretX25519
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Maybe PrivateKeyX25519
pk_
        }

blockEncryption :: THandleSMP c p -> VersionSMP -> Bool -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
blockEncryption :: forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> Bool
-> Maybe (THandleAuth p)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
blockEncryption THandle {$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {ALPN
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ALPN
sessionId :: ALPN
sessionId}} VersionSMP
v Bool
proxyServer = \case
  Just THandleAuth p
thAuth | Bool -> Bool
not Bool
proxyServer Bool -> Bool -> Bool
&& VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
encryptedBlockSMPVersion -> case THandleAuth p
thAuth of
    THAuthClient {Maybe DhSecretX25519
$sel:sessSecret:THAuthClient :: THandleAuth 'TClient -> Maybe DhSecretX25519
sessSecret :: Maybe DhSecretX25519
sessSecret} -> Maybe DhSecretX25519
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
be Maybe DhSecretX25519
sessSecret
    THAuthServer {Maybe DhSecretX25519
$sel:sessSecret':THAuthClient :: THandleAuth 'TServer -> Maybe DhSecretX25519
sessSecret' :: Maybe DhSecretX25519
sessSecret'} -> Maybe DhSecretX25519
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
be Maybe DhSecretX25519
sessSecret'
  Maybe (THandleAuth p)
_ -> Maybe (TVar SbChainKey, TVar SbChainKey)
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TVar SbChainKey, TVar SbChainKey)
forall a. Maybe a
Nothing
  where
    be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
    be :: Maybe DhSecretX25519
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
be = (DhSecretX25519 -> IO (TVar SbChainKey, TVar SbChainKey))
-> Maybe DhSecretX25519
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((DhSecretX25519 -> IO (TVar SbChainKey, TVar SbChainKey))
 -> Maybe DhSecretX25519
 -> IO (Maybe (TVar SbChainKey, TVar SbChainKey)))
-> (DhSecretX25519 -> IO (TVar SbChainKey, TVar SbChainKey))
-> Maybe DhSecretX25519
-> IO (Maybe (TVar SbChainKey, TVar SbChainKey))
forall a b. (a -> b) -> a -> b
$ \(C.DhSecretX25519 DhSecret
secret) -> (SbChainKey -> IO (TVar SbChainKey))
-> (SbChainKey -> IO (TVar SbChainKey))
-> (SbChainKey, SbChainKey)
-> IO (TVar SbChainKey, TVar SbChainKey)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM SbChainKey -> IO (TVar SbChainKey)
forall a. a -> IO (TVar a)
newTVarIO SbChainKey -> IO (TVar SbChainKey)
forall a. a -> IO (TVar a)
newTVarIO ((SbChainKey, SbChainKey) -> IO (TVar SbChainKey, TVar SbChainKey))
-> (SbChainKey, SbChainKey)
-> IO (TVar SbChainKey, TVar SbChainKey)
forall a b. (a -> b) -> a -> b
$ ALPN -> DhSecret -> (SbChainKey, SbChainKey)
forall secret.
ByteArrayAccess secret =>
ALPN -> secret -> (SbChainKey, SbChainKey)
C.sbcInit ALPN
sessionId DhSecret
secret

smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
smpTHandle_ :: forall (c :: TransportPeer -> *) (p :: TransportPeer).
THandleSMP c p
-> VersionSMP
-> VersionRangeSMP
-> Maybe (THandleAuth p)
-> Maybe TSbChainKeys
-> THandleSMP c p
smpTHandle_ th :: THandleSMP c p
th@THandle {THandleParams SMPVersion p
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params :: THandleParams SMPVersion p
params} VersionSMP
v VersionRangeSMP
vr Maybe (THandleAuth p)
thAuth Maybe TSbChainKeys
encryptBlock =
  -- TODO drop SMP v6: make thAuth non-optional
  -- * Note: update version-based parameters in smpTHParamsSetVersion as well.
  let params' :: THandleParams SMPVersion p
params' =
        THandleParams SMPVersion p
params
          { thVersion = v,
            thServerVRange = vr,
            thAuth,
            implySessId = v >= authCmdsSMPVersion,
            encryptBlock,
            serviceAuth = v >= serviceCertsSMPVersion -- optional service signature will be encoded for all commands and responses
          }
   in (THandleSMP c p
th :: THandleSMP c p) {params = params'}

forceCertChain :: CertChainPubKey -> CertChainPubKey
forceCertChain :: CertChainPubKey -> CertChainPubKey
forceCertChain cert :: CertChainPubKey
cert@(CertChainPubKey (X.CertificateChain [SignedExact Certificate]
cc) SignedExact PubKey
signedKey) = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([SignedExact Certificate] -> String
forall a. Show a => a -> String
show [SignedExact Certificate]
cc) Int -> CertChainPubKey -> CertChainPubKey
forall a b. a -> b -> b
`seq` SignedExact PubKey -> String
forall a. Show a => a -> String
show SignedExact PubKey
signedKey String -> CertChainPubKey -> CertChainPubKey
forall a b. a -> b -> b
`seq` CertChainPubKey
cert
{-# INLINE forceCertChain #-}

-- This function is only used with v >= 8, so currently it's a simple record update.
-- * Note: it requires updating version-based parameters, to be consistent with smpTHandle_.
smpTHParamsSetVersion :: VersionSMP -> THandleParams SMPVersion p -> THandleParams SMPVersion p
smpTHParamsSetVersion :: forall (p :: TransportPeer).
VersionSMP
-> THandleParams SMPVersion p -> THandleParams SMPVersion p
smpTHParamsSetVersion VersionSMP
v THandleParams SMPVersion p
params =
  THandleParams SMPVersion p
params
    { thVersion = v,
      serviceAuth = v >= serviceCertsSMPVersion
    }
{-# INLINE smpTHParamsSetVersion #-}

sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake :: forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake THandle v c p
th = IO (Either TransportError ()) -> ExceptT TransportError IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either TransportError ()) -> ExceptT TransportError IO ())
-> (smp -> IO (Either TransportError ()))
-> smp
-> ExceptT TransportError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THandle v c p -> ALPN -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> ALPN -> IO (Either TransportError ())
tPutBlock THandle v c p
th (ALPN -> IO (Either TransportError ()))
-> (smp -> ALPN) -> smp -> IO (Either TransportError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. smp -> ALPN
forall a. Encoding a => a -> ALPN
smpEncode

-- ignores tail bytes to allow future extensions
getHandshake :: (Transport c, Encoding smp) => THandle v c p -> ExceptT TransportError IO smp
getHandshake :: forall (c :: TransportPeer -> *) smp v (p :: TransportPeer).
(Transport c, Encoding smp) =>
THandle v c p -> ExceptT TransportError IO smp
getHandshake THandle v c p
th = IO (Either TransportError smp) -> ExceptT TransportError IO smp
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either TransportError smp) -> ExceptT TransportError IO smp)
-> IO (Either TransportError smp) -> ExceptT TransportError IO smp
forall a b. (a -> b) -> a -> b
$ ((String -> TransportError)
-> Either String smp -> Either TransportError smp
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
_ -> HandshakeError -> TransportError
TEHandshake HandshakeError
PARSE) (Either String smp -> Either TransportError smp)
-> (ALPN -> Either String smp) -> ALPN -> Either TransportError smp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser smp -> ALPN -> Either String smp
forall a. Parser a -> ALPN -> Either String a
A.parseOnly Parser smp
forall a. Encoding a => Parser a
smpP (ALPN -> Either TransportError smp)
-> Either TransportError ALPN -> Either TransportError smp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Either TransportError ALPN -> Either TransportError smp)
-> IO (Either TransportError ALPN)
-> IO (Either TransportError smp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle v c p -> IO (Either TransportError ALPN)
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> IO (Either TransportError ALPN)
tGetBlock THandle v c p
th

smpTHandle :: Transport c => c p -> THandleSMP c p
smpTHandle :: forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> THandleSMP c p
smpTHandle c p
c = THandle {$sel:connection:THandle :: c p
connection = c p
c, THandleParams SMPVersion p
$sel:params:THandle :: THandleParams SMPVersion p
params :: THandleParams SMPVersion p
params}
  where
    v :: VersionSMP
v = Word16 -> VersionSMP
VersionSMP Word16
0
    params :: THandleParams SMPVersion p
params =
      THandleParams
        { $sel:sessionId:THandleParams :: ALPN
sessionId = c p -> ALPN
forall (p :: TransportPeer). c p -> ALPN
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> ALPN
tlsUnique c p
c,
          $sel:blockSize:THandleParams :: Int
blockSize = Int
smpBlockSize,
          $sel:thServerVRange:THandleParams :: VersionRangeSMP
thServerVRange = VersionSMP -> VersionRangeSMP
forall v. Version v -> VersionRange v
versionToRange VersionSMP
v,
          $sel:thVersion:THandleParams :: VersionSMP
thVersion = VersionSMP
v,
          $sel:thAuth:THandleParams :: Maybe (THandleAuth p)
thAuth = Maybe (THandleAuth p)
forall a. Maybe a
Nothing,
          $sel:implySessId:THandleParams :: Bool
implySessId = Bool
False,
          $sel:encryptBlock:THandleParams :: Maybe TSbChainKeys
encryptBlock = Maybe TSbChainKeys
forall a. Maybe a
Nothing,
          $sel:batch:THandleParams :: Bool
batch = Bool
True,
          $sel:serviceAuth:THandleParams :: Bool
serviceAuth = Bool
False
        }

$(J.deriveJSON (sumTypeJSON id) ''HandshakeError)

$(J.deriveJSON (sumTypeJSON $ dropPrefix "TE") ''TransportError)