diff --git a/simplexmq.cabal b/simplexmq.cabal index 5f3d96304..50ab6f282 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -543,6 +543,7 @@ test-suite simplexmq-test , text , time , timeit ==2.0.* + , tls >=1.9.0 && <1.10 , transformers , unliftio , unliftio-core diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 63f43eca8..33509e103 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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} diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index c444f33f9..450d99305 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -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 diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2b18a2d51..b24693b98 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -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 diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 5f1a59fd0..da48ba01a 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -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 diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 407b9f182..3c11ad010 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -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