dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-10-15 23:30:11 +00:00
Code Issues Packages Projects Releases Wiki Activity

test: delivery to client with service certificate

Browse Source
This commit is contained in:
Evgeny Poberezkin
2025-08-15 10:42:28 +01:00
parent 56d9170aae
commit 6092fc45e6
6 changed files with 105 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files
simplexmq.cabal
+1
View File
@@ -543,6 +543,7 @@ test-suite simplexmq-test
, text
, time
, timeit ==2.0.*
, tls >=1.9.0 && <1.10
, transformers
, unliftio
, unliftio-core
src/Simplex/Messaging/Server.hs
+1 -1
View File
@@ -1488,7 +1488,7 @@ client
QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr
Cmd SRecipientService SUBS -> response . (corrId,entId,) <$> case clntServiceId of
Just serviceId -> subscribeServiceMessages serviceId
Nothing -> pure $ ERR INTERNAL
Nothing -> pure $ ERR INTERNAL -- it's "internal" because it should never get to this branch
where
createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds}
src/Simplex/Messaging/Server/QueueStore/STM.hs
+2 -1
View File
@@ -115,7 +115,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
serviceQueuesCount serviceSel = foldM (\n s -> (n +) . S.size <$> readTVarIO (serviceSel s)) 0
addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do
sq <- mkQ rId qr
add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
where
@@ -125,6 +125,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
TM.insert sId rId senders
forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links
mapM_ (addServiceQueue st serviceRcvQueues rId) rcvServiceId
hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink]
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
tests/SMPClient.hs
+23 -5
View File
@@ -15,10 +15,14 @@
module SMPClient where
import Control.Monad
import Control.Monad.Except (runExceptT)
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Network.Socket
import qualified Network.TLS as TLS
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
@@ -33,6 +37,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts)
import Simplex.Messaging.Util (ifM)
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
@@ -151,13 +156,26 @@ testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR vr client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort vr client
testSMPClient_ useHost testPort vr Nothing client
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient_ host port vr client = do
let tcConfig = defaultTransportClientConfig {clientALPN} :: TransportClientConfig
testSMPServiceClient :: Transport c => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPServiceClient serviceCreds client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort supportedClientSMPRelayVRange (Just serviceCreds) client
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> Maybe (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient_ host port vr serviceCreds_ client = do
serviceAndKeys_ <- forM serviceCreds_ $ \(serviceCreds@(cc, pk), keys) -> do
Right serviceSignKey <- pure $ C.x509ToPrivate' pk
let idCert' = case chainIdCaCerts cc of
CCSelf cert -> cert
CCValid {idCert} -> idCert
_ -> error "bad certificate"
serviceCertHash = XV.getFingerprint idCert' X.HashSHA256
pure (ServiceCredentials {serviceRole = SRMessaging, serviceCreds, serviceCertHash, serviceSignKey}, keys)
let tcConfig = defaultTransportClientConfig {clientALPN, clientCredentials = fst <$> serviceCreds_} :: TransportClientConfig
runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h ->
runExceptT (smpClientHandshake h Nothing testKeyHash vr False Nothing) >>= \case
runExceptT (smpClientHandshake h Nothing testKeyHash vr False serviceAndKeys_) >>= \case
Right th -> client th
Left e -> error $ show e
where
tests/SMPProxyTests.hs
+2 -2
View File
@@ -434,14 +434,14 @@ agentViaProxyRetryNoSession = do
testNoProxy :: AStoreType -> IO ()
testNoProxy msType = do
withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing)
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
testProxyAuth :: AStoreType -> IO ()
testProxyAuth msType = do
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong")
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
where
tests/ServerTests.hs
+76 -2
View File
@@ -35,6 +35,7 @@ import Data.String (IsString (..))
import Data.Type.Equality
import qualified Data.X509.Validation as XV
import GHC.Stack (withFrozenCallStack)
import qualified Network.TLS as TLS
import SMPClient
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -49,6 +50,7 @@ import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..)
import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Credentials
import Simplex.Messaging.Util (whenM)
import Simplex.Messaging.Version (mkVersionRange)
import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile)
@@ -78,6 +80,8 @@ serverTests = do
describe "GET & SUB commands" testGetSubCommands
describe "Exceeding queue quota" testExceedQueueQuota
describe "Concurrent sending and delivery" testConcurrentSendDelivery
describe "Service message subscriptions" $ do
testServiceDeliverSubscribe
describe "Store log" testWithStoreLog
describe "Restore messages" testRestoreMessages
describe "Restore messages (old / v2)" testRestoreExpireMessages
@@ -104,6 +108,9 @@ pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing Nothing)
pattern Ids_ :: RecipientId -> SenderId -> RcvPublicDhKey -> ServiceId -> BrokerMsg
pattern Ids_ rId sId srvDh serviceId <- IDS (QIK rId sId srvDh _sndSecure _linkId (Just serviceId) Nothing)
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
@@ -129,10 +136,15 @@ serviceSignSendRecv h pk serviceKey t = do
pure r
signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
signSendRecv_ h pk serviceKey_ t = do
signSend_ h pk serviceKey_ t
liftIO $ tGetClient h
signSend_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO ()
signSend_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (authorize tForAuth, tToSend)
liftIO $ tGetClient h
pure ()
where
authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t'
@@ -653,6 +665,68 @@ testConcurrentSendDelivery =
Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, ACK mId2)
pure ()
testServiceDeliverSubscribe :: SpecWith (ASrvTransport, AStoreType)
testServiceDeliverSubscribe =
it "" $ \(at@(ATransport t), msType) -> do
g <- C.newRandom
creds <- genCredentials g Nothing (0, 2400) "localhost"
let (_fp, tlsCred) = tlsCredentials [creds]
serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g
let aServicePK = C.APrivateAuthKey C.SEd25519 servicePK
withSmpServerConfigOn at (cfgMS msType) testPort $ \_ -> runClient t $ \h -> do
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(rId, sId, dec, serviceId) <- runServiceClient t (tlsCred, serviceKeys) $ \sh -> do
Resp "1" NoEntity (ERR SERVICE) <- signSendRecv sh rKey ("1", NoEntity, New rPub dhPub)
Resp "2" NoEntity (Ids_ rId sId srvDh serviceId) <- serviceSignSendRecv sh rKey servicePK ("2", NoEntity, New rPub dhPub)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
Resp "3" sId' OK <- signSendRecv h sKey ("3", sId, SKEY sPub)
sId' `shouldBe` sId
Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello")
Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 2")
Resp "" rId' (Msg mId1 msg1) <- tGet1 sh
rId' `shouldBe` rId
dec mId1 msg1 `shouldBe` Right "hello"
-- ACK doesn't need service signature
Resp "6" _ (Msg mId2 msg2) <- signSendRecv sh rKey ("6", rId, ACK mId1)
dec mId2 msg2 `shouldBe` Right "hello 2"
Resp "7" _ (ERR NO_MSG) <- signSendRecv sh rKey ("7", rId, ACK mId1)
Resp "8" _ OK <- signSendRecv sh rKey ("8", rId, ACK mId2)
Resp "9" _ OK <- signSendRecv h sKey ("9", sId, _SEND "hello 3")
pure (rId, sId, dec, serviceId)
runServiceClient t (tlsCred, serviceKeys) $ \sh -> do
Resp "10" NoEntity (ERR (CMD NO_AUTH)) <- signSendRecv sh aServicePK ("10", NoEntity, SUBS)
mId3 <- signSendRecv sh aServicePK ("11", serviceId, SUBS) >>= \case -- possible race between SOKS response and MSG
Resp "11" serviceId' (SOKS n) -> do
n `shouldBe` 1
serviceId' `shouldBe` serviceId
Resp "" rId'' (Msg mId3 msg3) <- tGet1 sh
rId'' `shouldBe` rId
dec mId3 msg3 `shouldBe` Right "hello 3"
pure mId3
Resp "" rId'' (Msg mId3 msg3) -> do
rId'' `shouldBe` rId
dec mId3 msg3 `shouldBe` Right "hello 3"
Resp "11" serviceId' (SOKS n) <- tGet1 sh
n `shouldBe` 1
serviceId' `shouldBe` serviceId
pure mId3
r -> error $ "unexpected response " <> take 100 (show r)
Resp "12" _ OK <- signSendRecv sh rKey ("12", rId, ACK mId3)
Resp "14" _ OK <- signSendRecv h sKey ("14", sId, _SEND "hello 4")
Resp "" _ (Msg mId4 msg4) <- tGet1 sh
dec mId4 msg4 `shouldBe` Right "hello 4"
Resp "15" _ OK <- signSendRecv sh rKey ("15", rId, ACK mId4)
pure ()
where
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
runClient _ test' = testSMPClient test'
runServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
runServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test'
testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
testWithStoreLog =
it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do