mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
refactor types (#1551)
This commit is contained in:
Evgeny
@@ -56,7 +56,7 @@ import Simplex.Messaging.Protocol
|
||||
SenderId,
|
||||
pattern NoEntity,
|
||||
)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -147,12 +147,12 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
|
||||
Nothing -> throwE $ PCETransportError TEVersion
|
||||
Just (Compatible vr) ->
|
||||
fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do
|
||||
let (X.CertificateChain cert, exact) = serverAuth
|
||||
let CertChainPubKey (X.CertificateChain cert) exact = serverAuth
|
||||
case cert of
|
||||
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
|
||||
_ -> throwError "bad certificate"
|
||||
pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
C.x509ToPublic' pubKey
|
||||
sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
|
||||
sendClientHandshake chs = do
|
||||
chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
|
||||
|
||||
@@ -61,7 +61,7 @@ import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatu
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
|
||||
@@ -110,7 +110,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
runServer :: M ()
|
||||
runServer = do
|
||||
srvCreds@(chain, pk) <- asks tlsServerCreds
|
||||
signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
|
||||
signKey <- liftIO $ case C.x509ToPrivate' pk of
|
||||
Right pk' -> pure pk'
|
||||
Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
|
||||
env <- ask
|
||||
@@ -142,7 +142,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
unless (B.null bodyHead) $ throwE HANDSHAKE
|
||||
(k, pk) <- atomically . C.generateKeyPair =<< asks random
|
||||
atomically $ TM.insert sessionId (HandshakeSent pk) sessions
|
||||
let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
|
||||
let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
|
||||
let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
|
||||
shs <- encodeXftp hs
|
||||
#ifdef slow_servers
|
||||
|
||||
@@ -42,7 +42,7 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (bimap, first)
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -50,7 +50,6 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Functor (($>))
|
||||
import Data.Word (Word16, Word32)
|
||||
import qualified Data.X509 as X
|
||||
import Network.HTTP2.Client (HTTP2Error)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
@@ -58,7 +57,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
import Simplex.Messaging.Util (bshow, tshow)
|
||||
import Simplex.Messaging.Version
|
||||
@@ -112,7 +111,7 @@ data XFTPServerHandshake = XFTPServerHandshake
|
||||
{ xftpVersionRange :: VersionRangeXFTP,
|
||||
sessionId :: SessionId,
|
||||
-- | pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey)
|
||||
authPubKey :: CertChainPubKey
|
||||
}
|
||||
|
||||
data XFTPClientHandshake = XFTPClientHandshake
|
||||
@@ -132,15 +131,12 @@ instance Encoding XFTPClientHandshake where
|
||||
|
||||
instance Encoding XFTPServerHandshake where
|
||||
smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
|
||||
smpEncode (xftpVersionRange, sessionId, auth)
|
||||
where
|
||||
auth = bimap C.encodeCertChain C.SignedObject authPubKey
|
||||
smpEncode (xftpVersionRange, sessionId, authPubKey)
|
||||
smpP = do
|
||||
(xftpVersionRange, sessionId) <- smpP
|
||||
cert <- C.certChainP
|
||||
C.SignedObject key <- smpP
|
||||
authPubKey <- smpP
|
||||
Tail _compat <- smpP
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)}
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey}
|
||||
|
||||
sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
|
||||
sendEncFile h send = go
|
||||
|
||||
@@ -956,7 +956,7 @@ connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT S
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
| thVersion (thParams c) >= sendingProxySMPVersion =
|
||||
sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (chain, key) ->
|
||||
PKEY sId vr (CertChainPubKey chain key) ->
|
||||
case supportedClientSMPRelayVRange `compatibleVersion` vr of
|
||||
Nothing -> throwE $ transportErr TEVersion
|
||||
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key
|
||||
@@ -970,10 +970,9 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
|
||||
serverKey <- case cert of
|
||||
[leaf, ca]
|
||||
| XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 ->
|
||||
C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned leaf, []) >>= C.pubKey
|
||||
C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned leaf
|
||||
_ -> throwError "bad certificate"
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
C.x509ToPublic' =<< C.verifyX509 serverKey exact
|
||||
|
||||
data ProxiedRelay = ProxiedRelay
|
||||
{ prSessionId :: SessionId,
|
||||
|
||||
@@ -64,6 +64,7 @@ module Simplex.Messaging.Crypto
|
||||
AAuthKeyPair,
|
||||
KeyPair,
|
||||
KeyPairX25519,
|
||||
KeyPairEd25519,
|
||||
ASignatureKeyPair,
|
||||
DhSecret (..),
|
||||
DhSecretX25519,
|
||||
@@ -78,7 +79,9 @@ module Simplex.Messaging.Crypto
|
||||
generateDhKeyPair,
|
||||
privateToX509,
|
||||
x509ToPublic,
|
||||
x509ToPublic',
|
||||
x509ToPrivate,
|
||||
x509ToPrivate',
|
||||
publicKey,
|
||||
signatureKeyPair,
|
||||
publicToX509,
|
||||
@@ -678,6 +681,8 @@ type KeyPair a = KeyPairType (PrivateKey a)
|
||||
|
||||
type KeyPairX25519 = KeyPair X25519
|
||||
|
||||
type KeyPairEd25519 = KeyPair Ed25519
|
||||
|
||||
-- TODO narrow key pair types to have the same algorithm in both keys
|
||||
type AKeyPair = KeyPairType APrivateKey
|
||||
|
||||
@@ -1484,6 +1489,10 @@ x509ToPublic = \case
|
||||
(X.PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k
|
||||
r -> keyError r
|
||||
|
||||
x509ToPublic' :: CryptoPublicKey k => X.PubKey -> Either String k
|
||||
x509ToPublic' k = x509ToPublic (k, []) >>= pubKey
|
||||
{-# INLINE x509ToPublic' #-}
|
||||
|
||||
x509ToPrivate :: (X.PrivKey, [ASN1]) -> Either String APrivateKey
|
||||
x509ToPrivate = \case
|
||||
(X.PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k
|
||||
@@ -1492,6 +1501,10 @@ x509ToPrivate = \case
|
||||
(X.PrivKeyX448 k, []) -> Right . APrivateKey SX448 . PrivateKeyX448 k $ X448.toPublic k
|
||||
r -> keyError r
|
||||
|
||||
x509ToPrivate' :: CryptoPrivateKey k => X.PrivKey -> Either String k
|
||||
x509ToPrivate' pk = x509ToPrivate (pk, []) >>= privKey
|
||||
{-# INLINE x509ToPrivate' #-}
|
||||
|
||||
decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1])
|
||||
decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict
|
||||
|
||||
|
||||
@@ -48,7 +48,7 @@ contactShortLinkKdf (LinkKey k) =
|
||||
invShortLinkKdf :: LinkKey -> C.SbKey
|
||||
invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
|
||||
|
||||
encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
|
||||
encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
|
||||
encodeSignLinkData (rootKey, pk) agentVRange connReq userData =
|
||||
let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq}
|
||||
md = smpEncode $ connLinkData @c agentVRange userData
|
||||
|
||||
@@ -123,10 +123,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
|
||||
runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
|
||||
runServer (tcpPort, ATransport t, _addHTTP) = do
|
||||
srvCreds <- asks tlsServerCreds
|
||||
serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
|
||||
serverSignKey <- either fail pure $ C.x509ToPrivate' $ snd srvCreds
|
||||
env <- ask
|
||||
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
|
||||
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
|
||||
|
||||
runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
|
||||
runClient signKey _ h = do
|
||||
|
||||
@@ -55,14 +55,14 @@ data NtfTknData = NtfTknData
|
||||
token :: DeviceToken,
|
||||
tknStatus :: TVar NtfTknStatus,
|
||||
tknVerifyKey :: NtfPublicAuthKey,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhKeys :: C.KeyPairX25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: TVar Word16,
|
||||
tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
|
||||
}
|
||||
|
||||
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
|
||||
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
|
||||
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
|
||||
tknStatus <- newTVarIO NTRegistered
|
||||
tknCronInterval <- newTVarIO 0
|
||||
|
||||
@@ -137,7 +137,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer = do
|
||||
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey signedKey
|
||||
(,(getPeerCertChain c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
(,CertChainPubKey (getPeerCertChain c) signedKey) <$> C.x509ToPublic' pubKey
|
||||
let v = maxVersion vr
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
pure $ ntfThHandleClient th v vr ck_
|
||||
@@ -148,7 +148,7 @@ ntfThHandleServer th v vr pk =
|
||||
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
|
||||
in ntfThHandle_ th v vr (Just thAuth)
|
||||
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient th v vr ck_ =
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
|
||||
in ntfThHandle_ th v vr thAuth
|
||||
|
||||
@@ -52,7 +52,7 @@ data NtfToken = NtfToken
|
||||
-- | key used by the ntf client to sign transmissions
|
||||
ntfPrivKey :: C.APrivateAuthKey,
|
||||
-- | client's DH keys (to repeat registration if necessary)
|
||||
ntfDhKeys :: C.KeyPair 'C.X25519,
|
||||
ntfDhKeys :: C.KeyPairX25519,
|
||||
-- | shared DH secret used to encrypt/decrypt notifications e2e
|
||||
ntfDhSecret :: Maybe C.DhSecretX25519,
|
||||
-- | token status
|
||||
@@ -63,7 +63,7 @@ data NtfToken = NtfToken
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
|
||||
newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
|
||||
NtfToken
|
||||
{ deviceToken,
|
||||
|
||||
@@ -220,7 +220,6 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import qualified Data.X509 as X
|
||||
import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
|
||||
import qualified GHC.TypeLits as TE
|
||||
import qualified GHC.TypeLits as Type
|
||||
@@ -575,7 +574,7 @@ data BrokerMsg where
|
||||
NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
|
||||
NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
|
||||
-- Should include certificate chain
|
||||
PKEY :: SessionId -> VersionRangeSMP -> (X.CertificateChain, X.SignedExact X.PubKey) -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
|
||||
PKEY :: SessionId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
|
||||
RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
|
||||
PRES :: EncResponse -> BrokerMsg -- proxy to client
|
||||
END :: BrokerMsg
|
||||
@@ -1629,7 +1628,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
e (MSG_, ' ', msgId, Tail body)
|
||||
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
|
||||
NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
|
||||
PKEY sid vr (cert, key) -> e (PKEY_, ' ', sid, vr, C.encodeCertChain cert, C.SignedObject key)
|
||||
PKEY sid vr certKey -> e (PKEY_, ' ', sid, vr, certKey)
|
||||
RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
|
||||
PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
|
||||
END -> e END_
|
||||
@@ -1671,7 +1670,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
LNK_ -> LNK <$> _smpP <*> smpP
|
||||
NID_ -> NID <$> _smpP <*> smpP
|
||||
NMSG_ -> NMSG <$> _smpP <*> smpP
|
||||
PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP))
|
||||
PKEY_ -> PKEY <$> _smpP <*> smpP <*> smpP
|
||||
RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
|
||||
PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
|
||||
END_ -> pure END
|
||||
|
||||
@@ -184,7 +184,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
httpCreds_ <- asks httpServerCreds
|
||||
ss <- liftIO newSocketState
|
||||
asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
|
||||
srvSignKey <- either fail pure $ fromTLSPrivKey srvKey
|
||||
srvSignKey <- either fail pure $ C.x509ToPrivate' srvKey
|
||||
env <- ask
|
||||
liftIO $ case (httpCreds_, attachHTTP_) of
|
||||
(Just httpCreds, Just attachHTTP) | addHTTP ->
|
||||
@@ -199,7 +199,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
httpALPN = ["h2", "http/1.1"]
|
||||
_ ->
|
||||
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
|
||||
fromTLSPrivKey pk = C.x509ToPrivate (pk, []) >>= C.privKey
|
||||
|
||||
sigIntHandlerThread :: M ()
|
||||
sigIntHandlerThread = do
|
||||
|
||||
@@ -81,6 +81,7 @@ module Simplex.Messaging.Transport
|
||||
THandle (..),
|
||||
THandleParams (..),
|
||||
THandleAuth (..),
|
||||
CertChainPubKey (..),
|
||||
TSbChainKeys (..),
|
||||
TransportError (..),
|
||||
HandshakeError (..),
|
||||
@@ -103,7 +104,7 @@ 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 (bimap, first)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -303,9 +304,12 @@ type ASrvTransport = ATransport 'TServer
|
||||
getServerVerifyKey :: Transport c => c 'TClient -> Either String C.APublicVerifyKey
|
||||
getServerVerifyKey c =
|
||||
case getPeerCertChain c of
|
||||
X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey
|
||||
X.CertificateChain (server : _ca) -> getCertVerifyKey server
|
||||
_ -> Left "no certificate chain"
|
||||
|
||||
getCertVerifyKey :: X.SignedCertificate -> Either String C.APublicVerifyKey
|
||||
getCertVerifyKey cert = C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned cert
|
||||
|
||||
-- * TLS Transport
|
||||
|
||||
data TLS (p :: TransportPeer) = TLS
|
||||
@@ -452,7 +456,7 @@ data THandleParams v p = THandleParams
|
||||
data THandleAuth (p :: TransportPeer) where
|
||||
THAuthClient ::
|
||||
{ serverPeerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
|
||||
serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is serverPeerPubKey signed with server certificate
|
||||
serverCertKey :: CertChainPubKey, -- the key here is serverPeerPubKey signed with server certificate
|
||||
sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
|
||||
} ->
|
||||
THandleAuth 'TClient
|
||||
@@ -470,15 +474,15 @@ data TSbChainKeys = TSbChainKeys
|
||||
-- | TLS-unique channel binding
|
||||
type SessionId = ByteString
|
||||
|
||||
data ServerHandshake = ServerHandshake
|
||||
data SMPServerHandshake = SMPServerHandshake
|
||||
{ smpVersionRange :: VersionRangeSMP,
|
||||
sessionId :: SessionId,
|
||||
-- pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
-- todo C.PublicKeyX25519
|
||||
authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
|
||||
authPubKey :: Maybe CertChainPubKey
|
||||
}
|
||||
|
||||
data ClientHandshake = ClientHandshake
|
||||
data SMPClientHandshake = SMPClientHandshake
|
||||
{ -- | agreed SMP server protocol version
|
||||
smpVersion :: VersionSMP,
|
||||
-- | server identity - CA certificate fingerprint
|
||||
@@ -491,8 +495,8 @@ data ClientHandshake = ClientHandshake
|
||||
proxyServer :: Bool
|
||||
}
|
||||
|
||||
instance Encoding ClientHandshake where
|
||||
smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
|
||||
instance Encoding SMPClientHandshake where
|
||||
smpEncode SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
|
||||
smpEncode (v, keyHash)
|
||||
<> encodeAuthEncryptCmds v authPubKey
|
||||
<> ifHasProxy v (smpEncode proxyServer) ""
|
||||
@@ -501,28 +505,35 @@ instance Encoding ClientHandshake where
|
||||
-- TODO drop SMP v6: remove special parser and make key non-optional
|
||||
authPubKey <- authEncryptCmdsP v smpP
|
||||
proxyServer <- ifHasProxy v smpP (pure False)
|
||||
pure ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
|
||||
pure SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
|
||||
|
||||
ifHasProxy :: VersionSMP -> a -> a -> a
|
||||
ifHasProxy v a b = if v >= proxyServerHandshakeSMPVersion then a else b
|
||||
|
||||
instance Encoding ServerHandshake where
|
||||
smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
|
||||
instance Encoding SMPServerHandshake where
|
||||
smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey} =
|
||||
smpEncode (smpVersionRange, sessionId) <> auth
|
||||
where
|
||||
auth =
|
||||
encodeAuthEncryptCmds (maxVersion smpVersionRange) $
|
||||
bimap C.encodeCertChain C.SignedObject <$> authPubKey
|
||||
auth = encodeAuthEncryptCmds (maxVersion smpVersionRange) authPubKey
|
||||
smpP = do
|
||||
(smpVersionRange, sessionId) <- smpP
|
||||
-- TODO drop SMP v6: remove special parser and make key non-optional
|
||||
authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) authP
|
||||
pure ServerHandshake {smpVersionRange, sessionId, authPubKey}
|
||||
where
|
||||
authP = do
|
||||
cert <- C.certChainP
|
||||
C.SignedObject key <- smpP
|
||||
pure (cert, key)
|
||||
authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) smpP
|
||||
pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey}
|
||||
|
||||
-- newtype for CertificateChain and a session key signed with this certificate
|
||||
data CertChainPubKey = CertChainPubKey
|
||||
{ certChain :: X.CertificateChain,
|
||||
signedPubKey :: X.SignedExact X.PubKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding CertChainPubKey where
|
||||
smpEncode CertChainPubKey {certChain, signedPubKey} = smpEncode (C.encodeCertChain certChain, C.SignedObject signedPubKey)
|
||||
smpP = do
|
||||
certChain <- C.certChainP
|
||||
C.SignedObject signedPubKey <- smpP
|
||||
pure CertChainPubKey {certChain, signedPubKey}
|
||||
|
||||
encodeAuthEncryptCmds :: Encoding a => VersionSMP -> Maybe a -> ByteString
|
||||
encodeAuthEncryptCmds v k
|
||||
@@ -609,9 +620,9 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
sk = C.signX509 srvSignKey $ C.publicToX509 k
|
||||
smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
|
||||
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (srvCert, sk)}
|
||||
sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = Just (CertChainPubKey srvCert sk)}
|
||||
getHandshake th >>= \case
|
||||
ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
|
||||
SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
|
||||
| keyHash /= kh ->
|
||||
throwE $ TEHandshake IDENTITY
|
||||
| otherwise ->
|
||||
@@ -625,7 +636,7 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange = do
|
||||
smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
|
||||
smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
|
||||
SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
|
||||
when (sessionId /= sessId) $ throwE 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.
|
||||
@@ -646,16 +657,15 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
|
||||
else vRange
|
||||
case smpVersionRange `compatibleVRange` smpVRange of
|
||||
Just (Compatible vr) -> do
|
||||
ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
|
||||
ck_ <- forM authPubKey $ \certKey@(CertChainPubKey (X.CertificateChain cert) exact) ->
|
||||
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
case cert of
|
||||
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
|
||||
_ -> throwError "bad certificate"
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
(,certKey) <$> (C.x509ToPublic' =<< C.verifyX509 serverKey exact)
|
||||
let v = maxVersion vr
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
|
||||
sendHandshake th $ SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
|
||||
liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer
|
||||
Nothing -> throwE TEVersion
|
||||
|
||||
@@ -665,7 +675,7 @@ smpTHandleServer th v vr pk k_ proxyServer = do
|
||||
be <- blockEncryption th v proxyServer thAuth
|
||||
pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
|
||||
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> Bool -> IO (THandleSMP c 'TClient)
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> Bool -> IO (THandleSMP c 'TClient)
|
||||
smpTHandleClient th v vr pk_ ck_ proxyServer = do
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
|
||||
be <- blockEncryption th v proxyServer thAuth
|
||||
@@ -689,8 +699,8 @@ smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
|
||||
in (th :: THandleSMP c p) {params = params'}
|
||||
|
||||
{-# INLINE forceCertChain #-}
|
||||
forceCertChain :: (X.CertificateChain, X.SignedExact T.PubKey) -> (X.CertificateChain, X.SignedExact T.PubKey)
|
||||
forceCertChain cert@(X.CertificateChain cc, signedKey) = length (show cc) `seq` show signedKey `seq` cert
|
||||
forceCertChain :: CertChainPubKey -> CertChainPubKey
|
||||
forceCertChain cert@(CertChainPubKey (X.CertificateChain cc) signedKey) = length (show cc) `seq` show signedKey `seq` cert
|
||||
|
||||
-- This function is only used with v >= 8, so currently it's a simple record update.
|
||||
-- It may require some parameters update in the future, to be consistent with smpTHandle_.
|
||||
|
||||
@@ -125,7 +125,7 @@ data TransportClientConfig = TransportClientConfig
|
||||
tcpConnectTimeout :: Int,
|
||||
tcpKeepAlive :: Maybe KeepAliveOpts,
|
||||
logTLSErrors :: Bool,
|
||||
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
|
||||
clientCredentials :: Maybe T.Credential,
|
||||
alpn :: Maybe [ALPN],
|
||||
useSNI :: Bool
|
||||
}
|
||||
@@ -265,7 +265,7 @@ instance StrEncoding SocksAuth where
|
||||
password <- A.takeTill (== '@') <* A.char '@'
|
||||
pure SocksAuthUsername {username, password}
|
||||
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe T.Credential -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ sni serverCerts =
|
||||
(T.defaultParamsClient host p)
|
||||
{ T.clientUseServerNameIndication = sni,
|
||||
|
||||
@@ -112,7 +112,7 @@ runTransportServerSocketState ss started getSocket threadLabel srvSupported srvC
|
||||
srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_
|
||||
|
||||
-- | Run a transport server with provided connection setup and handler.
|
||||
runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
|
||||
runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> T.Credential) -> T.ServerParams -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
|
||||
runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do
|
||||
labelMyThread $ "transport server for " <> threadLabel
|
||||
runTCPServerSocket ss started getSocket $ \conn ->
|
||||
|
||||
@@ -168,8 +168,8 @@ data RCCtrlPairing = RCCtrlPairing
|
||||
}
|
||||
|
||||
data RCHostKeys = RCHostKeys
|
||||
{ sessKeys :: C.KeyPair 'C.Ed25519,
|
||||
dhKeys :: C.KeyPair 'C.X25519
|
||||
{ sessKeys :: C.KeyPairEd25519,
|
||||
dhKeys :: C.KeyPairX25519
|
||||
}
|
||||
|
||||
-- Connected session with Host
|
||||
|
||||
@@ -393,7 +393,7 @@ testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
|
||||
serverKey <- head <$> XF.readKeyFile "tests/fixtures/server.key"
|
||||
signKey <- either error pure $ C.x509ToPrivate (serverKey, []) >>= C.privKey @C.APrivateSignKey
|
||||
(serverAuthPub, _) <- atomically $ C.generateKeyPair @'C.X25519 g
|
||||
let serverCertKey = (X.CertificateChain [serverCert, ca], C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
|
||||
let serverCertKey = CertChainPubKey (X.CertificateChain [serverCert, ca]) (C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
|
||||
pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
|
||||
_ -> pure Nothing
|
||||
|
||||
|
||||
Reference in New Issue
Block a user