From 8d81f775b131201d55b16cc0adf07277a9699cc4 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 8 Oct 2026 09:32:11 +0100 Subject: [PATCH] smp protocol: require fixed size corr ID when used as nonce, and min size msg ID to use as nonce (#1925) * smp protocol: require fixed size corr ID when used as nonce, and min size msg ID to use as nonce * simpler * fixes * randomMsgId --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- src/Simplex/FileTransfer/Protocol.hs | 4 +- src/Simplex/Messaging/Agent.hs | 26 +++---- src/Simplex/Messaging/Agent/Client.hs | 6 +- .../Messaging/Agent/Store/AgentStore.hs | 13 ++-- src/Simplex/Messaging/Client.hs | 16 ++--- src/Simplex/Messaging/Crypto.hs | 68 +++++++++++++----- src/Simplex/Messaging/Protocol.hs | 70 ++++++++++++++----- src/Simplex/Messaging/Server.hs | 21 +++--- src/Simplex/Messaging/Server/Env/STM.hs | 5 +- .../Messaging/Server/MsgStore/Postgres.hs | 14 ++-- .../Messaging/Server/QueueStore/Postgres.hs | 4 ++ tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/NotificationTests.hs | 26 +++---- tests/AgentTests/SQLiteTests.hs | 4 +- tests/CoreTests/BatchingTests.hs | 8 +-- tests/CoreTests/MsgStoreTests.hs | 4 +- tests/NtfServerTests.hs | 22 +++--- tests/SMPProxyTests.hs | 16 ++++- tests/ServerTests.hs | 34 ++++----- tests/XFTPWebTests.hs | 34 ++++----- 20 files changed, 243 insertions(+), 154 deletions(-) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 50c84e711..467452775 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -80,7 +80,7 @@ import Simplex.Messaging.Protocol tParse, ) import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..)) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) xftpBlockSize :: Int xftpBlockSize = 16384 @@ -383,7 +383,7 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey t@(corrId, _, _) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams t - xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (C.cbNonce $ bs corrId) tForAuth + xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (eitherToMaybe $ C.cbNonce $ bs corrId) tForAuth xftpEncodeTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString xftpEncodeTransmission thParams t = xftpEncodeBatch1 (Nothing, encodeTransmission thParams t) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 05df98ecc..833815f36 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -3652,7 +3652,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar HELLO -> helloMsg srvMsgId msgMeta conn'' >> ackDel msgId -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command A_MSG body -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) notify $ MSG msgMeta msgFlags body pure ACKPending A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta @@ -3662,7 +3662,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs -- no action needed for QTEST -- any message in the new queue will mark it active and trigger deletion of the old queue - QTEST _ -> logServer "<--" c srv rId ("MSG :" <> logSecret' srvMsgId) >> ackDel msgId + QTEST _ -> logServer "<--" c srv rId ("MSG :" <> logSecret' (SMP.unMsgId srvMsgId)) >> ackDel msgId QEND addrs -> qDuplexAckDel conn'' "QEND" $ qEndMsg srvMsgId addrs EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev where @@ -3697,7 +3697,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar else liftEither (parse smpP (AGENT $ A_MESSAGE "parse msg body 1") agentMsgBody) >>= \case AgentMessage _ (A_MSG body) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) notify $ MSG msgMeta msgFlags body pure ACKPending _ -> ack @@ -3843,7 +3843,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion = do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) checkConfVersions agentVersion phVer let ConnData {pqSupport, serviceRequestExpiresAt} = toConnData conn' case status of @@ -3952,7 +3952,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM () helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) case status of Active -> prohibited "hello: active" _ -> @@ -3976,7 +3976,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar continueSending srvMsgId addr (DuplexConnection _ _ sqs) = case findQ addr sqs of Just sq -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) atomically $ TM.lookup (qAddress sq) (smpDeliveryWorkers c) >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ()) @@ -3985,7 +3985,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) rs <- forM rcpts $ \rcpt -> clientReceipt rcpt `catchAllErrors` \e -> notify (ERR e) $> Nothing case L.nonEmpty . catMaybes $ L.toList rs of Just rs' -> notify (RCVD msgMeta rs') $> ACKPending @@ -4026,7 +4026,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar lockConnForUpdate db connId liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress) + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) <> " " <> logSecret (senderId queueAddress) swchStatus <- if connAgentVersion >= rpcAddressSMPAgentVersion then do @@ -4056,7 +4056,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'} | status' == New || status' == Confirmed -> do checkRQSwchStatus rq RSSendingQADD - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret senderId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) <> " " <> logSecret senderId let dhSecret = C.dh' dhPublicKey dhPrivKey withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer' enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey @@ -4078,7 +4078,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar case find ((replaceQId ==) . dbQId) sqs of Just sq1 -> do checkSQSwchStatus sq1 SSSendingQKEY - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret (snd addr) + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) <> " " <> logSecret (snd addr) withStore' c $ \db -> setSndQueueStatus db sq' Secured let sq'' = (sq' :: SndQueue) {status = Secured} -- sending QTEST to the new queue only, the old one will be removed if sent successfully @@ -4096,7 +4096,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar qEndMsg srvMsgId addrs (DuplexConnection cData'@ConnData {enableNtfs} rqs sqs) = case L.partition (\rq' -> any (`sameQAddress` sndAddress rq') addrs) rqs of (removed@(_ : _), keptRq : keptRqs) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) forM_ removed $ \rq'@RcvQueue {server = rmServer, rcvId} -> do withStore' c $ \db -> setRcvQueueDeleted db rq' enqueueCommand c "" connId (Just rmServer) $ AInternalCommand $ ICDeleteRcvQueue rcvId @@ -4120,7 +4120,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM () smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData (CR.E2ERatchetParamsUri _ k1 k2 kem_)) cInfo = do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) case conn' of ContactConnection _ RcvQueue {sndId} -> do -- show connection request even if invitaion via contact address is not compatible. @@ -4137,7 +4137,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpContactRequest :: SMP.MsgId -> Connection c -> VersionSMPA -> CR.SndE2ERatchetParams 'C.X448 -> RatchetKeyId -> ByteString -> VersionSMPC -> AM () smpContactRequest srvMsgId conn' agentVersion e2eSndParams ratchetKeyId encConnInfo phVer = do - logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' (SMP.unMsgId srvMsgId) case conn' of ContactConnection {} -> do checkConfVersions agentVersion phVer diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 3d8f8c1bd..766298948 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1982,7 +1982,7 @@ decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} = liftEither $ parse SMP.clientRcvMsgBodyP (AGENT $ A_MESSAGE "decrypt message") =<< decrypt body where - decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId) + decrypt = agentCbDecrypt (rcvDhSecret rq) msgId secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM () secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = @@ -2082,7 +2082,7 @@ disableQueuesNtfs c = sendTSessionBatches "NDEL" (mkSMPTSession . snd) disableQu sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = - withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp -> + withSMPClient c NRMBackground rq ("ACK:" <> logSecret' (SMP.unMsgId msgId)) $ \smp -> ackSMPMessage smp rcvPrivateKey rcvId msgId hasGetLock :: SomeRcvQueue q => AgentClient -> q -> IO Bool @@ -2277,7 +2277,7 @@ agentCbEncryptOnce clientVersion dhRcvPubKey msg = do -- | NaCl crypto-box decrypt - both for messages received from the server -- and per-queue E2E encrypted messages from the sender that were inside. -agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> Either AgentErrorType ByteString +agentCbDecrypt :: C.CbNonceI n => C.DhSecretX25519 -> n -> ByteString -> Either AgentErrorType ByteString agentCbDecrypt dhSecret nonce msg = first cryptoError $ C.cbDecrypt dhSecret nonce msg diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 21c087d46..2816d4615 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -1255,7 +1255,7 @@ getLastMsg db connId msgId = LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id WHERE r.conn_id = ? AND r.broker_id = ? |] - (connId, Binary msgId) + (connId, msgId) toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, BoolInt) -> RcvMsg toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, BI userAck)) = @@ -1287,7 +1287,7 @@ checkRcvMsgHashExists db connId hash = getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs) getRcvMsgBrokerTs db connId msgId = firstRow fromOnly (SEMsgNotFound "getRcvMsgBrokerTs") $ - DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId) + DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId) deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO () deleteMsg db connId msgId = @@ -3035,7 +3035,7 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna VALUES (?,?,?,?,?,?,?,?,?,?) |] - (connId, dbQueueId, internalRcvId, fst recipient, sndMsgId, Binary (fst broker), snd broker, Binary internalHash, Binary externalPrevSndHash, integrity) + (connId, dbQueueId, internalRcvId, fst recipient, sndMsgId, fst broker, snd broker, Binary internalHash, Binary externalPrevSndHash, integrity) DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary encryptedMsgHash) updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () @@ -3183,7 +3183,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do - (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays + nonce <- atomically $ C.randomCbNonce gVar + (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId (dummyDst nonce) prefixPath dstPath dstFile Nothing Nothing approvedRelays (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays liftIO $ forM_ redirectChunks $ \fc@FileChunk {replicas} -> do @@ -3191,7 +3192,7 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId pure dstEntityId where - dummyDst = + dummyDst nonce = FileDescription { party = SFRecipient, size, @@ -3199,7 +3200,7 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire redirect = Nothing, -- updated later with updateRcvFileRedirect key = C.unsafeSbKey $ B.replicate 32 '#', - nonce = C.cbNonce "", + nonce, chunkSize = FileSize 0, chunks = [] } diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7a2eedeb9..87b4319e7 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1228,7 +1228,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c -- encode let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command) -- serviceAuth is False here – proxied commands are not used with service certificates - auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey nonce tForAuth + auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey (Just nonce) tForAuth b <- case batchTransmissions serverThParams [Right (auth, tToSend)] of [] -> throwE $ PCETransportError TELargeMsg TBError e _ : _ -> throwE $ PCETransportError e @@ -1262,7 +1262,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c -- receives RRES :: Maybe C.CbNonce -> EncFwdResponse -> BrokerMsg -- proxy should send PRES to the client with EncResponse -- Always uses background timeout mode -forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO (Maybe C.CbNonce, EncResponse) +forwardSMPTransmission :: SMPClient -> C.CorrCbNonce -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO (Maybe C.CbNonce, EncResponse) forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do -- prepare params sessSecret <- case thAuth thParams of @@ -1400,7 +1400,7 @@ mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (entityId, pKey_, command) = do nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_ let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command) - auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ nonce tForAuth + auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ (Just nonce) tForAuth r <- mkRequest (CorrId corrId) pure ((,tToSend) <$> auth, r) where @@ -1419,14 +1419,14 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC atomically $ TM.insert corrId r sentCommands pure r -authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations) -authTransmission thAuth serviceAuth pKey_ nonce t = traverse authenticate pKey_ +authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> Maybe C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations) +authTransmission thAuth serviceAuth pKey_ nonce_ t = traverse authenticate pKey_ where authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations authenticate (C.APrivateAuthKey a pk) = (,serviceSig) <$> case a of - C.SX25519 -> case thAuth of - Just THAuthClient {peerServerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t' - Nothing -> Left TENoServerAuth + C.SX25519 -> case (thAuth, nonce_) of + (Just THAuthClient {peerServerPubKey = k}, Just nonce) -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t' + _ -> Left TENoServerAuth C.SEd25519 -> sign pk C.SEd448 -> sign pk -- When command is signed by both entity key and service key, diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index a22833976..858e040e4 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -140,8 +140,10 @@ module Simplex.Messaging.Crypto gcmIV, -- * NaCl crypto_box - CbNonce (unCbNonce), + CbNonceI (..), + CbNonce, pattern CbNonce, + CorrCbNonce, cbEncrypt, cbEncryptNoPad, cbEncryptMaxLenBS, @@ -152,8 +154,12 @@ module Simplex.Messaging.Crypto sbEncryptNoPad, sbDecryptNoPad, cbNonce, + unsafeCbNonce, + corrCbNonce, randomCbNonce, reverseNonce, + xorNonce, + toCbNonce, -- * NaCl crypto_secretbox SbKey (unSbKey), @@ -232,6 +238,7 @@ import Data.ASN1.Types import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (bimap, first) +import Data.Bits (xor) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA import Data.ByteString.Base64 (decode) @@ -254,7 +261,7 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (. import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll, parseString) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (packZipWith, (<$?>)) -- | Cryptographic algorithms. data Algorithm = Ed25519 | Ed448 | X25519 | X448 @@ -1324,8 +1331,8 @@ sbEncryptNoPad (SbKey key) (CbNonce nonce) = cryptoBox key nonce {-# INLINE sbEncryptNoPad #-} -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce. -cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString -cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS +cbEncryptMaxLenBS :: (KnownNat i, CbNonceI n) => DhSecret X25519 -> n -> MaxLenBS i -> ByteString +cbEncryptMaxLenBS (DhSecretX25519 secret) nonce = cryptoBox secret (unCbNonce nonce) . unMaxLenBS . padMaxLenBS {-# INLINE cbEncryptMaxLenBS #-} cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString @@ -1335,8 +1342,8 @@ cryptoBox secret nonce s = BA.convert tag <> c tag = Poly1305.auth rs c -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. -cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString -cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret +cbDecrypt :: CbNonceI n => DhSecret X25519 -> n -> ByteString -> Either CryptoError ByteString +cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret . toCbNonce {-# INLINE cbDecrypt #-} -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). @@ -1383,9 +1390,16 @@ cbAuthenticate k pk nonce msg = CbAuthenticator $ cbEncryptNoPad (dh' k pk) nonc cbVerify :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> CbAuthenticator -> ByteString -> Bool cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) nonce s == Right (sha512Hash authorized) -newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString} +class CbNonceI n where + unCbNonce :: n -> ByteString + +newtype CbNonce = CryptoBoxNonce ByteString deriving (Eq, Show) - deriving newtype (FromField) + +instance CbNonceI CbNonce where + unCbNonce (CryptoBoxNonce s) = s + +instance FromField CbNonce where fromField = blobFieldDecoder cbNonce instance ToField CbNonce where toField (CryptoBoxNonce s) = toField $ Binary s @@ -1396,7 +1410,7 @@ pattern CbNonce s <- CryptoBoxNonce s instance StrEncoding CbNonce where strEncode (CbNonce s) = strEncode s - strP = cbNonce <$> strP + strP = cbNonce <$?> strP instance ToJSON CbNonce where toJSON = strToJSON @@ -1405,13 +1419,16 @@ instance ToJSON CbNonce where instance FromJSON CbNonce where parseJSON = strParseJSON "CbNonce" -cbNonce :: ByteString -> CbNonce +cbNonce :: ByteString -> Either String CbNonce cbNonce s - | len == 24 = CryptoBoxNonce s - | len > 24 = CryptoBoxNonce . fst $ B.splitAt 24 s - | otherwise = CryptoBoxNonce $ s <> B.replicate (24 - len) (toEnum 0) - where - len = B.length s + | B.length s == 24 = Right $ CryptoBoxNonce s + | otherwise = Left "CbNonce: invalid length" + +unsafeCbNonce :: ByteString -> CbNonce +unsafeCbNonce s = either error id $ cbNonce s + +corrCbNonce :: ByteString -> Either String CorrCbNonce +corrCbNonce s = CorrCbNonce . unCbNonce <$> cbNonce s randomCbNonce :: TVar ChaChaDRG -> STM CbNonce randomCbNonce = fmap CryptoBoxNonce . randomBytes 24 @@ -1419,13 +1436,30 @@ randomCbNonce = fmap CryptoBoxNonce . randomBytes 24 randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n -reverseNonce :: CbNonce -> CbNonce -reverseNonce (CryptoBoxNonce s) = CryptoBoxNonce (B.reverse s) +reverseNonce :: CbNonceI n => n -> CbNonce +reverseNonce = CryptoBoxNonce . B.reverse . unCbNonce + +xorNonce :: CbNonceI n => ByteString -> n -> CbNonce +xorNonce s nonce = CryptoBoxNonce $ packZipWith xor s n <> B.drop (B.length s) n + where + n = unCbNonce nonce + +toCbNonce :: CbNonceI n => n -> CbNonce +toCbNonce = CryptoBoxNonce . unCbNonce instance Encoding CbNonce where smpEncode = unCbNonce smpP = CryptoBoxNonce <$> A.take 24 +newtype CorrCbNonce = CorrCbNonce ByteString + +instance CbNonceI CorrCbNonce where + unCbNonce (CorrCbNonce s) = s + +instance Encoding CorrCbNonce where + smpEncode = smpEncode . unCbNonce + smpP = corrCbNonce <$?> smpP + newtype SbKey = SecretBoxKey {unSbKey :: ByteString} deriving (Eq, Show) deriving newtype (FromField) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index ab0f362f4..fdb2a0209 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -145,7 +145,10 @@ module Simplex.Messaging.Protocol RcvNtfDhSecret, Message (..), RcvMessage (..), - MsgId, + MsgId (unMsgId), + mkMsgId, + unsafeMsgId, + randomMsgId, MsgBody, IdsHash (..), ServiceSub (..), @@ -233,8 +236,10 @@ module Simplex.Messaging.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Concurrent.STM (STM, TVar) import Control.Exception (Exception, SomeException, displayException, fromException) import Control.Monad.Except +import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import qualified Data.Aeson.TH as J @@ -269,7 +274,7 @@ import qualified GHC.TypeLits as TE import qualified GHC.TypeLits as Type import Network.Socket (ServiceName) import qualified Network.TLS as TLS -import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -281,7 +286,7 @@ import Simplex.Messaging.ServiceScheme import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..)) -import Simplex.Messaging.Util (bshow, eitherToMaybe, packZipWith, safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal @@ -703,24 +708,24 @@ instance Encoding NewNtfCreds where newtype EncTransmission = EncTransmission ByteString deriving (Show) -encTransmissionNonce :: VersionSMP -> C.CbNonce -> C.CbNonce -encTransmissionNonce v nonce@(C.CbNonce s) - | v >= fwdNoncesSMPVersion = C.cbNonce $ packZipWith xor (smpEncode v) s <> BS.drop 2 s - | otherwise = nonce +encTransmissionNonce :: C.CbNonceI n => VersionSMP -> n -> C.CbNonce +encTransmissionNonce v nonce + | v >= fwdNoncesSMPVersion = C.xorNonce (smpEncode v) nonce + | otherwise = C.toCbNonce nonce data FwdTransmission = FwdTransmission - { fwdCorrId :: CorrId, + { fwdCorrId :: C.CorrCbNonce, fwdVersion :: VersionSMP, fwdKey :: C.PublicKeyX25519, fwdTransmission :: EncTransmission } instance Encoding FwdTransmission where - smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} = - smpEncode (corrId, fwdVersion, fwdKey, Tail t) + smpEncode FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} = + smpEncode (fwdCorrId, fwdVersion, fwdKey, Tail t) smpP = do - (corrId, fwdVersion, fwdKey, Tail t) <- smpP - pure FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} + (fwdCorrId, fwdVersion, fwdKey, Tail t) <- smpP + pure FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} newtype EncFwdTransmission = EncFwdTransmission ByteString deriving (Show) @@ -766,16 +771,16 @@ newtype EncFwdResponse = EncFwdResponse ByteString deriving (Eq, Show) data FwdResponse = FwdResponse - { fwdCorrId :: CorrId, + { fwdCorrId :: C.CorrCbNonce, fwdResponse :: EncResponse } instance Encoding FwdResponse where - smpEncode FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} = - smpEncode (corrId, Tail t) + smpEncode FwdResponse {fwdCorrId, fwdResponse = EncResponse t} = + smpEncode (fwdCorrId, Tail t) smpP = do - (corrId, Tail t) <- smpP - pure FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} + (fwdCorrId, Tail t) <- smpP + pure FwdResponse {fwdCorrId, fwdResponse = EncResponse t} newtype EncResponse = EncResponse ByteString deriving (Eq, Show) @@ -798,7 +803,7 @@ toMsgInfo = \case Message {msgId, msgTs} -> msgInfo msgId msgTs MTMessage MessageQuota {msgId, msgTs} -> msgInfo msgId msgTs MTQuota where - msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode msgId, msgTs = systemToUTCTime msgTs, msgType} + msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode $ unMsgId msgId, msgTs = systemToUTCTime msgTs, msgType} messageId :: Message -> MsgId messageId = \case @@ -1499,7 +1504,34 @@ type RcvNtfPublicDhKey = C.PublicKeyX25519 type RcvNtfDhSecret = C.DhSecretX25519 -- | SMP message server ID. -type MsgId = ByteString +newtype MsgId = MsgId {unMsgId :: ByteString} + deriving (Eq, Show) + +instance C.CbNonceI MsgId where + unCbNonce (MsgId s) = B.take 24 s + +instance Encoding MsgId where + smpEncode (MsgId s) = smpEncode s + smpP = mkMsgId <$?> smpP + +instance StrEncoding MsgId where + strEncode (MsgId s) = strEncode s + strP = mkMsgId <$?> strP + +instance FromField MsgId where fromField = blobFieldDecoder mkMsgId + +instance ToField MsgId where toField (MsgId s) = toField $ Binary s + +mkMsgId :: ByteString -> Either String MsgId +mkMsgId s + | B.length s >= 24 = Right $ MsgId s + | otherwise = Left "MsgId: invalid length" + +unsafeMsgId :: ByteString -> MsgId +unsafeMsgId s = either error id $ mkMsgId s + +randomMsgId :: Int -> TVar ChaChaDRG -> STM MsgId +randomMsgId n = fmap MsgId . C.randomBytes (max 24 n) -- | SMP message body. type MsgBody = ByteString diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 7dd7817a7..600c9d287 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1334,7 +1334,7 @@ verifyCmdAuthorization thAuth tAuth authorized corrId key = maybe False (verify verifyCmdAuth :: Maybe (THandleAuth 'TServer) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> CorrId -> Bool verifyCmdAuth thAuth k authenticator authorized (CorrId corrId) = case thAuth of - Just THAuthServer {serverPrivKey = pk} -> C.cbVerify k pk (C.cbNonce corrId) authenticator authorized + Just THAuthServer {serverPrivKey = pk} -> either (const False) (\nonce -> C.cbVerify k pk nonce authenticator authorized) $ C.cbNonce corrId Nothing -> False dummyVerifyCmd :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> Bool @@ -1453,14 +1453,15 @@ client ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn liftIO (lookupSMPServerClient a sessId) >>= \case - Just (own, smp) -> do + Just (own, smp) | Right fwdCorrId <- C.corrCbNonce (bs corrId) -> do inc own pRequests forkProxiedCmd $ do - liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `E.catches` clientHandlers) >>= \case + liftIO (runExceptT (forwardSMPTransmission smp fwdCorrId fwdV pubKey encBlock) `E.catches` clientHandlers) >>= \case Right (nonce_, r) -> PRES nonce_ r <$ inc own pSuccesses Left e -> ERR (smpProxyError e) <$ case e of PCEProtocolError {} -> inc own pSuccesses _ -> inc own pErrorsOther + Just _ -> pure $ Just $ ERR $ CMD SYNTAX Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION) where forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg) @@ -1950,7 +1951,7 @@ client getDelivered :: Sub -> STM (Maybe (ServerSub, SystemSeconds)) getDelivered Sub {delivered, subThread} = do readTVar delivered $>>= \(msgId', ts) -> - if msgId == msgId' || B.null msgId + if msgId == msgId' then writeTVar delivered Nothing $> Just (subThread, ts) else pure Nothing updateStats :: ServerStats -> Bool -> SystemSeconds -> Message -> IO () @@ -1996,7 +1997,7 @@ client when (isJust (queueData qr) && isSecuredMsgQueue qr) $ void $ liftIO $ deleteQueueLinkData (queueStore ms) q ServerConfig {messageExpiration, expireMessagesOnSend, msgIdBytes} <- asks config - msgId <- randomId' msgIdBytes + msgId <- atomically . randomMsgId msgIdBytes =<< asks random msg_ <- liftIO $ runExceptT $ do when expireMessagesOnSend $ mapM_ (expireMessages stats) messageExpiration msg <- liftIO $ mkMessage msgId body @@ -2109,7 +2110,7 @@ client liftIO $ storeNtf ns nId ntf incStat . ntfCount =<< asks serverStats - mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M s MsgNtf + mkMessageNotification :: MsgId -> SystemTime -> RcvNtfDhSecret -> M s MsgNtf mkMessageNotification msgId msgTs rcvNtfDhSecret = do ntfNonce <- atomically . C.randomCbNonce =<< asks random let msgMeta = NMsgMeta {msgId, msgTs} @@ -2120,12 +2121,12 @@ client processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams') sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret' - let proxyNonce = C.cbNonce $ bs corrId + proxyNonce <- liftEitherWith (const CRYPTO) $ C.cbNonce $ bs corrId s' <- liftEitherWith (const CRYPTO) $ C.cbDecryptNoPad sessSecret proxyNonce s FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission et} <- liftEitherWith (const $ CMD SYNTAX) $ smpDecode s' unless (fwdVersion `isCompatible` thServerVRange thParams') $ throwE $ transportErr TEVersion let clientSecret = C.dh' fwdKey serverPrivKey - clientNonce = C.cbNonce $ bs fwdCorrId + clientNonce = fwdCorrId b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret (encTransmissionNonce fwdVersion clientNonce) et let clntTHParams = smpTHParamsSetVersion fwdVersion thParams' -- only allowing single forwarded transactions @@ -2187,7 +2188,7 @@ client MessageQuota {} -> RcvMsgQuota msgTs' where encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage - encrypt body = RcvMessage msgId' . EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body + encrypt body = RcvMessage msgId' . EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) msgId' body msgId' = messageId msg msgTs' = messageTs msg @@ -2236,7 +2237,7 @@ client SubPending -> QSubPending SubThread _ -> QSubThread ProhibitSub -> pure QProhibitSub - qDelivered <- decodeLatin1 . encode . fst <$$> readTVarIO delivered + qDelivered <- decodeLatin1 . encode . unMsgId . fst <$$> readTVarIO delivered pure QSub {qSubThread, qDelivered} ok :: Transmission BrokerMsg diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index b4333959f..ca59f75f6 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -571,7 +571,10 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig s -> IO (Env s) -newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig, msgIdBytes} = do + when (msgIdBytes < 24) $ do + logError "Error: msgIdBytes must be at least 24" + exitFailure serverActive <- newTVarIO True server <- newServer msgStore_ <- case serverStoreCfg of diff --git a/src/Simplex/Messaging/Server/MsgStore/Postgres.hs b/src/Simplex/Messaging/Server/MsgStore/Postgres.hs index a79643f08..c8506709c 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Postgres.hs @@ -202,7 +202,7 @@ instance MsgStoreClass PostgresMsgStore where DB.query db "SELECT quota_written, was_empty FROM write_message(?,?,?,?,?,?,?)" - (recipientId' q, Binary (messageId msg), systemSeconds (messageTs msg), msgQuota, ntf, Binary body, quota) + (recipientId' q, messageId msg, systemSeconds (messageTs msg), msgQuota, ntf, Binary body, quota) where toResult = \case ((msgQuota, wasEmpty) : _) -> if msgQuota then Nothing else Just (msg, wasEmpty) @@ -271,14 +271,14 @@ instance MsgStoreClass PostgresMsgStore where uninterruptibleMask_ $ withDB' "tryDelMsg" (queueStore_ ms) $ \db -> maybeFirstRow toMessage $ - DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_msg(?, ?)" (recipientId' q, Binary msgId) + DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_msg(?, ?)" (recipientId' q, msgId) tryDelPeekMsg :: PostgresMsgStore -> PostgresQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) tryDelPeekMsg ms q msgId = uninterruptibleMask_ $ withDB' "tryDelPeekMsg" (queueStore_ ms) $ \db -> toResult . map toMessage - <$> DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_peek_msg(?, ?)" (recipientId' q, Binary msgId) + <$> DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_peek_msg(?, ?)" (recipientId' q, msgId) where toResult = \case [] -> (Nothing, Nothing) @@ -297,13 +297,13 @@ uninterruptibleMask_ :: ExceptT ErrorType IO a -> ExceptT ErrorType IO a uninterruptibleMask_ = ExceptT . E.uninterruptibleMask_ . runExceptT {-# INLINE uninterruptibleMask_ #-} -toMaybeMessage :: (Maybe (Binary MsgId), Maybe Int64, Maybe Bool, Maybe Bool, Maybe (Binary MsgBody)) -> Maybe Message +toMaybeMessage :: (Maybe MsgId, Maybe Int64, Maybe Bool, Maybe Bool, Maybe (Binary MsgBody)) -> Maybe Message toMaybeMessage = \case (Just msgId, Just ts, Just msgQuota, Just ntf, Just body) -> Just $ toMessage (msgId, ts, msgQuota, ntf, body) _ -> Nothing -toMessage :: (Binary MsgId, Int64, Bool, Bool, Binary MsgBody) -> Message -toMessage (Binary msgId, ts, msgQuota, ntf, Binary body) +toMessage :: (MsgId, Int64, Bool, Bool, Binary MsgBody) -> Message +toMessage (msgId, ts, msgQuota, ntf, Binary body) | msgQuota = MessageQuota {msgId, msgTs} | otherwise = Message {msgId, msgTs, msgFlags = MsgFlags ntf, msgBody = C.unsafeMaxLenBS body} -- TODO [messages] unsafeMaxLenBS? where @@ -429,7 +429,7 @@ messageRecToText rId msg = tabFields = BB.char7 ',' `intersperse` fields fields = [ renderField (toField rId), - renderField (toField $ Binary (messageId msg)), + renderField (toField $ messageId msg), renderField (toField $ systemSeconds (messageTs msg)), renderField (toField msgQuota), renderField (toField ntf), diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 72f051fe3..2a879f8cb 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -825,6 +825,10 @@ instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s deriving newtype instance FromField EncDataBytes +instance ToField MsgId where toField = toField . Binary . unMsgId + +instance FromField MsgId where fromField = blobFieldDecoder mkMsgId + deriving newtype instance ToField (RoundedSystemTime t) deriving newtype instance FromField (RoundedSystemTime t) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 0467306f5..1d6f0c121 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -4861,7 +4861,7 @@ testServerQueueInfo = do Just srvMsgId <- checkMsgQ bob aliceId 1 get bob =##> \case ("", c, MSG MsgMeta {integrity = MsgOk, broker = (smId, _), recipient = (mId, _), pqEncryption = PQEncOn} _ "hello") -> - c == aliceId && decodeLatin1 (B64.encode smId) == srvMsgId && mId == msgId + c == aliceId && decodeLatin1 (B64.encode $ SMP.unMsgId smId) == srvMsgId && mId == msgId _ -> False ackMessage bob aliceId msgId Nothing liftIO $ threadDelay 200000 diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index d81c08a41..8e1a85e8a 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -230,7 +230,7 @@ testNotificationToken apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification NTActive <- checkNtfToken a tkn deleteNtfToken a tkn @@ -254,7 +254,7 @@ testNtfTokenRepeatRegistration apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- getMockNotification apns tkn @@ -273,14 +273,14 @@ testNtfTokenSecondRegistration apns = APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification NTRegistered <- registerNtfToken a' tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- getMockNotification apns tkn verification' <- ntfData' .-> "verification" - nonce' <- C.cbNonce <$> ntfData' .-> "nonce" + nonce' <- C.unsafeCbNonce <$> ntfData' .-> "nonce" -- at this point the first token is still active NTActive <- checkNtfToken a tkn @@ -311,7 +311,7 @@ testNtfTokenServerRestart t apns = do -- so that repeat verification happens without restarting the clients, when notification arrives withNtfServer t $ runRight_ $ do verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification NTActive <- checkNtfToken a' tkn pure () @@ -327,7 +327,7 @@ testNtfTokenServerRestartReverify t apns = do pure ntfData runRight_ $ do verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" Left (BROKER _ (NETWORK _)) <- tryE $ verifyNtfToken a tkn nonce verification pure () threadDelay 1500000 @@ -348,7 +348,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification pure (nonce, verification) -- this emulates the situation when server verified token but the client did not receive the response @@ -393,7 +393,7 @@ testNtfTokenServerRestartReregister t apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification NTActive <- checkNtfToken a' tkn pure () @@ -428,7 +428,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification NTActive <- checkNtfToken a' tkn pure () @@ -450,7 +450,7 @@ testNtfTokenMultipleServers t apns = do APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken a tkn nonce verification NTActive <- checkNtfToken a tkn -- shut down the "other" server @@ -566,7 +566,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn verification <- ntfData .-> "verification" - vNonce <- C.cbNonce <$> ntfData .-> "nonce" + vNonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" verifyNtfToken alice tkn vNonce verification NTActive <- checkNtfToken alice tkn -- send message @@ -657,7 +657,7 @@ registerTestToken a token mode apns = do Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- timeout 1000000 $ getMockNotification apns tkn verification' <- ntfData' .-> "verification" - nonce' <- C.cbNonce <$> ntfData' .-> "nonce" + nonce' <- C.unsafeCbNonce <$> ntfData' .-> "nonce" verifyNtfToken a tkn nonce' verification' NTActive <- checkNtfToken a tkn pure tkn @@ -1035,7 +1035,7 @@ messageNotification apns tkn = do 500000 `timeout` getMockNotification apns tkn >>= \case Nothing -> error "no notification" Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do - nonce <- C.cbNonce <$> ntfData .-> "nonce" + nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce" message <- ntfData .-> "message" pure (nonce, message) _ -> error "bad notification" diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index ea0523a09..169d1ad7e 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -513,7 +513,7 @@ hw = encodeUtf8 "Hello world!" ts :: UTCTime ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0) -mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> BrokerId -> MsgHash -> RcvMsgData +mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> ByteString -> MsgHash -> RcvMsgData mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash = RcvMsgData { internalRcvId, @@ -522,7 +522,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash = { integrity = MsgOk, recipient = (unId internalId, ts), sndMsgId = externalSndId, - broker = (brokerId, ts), + broker = (SMP.unsafeMsgId $ mconcat (replicate 24 brokerId), ts), pqEncryption = CR.PQEncOn }, msgType = AM_A_MSG_, diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 960c2113e..efed59f77 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -183,7 +183,7 @@ randomSUB sessId = do thAuth_ <- testTHandleAuth g rKey let thParams = testTHandleParams sessId TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB) - pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) nonce tForAuth + pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) (Just nonce) tForAuth randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd c = do @@ -202,7 +202,7 @@ randomNMSGCmd :: SystemTime -> IO (Transmission BrokerMsg) randomNMSGCmd ts = do g <- C.newRandom nId <- atomically $ C.randomBytes 24 g - msgId <- atomically $ C.randomBytes 24 g + msgId <- atomically $ randomMsgId 24 g (k, pk) <- atomically $ C.generateKeyPair g nonce <- atomically $ C.randomCbNonce g let msgMeta = NMsgMeta {msgId, msgTs = ts} @@ -221,7 +221,7 @@ randomMSG = do g <- C.newRandom corrId <- atomically $ C.randomBytes 24 g rId <- atomically $ C.randomBytes 24 g - msgId <- atomically $ C.randomBytes 24 g + msgId <- atomically $ randomMsgId 24 g msg <- atomically $ C.randomBytes maxMessageLength g pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg}) @@ -235,7 +235,7 @@ randomSEND sessId len = do msg <- atomically $ C.randomBytes len g let thParams = testTHandleParams sessId TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg) - pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) nonce tForAuth + pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) (Just nonce) tForAuth testTHandleParams :: ByteString -> THandleParams SMPVersion 'TClient testTHandleParams sessionId = diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index d4a2d7582..d9a259051 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -34,7 +34,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags) +import Simplex.Messaging.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags, randomMsgId) import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats) import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch) @@ -147,7 +147,7 @@ mkMessage :: MonadIO m => ByteString -> m Message mkMessage body = liftIO $ do g <- C.newRandom msgTs <- getSystemTime - msgId <- atomically $ C.randomBytes 24 g + msgId <- atomically $ randomMsgId 24 g pure Message {msgId, msgTs, msgFlags = noMsgFlags, msgBody = C.unsafeMaxLenBS body} pattern Msg :: ByteString -> Maybe Message diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 7fd430fef..fe19259db 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -136,7 +136,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = let dhSecret = C.dh' ntfDh dhPriv decryptCode nd = let Right verification = nd .-> "verification" - Right nonce = C.cbNonce <$> nd .-> "nonce" + Right nonce = C.cbNonce =<< nd .-> "nonce" Right pt = C.cbDecrypt dhSecret nonce verification in NtfRegCode pt let code = decryptCode ntfData @@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = -- receive notification APNSMockRequest {notification} <- getMockNotification apns tkn let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification - Right nonce' = C.cbNonce <$> ntfData' .-> "nonce" + Right nonce' = C.cbNonce =<< ntfData' .-> "nonce" Right message = ntfData' .-> "message" Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted @@ -171,7 +171,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = notifierId `shouldBe` nId -- receive message Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh - Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body) + Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId1 body) mId1 `shouldBe` msgId mTs `shouldBe` msgTs (msgBody, "hello") #== "delivered from queue" @@ -183,7 +183,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <- getMockNotification apns tkn' let Right verification2 = ntfData2 .-> "verification" - Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce" + Right nonce2 = C.cbNonce =<< ntfData2 .-> "nonce" Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2 RespNtf "8" _ NROk <- signSendRecvNtf nh tknKey ("8", tId, TVFY code2) RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK) @@ -191,7 +191,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2") APNSMockRequest {notification = notification3} <- getMockNotification apns tkn' let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3 - Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce" + Right nonce3 = C.cbNonce =<< ntfData3 .-> "nonce" Right message3 = ntfData3 .-> "message" Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3 Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3 @@ -199,7 +199,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId Resp "" _ (MSG RcvMessage {msgId = mId2, msgBody = EncRcvMsgBody body2}) <- tGet1 rh - Right ClientRcvMsgBody {msgBody = "hello 2"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId2) body2) + Right ClientRcvMsgBody {msgBody = "hello 2"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId2 body2) Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId2) q2 <- createQueue rh sPub nPub @@ -218,7 +218,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = Resp "14" _ OK <- signSendRecv sh sKey ("14", sId, _SEND' "hello 3") APNSMockRequest {notification = notification4} <- getMockNotification apns tkn' let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData4} = notification4 - Right nonce4 = C.cbNonce <$> ntfData4 .-> "nonce" + Right nonce4 = C.cbNonce =<< ntfData4 .-> "nonce" Right message4 = ntfData4 .-> "message" Right ntfDataDecrypted4 = C.cbDecrypt dhSecret nonce4 message4 Right pnMsgs4 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted4 @@ -226,14 +226,14 @@ testNotificationSubscription (ATransport t, msType) createQueue = smpServer4 `shouldBe` srv notifierId4 `shouldBe` nId Resp "" _ (MSG RcvMessage {msgId = mId3, msgBody = EncRcvMsgBody body3}) <- tGet1 rh - Right ClientRcvMsgBody {msgBody = "hello 3"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId3) body3) + Right ClientRcvMsgBody {msgBody = "hello 3"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId3 body3) Resp "15" _ OK <- signSendRecv rh rKey ("15", rId, ACK mId3) -- deliver to queue with ntf sub created while SMP was offline Resp "16" _ OK <- signSendRecv sh sKey ("16", sId', _SEND' "hello 4") APNSMockRequest {notification = notification5} <- getMockNotification apns tkn' let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData5} = notification5 - Right nonce5 = C.cbNonce <$> ntfData5 .-> "nonce" + Right nonce5 = C.cbNonce =<< ntfData5 .-> "nonce" Right message5 = ntfData5 .-> "message" Right ntfDataDecrypted5 = C.cbDecrypt dhSecret nonce5 message5 Right pnMsgs5 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted5 @@ -241,7 +241,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = smpServer5 `shouldBe` srv notifierId5 `shouldBe` nId' Resp "" _ (MSG RcvMessage {msgId = mId4, msgBody = EncRcvMsgBody body4}) <- tGet1 rh - Right ClientRcvMsgBody {msgBody = "hello 4"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret' (C.cbNonce mId4) body4) + Right ClientRcvMsgBody {msgBody = "hello 4"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret' mId4 body4) Resp "17" _ OK <- signSendRecv rh rKey' ("17", rId', ACK mId4) pure () @@ -307,7 +307,7 @@ registerToken nh apns token = do let dhSecret = C.dh' ntfDh dhPriv decryptCode nd = let Right verification = nd .-> "verification" - Right nonce = C.cbNonce <$> nd .-> "nonce" + Right nonce = C.cbNonce =<< nd .-> "nonce" Right pt = C.cbDecrypt dhSecret nonce verification in NtfRegCode pt let code = decryptCode ntfData diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 91bae09a6..134093acc 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -75,6 +75,8 @@ smpProxyTests = do xit "batching proxy requests" todo it "relay rejects forwarded command with changed version" $ \_ -> testChangedFwdVersion + it "proxy rejects forwarded correlation ID that is not 24 bytes" $ \_ -> + testFwdCorrIdSize describe "deliver message via SMP proxy" $ do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost2 testPort2 testKeyHash @@ -472,10 +474,22 @@ testChangedFwdVersion = nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g let v = currentClientSMPRelayVersion et <- either (fail . show) (pure . SMP.EncTransmission) $ C.cbEncrypt (C.dh' peerServerPubKey cmdPrivKey) (SMP.encTransmissionNonce v nonce) "" SMP.paddedProxiedTLength - let forward fwdVersion = forwardSMPTransmission rc (SMP.CorrId corrId) fwdVersion cmdPubKey et + let forward fwdVersion = forwardSMPTransmission rc (either error id $ C.corrCbNonce corrId) fwdVersion cmdPubKey et _ <- runExceptT' $ forward v runExceptT (forward $ prevVersion v) `shouldReturn` Left (PCEProtocolError SMP.CRYPTO) +testFwdCorrIdSize :: IO () +testFwdCorrIdSize = + withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ -> + testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do + (_, _, Right (SMP.PKEY sessId _ _)) <- sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing) + g <- C.newRandom + (cmdPubKey, _) <- atomically $ C.generateKeyPair g + forM_ (["", "2", "3333333333333333333333333"] :: [ByteString]) $ \corrId -> do + (_, _, reply) <- sendRecv th (Nothing, corrId, SMP.EntityId sessId, SMP.PFWD currentClientSMPRelayVersion cmdPubKey (SMP.EncTransmission "")) + reply `shouldBe` Right (SMP.ERR $ SMP.CMD SMP.SYNTAX) + -- Shared "phase 2" of the reconnection tests: start a healthy relay, confirm it is reachable -- directly (PING, not via the proxy) so a proxy failure can only mean the proxy didn't reconnect, -- let any stored connection error expire, then require the proxy to establish the session (PKEY). diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 116b4f0ec..6165dfb46 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -166,7 +166,7 @@ signSend_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t' C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t' - C.SX25519 -> (\THAuthClient {peerServerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t') <$> thAuth params + C.SX25519 -> (\THAuthClient {peerServerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.unsafeCbNonce corrId) t') <$> thAuth params #if !MIN_VERSION_base(4,18,0) _sx448 -> undefined -- ghc8107 fails to the branch excluded by types #endif @@ -194,12 +194,12 @@ _SEND = SEND noMsgFlags _SEND' :: MsgBody -> Command 'Sender _SEND' = SEND MsgFlags {notification = True} -decryptMsgV2 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either C.CryptoError ByteString -decryptMsgV2 dhShared = C.cbDecrypt dhShared . C.cbNonce +decryptMsgV2 :: C.DhSecret 'C.X25519 -> MsgId -> ByteString -> Either C.CryptoError ByteString +decryptMsgV2 = C.cbDecrypt -decryptMsgV3 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either String MsgBody +decryptMsgV3 :: C.DhSecret 'C.X25519 -> MsgId -> ByteString -> Either String MsgBody decryptMsgV3 dhShared nonce body = - case parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body) of + case parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared nonce body) of Right ClientRcvMsgBody {msgBody} -> Right msgBody Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota" Left e -> Left e @@ -425,7 +425,7 @@ testCreateDelete = Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, _SEND "hello") (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" - Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK "") + Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK mId2) (err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted" Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF) @@ -609,7 +609,7 @@ testGetSubCommands = Resp "4" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("4", rId, ACK mId1) (dec mId2 msg2, Right "hello 2") #== "received from queue via SUB" -- bad msgId returns error - Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK "1234") + Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK mId2) -- already ACK'd by subscriber, but still returns OK when msgId matches Resp "5a" _ OK <- signSendRecv rh2 rKey ("5a", rId, ACK mId1) -- msg2 is not lost - even if subscriber does not ACK it, it is delivered to getter @@ -1302,9 +1302,9 @@ testTiming = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub) + Resp "abcdabcdabcdabcdabcdabcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcdabcdabcdabcdabcdabcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv - Resp "cdab" _ resp <- signSendRecv rh rKey ("cdab", rId, SUB) + Resp "cdabcdabcdabcdabcdabcdab" _ resp <- signSendRecv rh rKey ("cdabcdabcdabcdabcdabcdab", rId, SUB) case resp of OK -> pure () SOK Nothing -> pure () @@ -1314,9 +1314,9 @@ testTiming = runTimingTest rh badKey rId SUB (sPub, sKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g - Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) + Resp "dabcdabcdabcdabcdabcdabc" _ OK <- signSendRecv rh rKey ("dabcdabcdabcdabcdabcdabc", rId, KEY sPub) - Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello") + Resp "bcdabcdabcdabcdabcdabcda" _ OK <- signSendRecv sh sKey ("bcdabcdabcdabcdabcdabcda", sId, _SEND "hello") Resp "" _ (Msg mId msg) <- tGet1 rh (dec mId msg, Right "hello") #== "delivered from queue" @@ -1327,15 +1327,15 @@ testTiming = threadDelay 100000 _ <- timeRepeat n $ do -- "warm up" the server - Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd) + Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd) return () threadDelay 100000 timeWrongKey <- timeRepeat n $ do - Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd) + Resp "cdabcdabcdabcdabcdabcdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdabcdabcdabcdabcdabcdab", qId, cmd) return () threadDelay 100000 timeNoQueue <- timeRepeat n $ do - Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd) + Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey msType unless ok . putStrLn . unwords $ @@ -1814,10 +1814,10 @@ serverSyntaxTests (ATransport t) = do it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX) it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY) describe "ACK" $ do - it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH) + it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH) it "no parameters" $ (sampleSig, "abcd", "12345678", ACK_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX) - it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH) - it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH) + it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH) + it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH) describe "PING" $ do it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG) describe "broker response not allowed" $ do diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index b56fbef72..ddb1d1f56 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -768,7 +768,7 @@ tsSecretboxTests :: Spec tsSecretboxTests = describe "crypto/secretbox" $ do let key32 = B.pack [1 .. 32] nonce24 = B.pack [1 .. 24] - cbNonceVal = C.cbNonce nonce24 + cbNonceVal = C.unsafeCbNonce nonce24 sbKeyVal = C.unsafeSbKey key32 describe "NaCl secretbox (tag prepended)" $ do @@ -979,7 +979,7 @@ tsFileCryptoTests :: Spec tsFileCryptoTests = describe "crypto/file" $ do let key32 = B.pack [1 .. 32] nonce24 = B.pack [1 .. 24] - cbNonceVal = C.cbNonce nonce24 + cbNonceVal = C.unsafeCbNonce nonce24 sbKeyVal = C.unsafeSbKey key32 describe "FileHeader encoding" $ do @@ -2329,7 +2329,7 @@ tsClientTests = describe "protocol/client" $ do C.cbAuthenticate (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) - (C.cbNonce nonce24) + (C.unsafeCbNonce nonce24) msg tsResult <- callNode $ @@ -2352,7 +2352,7 @@ tsClientTests = describe "protocol/client" $ do C.cbAuthenticate (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) - (C.cbNonce nonce24) + (C.unsafeCbNonce nonce24) msg B.length expected `shouldBe` 80 @@ -2363,7 +2363,7 @@ tsClientTests = describe "protocol/client" $ do C.cbAuthenticate (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) - (C.cbNonce nonce24) + (C.unsafeCbNonce nonce24) msg tsResult <- callNode $ @@ -2389,7 +2389,7 @@ tsClientTests = describe "protocol/client" $ do C.cbAuthenticate (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) - (C.cbNonce nonce24) + (C.unsafeCbNonce nonce24) msg tsResult <- callNode $ @@ -2427,7 +2427,7 @@ tsClientTests = describe "protocol/client" $ do C.cbVerify (C.PublicKeyX25519 pubB) (C.PrivateKeyX25519 privA) - (C.cbNonce nonce24) + (C.unsafeCbNonce nonce24) (C.CbAuthenticator tsAuth) msg hsValid `shouldBe` True @@ -2438,7 +2438,7 @@ tsClientTests = describe "protocol/client" $ do it "encryptTransportChunk matches Haskell" $ do let plaintext = B.pack [100 .. 199] - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 plaintext tag = BA.convert $ LC.sbAuth state1 :: B.ByteString expected = cipher <> tag @@ -2457,7 +2457,7 @@ tsClientTests = describe "protocol/client" $ do it "decryptTransportChunk decrypts Haskell-encrypted data" $ do let plaintext = B.pack ([200 .. 255] <> [0 .. 99]) - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 plaintext tag = BA.convert $ LC.sbAuth state1 :: B.ByteString encData = cipher <> tag @@ -2542,7 +2542,7 @@ tsDownloadTests = describe "download" $ do -- File-level key/nonce (different from transport) fileKey32 = B.pack [1 .. 32] fileNonce24 = B.pack [1 .. 24] - fileCbNonce = C.cbNonce fileNonce24 + fileCbNonce = C.unsafeCbNonce fileNonce24 fileSbKey = C.unsafeSbKey fileKey32 describe "processFileResponse" $ do @@ -2568,7 +2568,7 @@ tsDownloadTests = describe "download" $ do dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString chunkData = B.pack [50 .. 149] chunkDigest = C.sha256Hash chunkData - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 chunkData tag = BA.convert (LC.sbAuth state1) :: B.ByteString encData = cipher <> tag @@ -2592,7 +2592,7 @@ tsDownloadTests = describe "download" $ do dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString chunkData = B.pack [50 .. 149] wrongDigest = B.replicate 32 0xff - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 chunkData tag = BA.convert (LC.sbAuth state1) :: B.ByteString encData = cipher <> tag @@ -2615,7 +2615,7 @@ tsDownloadTests = describe "download" $ do let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString chunkData = B.pack [10 .. 50] - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 chunkData tag = BA.convert (LC.sbAuth state1) :: B.ByteString encData = cipher <> tag @@ -2652,7 +2652,7 @@ tsDownloadTests = describe "download" $ do -- Step 2: transport-level encryption (simulates server sending chunk) let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString - ts0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + ts0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (transportCipher, ts1) = LC.sbEncryptChunk ts0 fileEncrypted transportTag = BA.convert (LC.sbAuth ts1) :: B.ByteString transportEncData = transportCipher <> transportTag @@ -2702,7 +2702,7 @@ tsDownloadTests = describe "download" $ do dhSecret1 = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) dhSecret1Bytes = case dhSecret1 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString nonce1 = nonce24 - t1s0 = either (error . show) id $ LC.cbInit dhSecret1 (C.cbNonce nonce1) + t1s0 = either (error . show) id $ LC.cbInit dhSecret1 (C.unsafeCbNonce nonce1) (t1cipher, t1s1) = LC.sbEncryptChunk t1s0 fileChunk1 t1tag = BA.convert (LC.sbAuth t1s1) :: B.ByteString transportEnc1 = t1cipher <> t1tag @@ -2710,7 +2710,7 @@ tsDownloadTests = describe "download" $ do nonce2 = B.pack [24 .. 47] dhSecret2 = C.dh' (C.PublicKeyX25519 pubB) (C.PrivateKeyX25519 privA) dhSecret2Bytes = case dhSecret2 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString - t2s0 = either (error . show) id $ LC.cbInit dhSecret2 (C.cbNonce nonce2) + t2s0 = either (error . show) id $ LC.cbInit dhSecret2 (C.unsafeCbNonce nonce2) (t2cipher, t2s1) = LC.sbEncryptChunk t2s0 fileChunk2 t2tag = BA.convert (LC.sbAuth t2s1) :: B.ByteString transportEnc2 = t2cipher <> t2tag @@ -2748,7 +2748,7 @@ tsDownloadTests = describe "download" $ do -- Client side: generate FGET command let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB) chunkData = "FGET round-trip test data" :: B.ByteString - state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24) + state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24) (cipher, state1) = LC.sbEncryptChunk state0 chunkData tag = BA.convert (LC.sbAuth state1) :: B.ByteString encData = cipher <> tag