mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-22 13:12:01 +00:00
Merge remote-tracking branch 'origin/master' into sh/fix-proxy-leak
# Conflicts: # tests/SMPClient.hs
This commit is contained in:
commit
b3ef8fda7e
85 files changed
+4612
-846
No files matched your search
@@ -568,9 +568,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
|
||||
notify c sndFileEntityId $ SFPROG uploaded total
|
||||
when complete $ do
|
||||
(sndDescr, rcvDescrs) <- sndFileToDescrs sf
|
||||
flip catchAllErrors (\e -> logError $ "XFTP snd worker error: " <> tshow e) $ do
|
||||
lift . forM_ prefixPath $ removePath <=< toFSFilePath
|
||||
withStore' c $ \db -> updateSndFileComplete db sndFileId
|
||||
notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks)
|
||||
lift . forM_ prefixPath $ removePath <=< toFSFilePath
|
||||
withStore' c $ \db -> updateSndFileComplete db sndFileId
|
||||
where
|
||||
addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
|
||||
addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {sndChunkReplicaId, rcvIdsKeys}
|
||||
|
||||
@@ -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)
|
||||
|
||||
+395
-279
File diff suppressed because it is too large.
Load diff
@@ -312,7 +312,7 @@ import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.SystemTime
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion)
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), newNtfCredsSMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Credentials
|
||||
import Simplex.Messaging.Util
|
||||
@@ -1261,9 +1261,12 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn
|
||||
Left e -> throwE e
|
||||
|
||||
ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
|
||||
ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _) = do
|
||||
isJust socksProxy || (hostMode == HMOnion && any isOnionHost hosts)
|
||||
ipAddressProtected NetworkConfig {socksProxy, socksMode, hostMode} (ProtocolServer _ hosts _ _)
|
||||
| isJust socksProxy = socksMode == SMAlways || if hostMode == HMPublic then allOnion else anyOnion
|
||||
| otherwise = hostMode == HMOnion && anyOnion
|
||||
where
|
||||
anyOnion = any isOnionHost hosts
|
||||
allOnion = all isOnionHost hosts
|
||||
isOnionHost = \case THOnionHost _ -> True; _ -> False
|
||||
|
||||
withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
|
||||
@@ -1496,7 +1499,7 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
|
||||
let sessServiceId = (\THClientService {serviceId = sId} -> sId) <$> (clientService =<< thAuth thParams')
|
||||
when (isJust serviceId && serviceId /= sessServiceId) $ logError "incorrect service ID in NEW response"
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
shortLink <- mkShortLinkCreds thParams' qik
|
||||
shortLink <- mkShortLinkCreds qik
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ userId,
|
||||
@@ -1537,8 +1540,8 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
|
||||
(Just ((ntfPublicKey, ntfPrivateKey), dhpk), Just (ServerNtfCreds notifierId dhk')) ->
|
||||
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret = C.dh' dhk' dhpk}
|
||||
_ -> Nothing
|
||||
mkShortLinkCreds :: THandleParams SMPVersion 'TClient -> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds thParams' QIK {sndId, queueMode, linkId} = case (cqrd, queueMode) of
|
||||
mkShortLinkCreds :: QueueIdsKeys -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds QIK {sndId, queueMode, linkId} = case (cqrd, queueMode) of
|
||||
(CQRMessaging ld, Just QMMessaging) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
|
||||
if sndId == sndId'
|
||||
@@ -1552,11 +1555,9 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
|
||||
(_, Nothing) -> newErr "unexpected link ID"
|
||||
_ -> newErr "unexpected queue mode"
|
||||
where
|
||||
v = thVersion thParams'
|
||||
withLinkData :: Maybe d -> (SMP.LinkId -> d -> AM (Maybe ShortLinkCreds)) -> AM (Maybe ShortLinkCreds)
|
||||
withLinkData ld_ mkLink = case (ld_, linkId) of
|
||||
(Just ld, Just lnkId) -> mkLink lnkId ld
|
||||
(Just _, Nothing) | v < shortLinksSMPVersion -> pure Nothing
|
||||
(Nothing, Nothing) -> pure Nothing
|
||||
_ -> newErr "unexpected or absent link ID"
|
||||
newErr :: String -> AM (Maybe ShortLinkCreds)
|
||||
@@ -1981,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 =
|
||||
@@ -2079,9 +2080,9 @@ disableQueuesNtfs c = sendTSessionBatches "NDEL" (mkSMPTSession . snd) disableQu
|
||||
queueCreds :: DisableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey)
|
||||
queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvId, rcvPrivateKey)
|
||||
|
||||
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
|
||||
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM QueueDrained
|
||||
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
|
||||
@@ -2276,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
|
||||
|
||||
@@ -79,6 +79,7 @@ module Simplex.Messaging.Agent.Protocol
|
||||
SMPConfirmation (..),
|
||||
AgentMsgEnvelope (..),
|
||||
AgentMessage (..),
|
||||
RatchetInfo (..),
|
||||
RequestSignature (..),
|
||||
AgentMessageType (..),
|
||||
APrivHeader (..),
|
||||
@@ -245,7 +246,6 @@ import Simplex.Messaging.Crypto.Ratchet
|
||||
RcvE2ERatchetParams,
|
||||
RcvE2ERatchetParamsUri,
|
||||
SndE2ERatchetParams,
|
||||
RcvE2EPrivRatchetParams,
|
||||
pattern PQSupportOff,
|
||||
pattern PQSupportOn,
|
||||
)
|
||||
@@ -611,6 +611,7 @@ data RcvSwitchStatus
|
||||
| RSSendingQADD
|
||||
| RSSendingQUSE
|
||||
| RSReceivedMessage
|
||||
| RSReceivedQEND
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding RcvSwitchStatus where
|
||||
@@ -619,12 +620,14 @@ instance StrEncoding RcvSwitchStatus where
|
||||
RSSendingQADD -> "sending_qadd"
|
||||
RSSendingQUSE -> "sending_quse"
|
||||
RSReceivedMessage -> "received_message"
|
||||
RSReceivedQEND -> "received_qend"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"switch_started" -> pure RSSwitchStarted
|
||||
"sending_qadd" -> pure RSSendingQADD
|
||||
"sending_quse" -> pure RSSendingQUSE
|
||||
"received_message" -> pure RSReceivedMessage
|
||||
"received_qend" -> pure RSReceivedQEND
|
||||
_ -> fail "bad RcvSwitchStatus"
|
||||
|
||||
instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode
|
||||
@@ -928,7 +931,7 @@ data AgentMessage
|
||||
| -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
|
||||
-- It made removed REPLY message unnecessary.
|
||||
AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
|
||||
| AgentRatchetInfo ByteString
|
||||
| AgentRatchetInfo RatchetInfo
|
||||
| AgentMessage APrivHeader AMessage
|
||||
| AgentServiceRequest (NonEmpty SMPQueueInfo) (Maybe RequestSignature) MsgBody
|
||||
| AgentServiceResponse MsgBody
|
||||
@@ -939,7 +942,7 @@ instance Encoding AgentMessage where
|
||||
smpEncode = \case
|
||||
AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
|
||||
AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
|
||||
AgentRatchetInfo info -> smpEncode ('R', Tail info)
|
||||
AgentRatchetInfo info -> smpEncode ('R', info)
|
||||
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
|
||||
AgentServiceRequest qs sig_ body -> smpEncode ('A', qs, sig_, Tail body)
|
||||
AgentServiceResponse body -> smpEncode ('P', Tail body)
|
||||
@@ -948,13 +951,23 @@ instance Encoding AgentMessage where
|
||||
smpP >>= \case
|
||||
'I' -> AgentConnInfo . unTail <$> smpP
|
||||
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
|
||||
'R' -> AgentRatchetInfo . unTail <$> smpP
|
||||
'R' -> AgentRatchetInfo <$> smpP
|
||||
'M' -> AgentMessage <$> smpP <*> smpP
|
||||
'A' -> AgentServiceRequest <$> smpP <*> smpP <*> (unTail <$> smpP)
|
||||
'P' -> AgentServiceResponse . unTail <$> smpP
|
||||
'J' -> AgentRejection . unTail <$> smpP
|
||||
_ -> fail "bad AgentMessage"
|
||||
|
||||
data RatchetInfo = RatchetInfo {answeredKeyHash :: Maybe ByteString}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding RatchetInfo where
|
||||
smpEncode RatchetInfo {answeredKeyHash} = smpEncode answeredKeyHash
|
||||
smpP = do
|
||||
answeredKeyHash <- smpP <|> pure Nothing
|
||||
_ <- A.takeByteString
|
||||
pure RatchetInfo {answeredKeyHash}
|
||||
|
||||
-- internal type for storing message type in the database
|
||||
data AgentMessageType
|
||||
= AM_CONN_INFO
|
||||
@@ -1613,7 +1626,7 @@ newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
|
||||
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
|
||||
|
||||
-- | Parameters for creating a connection with a prepared link.
|
||||
data PreparedLinkParams = PreparedLinkParams
|
||||
data PreparedLinkParams k = PreparedLinkParams
|
||||
{ -- | Correlation ID / determines sender ID
|
||||
plpNonce :: C.CbNonce,
|
||||
-- | Queue E2EE DH key pair
|
||||
@@ -1628,8 +1641,8 @@ data PreparedLinkParams = PreparedLinkParams
|
||||
plpSrvWithAuth :: SMPServerWithAuth,
|
||||
-- | Initial PQ keys
|
||||
plpInitKeys :: InitialKeys,
|
||||
-- | Contact address double ratchet keys
|
||||
plpAddressKeys :: Maybe (RatchetKeyId, RcvE2EPrivRatchetParams 'C.X448)
|
||||
-- | Contact address double ratchet keys or invitation X3DH keys
|
||||
plpRatchetKeys :: k
|
||||
}
|
||||
|
||||
instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode
|
||||
|
||||
@@ -219,6 +219,7 @@ canAbortRcvSwitch ConnData {connAgentVersion} = maybe False canAbort . rcvSwchSt
|
||||
-- if switch is in RSReceivedMessage status, aborting switch (deleting new queue)
|
||||
-- will break the connection because the sender would have original queue deleted
|
||||
RSReceivedMessage -> False
|
||||
RSReceivedQEND -> False
|
||||
|
||||
data ClientNtfCreds = ClientNtfCreds
|
||||
{ -- | key pair to be used by the notification server to authorize transmissions
|
||||
|
||||
@@ -76,6 +76,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
getExpiredServiceConns,
|
||||
deleteExpiredServiceRequests,
|
||||
getDeletedWaitingDeliveryConnIds,
|
||||
getConnRatchetSync,
|
||||
setConnRatchetSync,
|
||||
addProcessedRatchetKeyHash,
|
||||
checkRatchetKeyHashExists,
|
||||
@@ -99,6 +100,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
setSndQueuePrimary,
|
||||
deleteConnRcvQueue,
|
||||
incRcvDeleteErrors,
|
||||
getEndedRcvQueueConnIds,
|
||||
deleteConnSndQueue,
|
||||
getPrimaryRcvQueue,
|
||||
getRcvQueue,
|
||||
@@ -762,6 +764,10 @@ incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO ()
|
||||
incRcvDeleteErrors db RcvQueue {connId, dbQueueId} =
|
||||
DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
|
||||
|
||||
getEndedRcvQueueConnIds :: DB.Connection -> IO [ConnId]
|
||||
getEndedRcvQueueConnIds db =
|
||||
map fromOnly <$> DB.query db "SELECT conn_id FROM rcv_queues WHERE switch_status = ? AND deleted = 0" (Only RSReceivedQEND)
|
||||
|
||||
deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO ()
|
||||
deleteConnRcvQueue db RcvQueue {connId, dbQueueId} =
|
||||
DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
|
||||
@@ -1254,7 +1260,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)) =
|
||||
@@ -1286,7 +1292,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 =
|
||||
@@ -1594,12 +1600,16 @@ getRatchet_ q db connId =
|
||||
where
|
||||
ratchet = maybe (Left SERatchetNotFound) Right . fromOnly
|
||||
|
||||
getSkippedMsgKeys :: DB.Connection -> ConnId -> IO SkippedMsgKeys
|
||||
getSkippedMsgKeys db connId =
|
||||
skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)
|
||||
getSkippedMsgKeys :: DB.Connection -> ConnId -> Int -> IO SkippedMsgKeys
|
||||
getSkippedMsgKeys db connId maxKeys = do
|
||||
(keys, oldKeys) <- splitAt maxKeys <$> DB.query db "SELECT skipped_message_id, header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ? ORDER BY skipped_message_id DESC LIMIT ?" (connId, maxKeys + 1)
|
||||
case oldKeys of
|
||||
(skippedMsgId :: Int64, _, _, _) : _ -> DB.execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND skipped_message_id <= ?" (connId, skippedMsgId)
|
||||
[] -> pure ()
|
||||
pure $ skipped keys
|
||||
where
|
||||
skipped = foldl' addSkippedKey M.empty
|
||||
addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
|
||||
addSkippedKey smks (_, hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
|
||||
where
|
||||
addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk)
|
||||
|
||||
@@ -2793,6 +2803,11 @@ getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId]
|
||||
getDeletedWaitingDeliveryConnIds db =
|
||||
map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL"
|
||||
|
||||
getConnRatchetSync :: DB.Connection -> ConnId -> IO (Either StoreError RatchetSyncState)
|
||||
getConnRatchetSync db connId =
|
||||
firstRow fromOnly SEConnNotFound $
|
||||
DB.query db "SELECT ratchet_sync_state FROM connections WHERE conn_id = ?" (Only connId)
|
||||
|
||||
setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
|
||||
setConnRatchetSync db connId ratchetSyncState =
|
||||
DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
|
||||
@@ -2814,21 +2829,35 @@ checkRatchetKeyHashExists db connId hash =
|
||||
(connId, Binary hash)
|
||||
|
||||
deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> Int -> IO ()
|
||||
deleteRatchetKeyHashesExpired db ttl limit = do
|
||||
deleteRatchetKeyHashesExpired db ttl maxConnHashes = do
|
||||
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
|
||||
#if defined(dbPostgres)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM processed_ratchet_key_hashes
|
||||
WHERE processed_ratchet_key_hash_id IN (
|
||||
SELECT processed_ratchet_key_hash_id
|
||||
FROM processed_ratchet_key_hashes
|
||||
WHERE created_at < ?
|
||||
ORDER BY created_at ASC
|
||||
LIMIT ?
|
||||
)
|
||||
|]
|
||||
(cutoffTs, limit)
|
||||
("DELETE FROM processed_ratchet_key_hashes h USING (" <> maxExcessIdsQuery <> ") e WHERE h.conn_id = e.conn_id AND h.processed_ratchet_key_hash_id <= e.max_excess_id AND h.created_at < ?")
|
||||
(maxConnHashes, maxConnHashes, cutoffTs)
|
||||
#else
|
||||
maxExcessIds <- DB.query db maxExcessIdsQuery (maxConnHashes, maxConnHashes)
|
||||
DB.executeMany
|
||||
db
|
||||
"DELETE FROM processed_ratchet_key_hashes WHERE conn_id = ? AND processed_ratchet_key_hash_id <= ? AND created_at < ?"
|
||||
(map (\(connId :: ConnId, maxExcessId :: Int64) -> (connId, maxExcessId, cutoffTs)) maxExcessIds)
|
||||
#endif
|
||||
where
|
||||
maxExcessIdsQuery :: Query
|
||||
maxExcessIdsQuery =
|
||||
[sql|
|
||||
SELECT conn_id, (
|
||||
SELECT processed_ratchet_key_hash_id
|
||||
FROM processed_ratchet_key_hashes
|
||||
WHERE conn_id = c.conn_id
|
||||
ORDER BY processed_ratchet_key_hash_id DESC
|
||||
LIMIT 1 OFFSET ?
|
||||
) AS max_excess_id
|
||||
FROM processed_ratchet_key_hashes c
|
||||
GROUP BY conn_id
|
||||
HAVING COUNT(*) > ?
|
||||
|]
|
||||
|
||||
-- | returns all connection queues, the first queue is the primary one
|
||||
getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
|
||||
@@ -3011,7 +3040,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 ()
|
||||
@@ -3159,7 +3188,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
|
||||
@@ -3167,7 +3197,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,
|
||||
@@ -3175,7 +3205,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 = []
|
||||
}
|
||||
|
||||
@@ -16,6 +16,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260929_ratchet_indexes
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20261008_rcv_switch_status
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
@@ -31,7 +33,9 @@ schemaMigrations =
|
||||
("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
|
||||
("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
|
||||
("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
|
||||
("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
|
||||
("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes),
|
||||
("20260929_ratchet_indexes", m20260929_ratchet_indexes, Just down_m20260929_ratchet_indexes),
|
||||
("20261008_rcv_switch_status", m20261008_rcv_switch_status, Just down_m20261008_rcv_switch_status)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,34 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260929_ratchet_indexes where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20260929_ratchet_indexes :: Text
|
||||
m20260929_ratchet_indexes =
|
||||
[r|
|
||||
DROP INDEX idx_skipped_messages_conn_id;
|
||||
CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id, skipped_message_id);
|
||||
|
||||
DELETE FROM processed_ratchet_key_hashes AS h
|
||||
WHERE EXISTS (
|
||||
SELECT 1 FROM processed_ratchet_key_hashes d
|
||||
WHERE d.conn_id = h.conn_id AND d.hash = h.hash AND d.processed_ratchet_key_hash_id < h.processed_ratchet_key_hash_id
|
||||
);
|
||||
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_hash;
|
||||
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(conn_id, processed_ratchet_key_hash_id);
|
||||
|]
|
||||
|
||||
down_m20260929_ratchet_indexes :: Text
|
||||
down_m20260929_ratchet_indexes =
|
||||
[r|
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_conn_id;
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_hash;
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|
||||
DROP INDEX idx_skipped_messages_conn_id;
|
||||
CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
|
||||
|]
|
||||
@@ -0,0 +1,20 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20261008_rcv_switch_status where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20261008_rcv_switch_status :: Text
|
||||
m20261008_rcv_switch_status =
|
||||
[r|
|
||||
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
|
||||
|]
|
||||
|
||||
down_m20261008_rcv_switch_status :: Text
|
||||
down_m20261008_rcv_switch_status =
|
||||
[r|
|
||||
UPDATE rcv_queues SET switch_status = NULL WHERE switch_status = 'received_qend';
|
||||
DROP INDEX idx_rcv_queues_switch_status;
|
||||
|]
|
||||
@@ -1169,11 +1169,15 @@ CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON smp_agent_test_protocol_schema.
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, processed_ratchet_key_hash_id);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (created_at);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, hash);
|
||||
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, hash);
|
||||
|
||||
|
||||
|
||||
@@ -1229,6 +1233,10 @@ CREATE UNIQUE INDEX idx_rcv_queues_ntf ON smp_agent_test_protocol_schema.rcv_que
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_rcv_queues_switch_status ON smp_agent_test_protocol_schema.rcv_queues USING btree (switch_status);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_rcv_queues_to_subscribe ON smp_agent_test_protocol_schema.rcv_queues USING btree (to_subscribe);
|
||||
|
||||
|
||||
@@ -1241,7 +1249,7 @@ CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON smp_agent_test_protoco
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_skipped_messages_conn_id ON smp_agent_test_protocol_schema.skipped_messages USING btree (conn_id);
|
||||
CREATE INDEX idx_skipped_messages_conn_id ON smp_agent_test_protocol_schema.skipped_messages USING btree (conn_id, skipped_message_id);
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -100,7 +100,8 @@ withTransaction st = withTransactionPriority st False
|
||||
{-# INLINE withTransaction #-}
|
||||
|
||||
withTransactionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a
|
||||
withTransactionPriority st priority action = withConnectionPriority st priority $ dbBusyLoop . transaction
|
||||
withTransactionPriority st@DBStore {dbClosed} priority action = withConnectionPriority st priority $ \db ->
|
||||
ifM (readTVarIO dbClosed) (fail "withTransaction: database closed") (dbBusyLoop $ transaction db)
|
||||
where
|
||||
transaction db@DB.Connection {conn} = SQL.withImmediateTransaction conn $ action db
|
||||
|
||||
|
||||
@@ -52,6 +52,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260929_ratchet_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261005_commands_autoincrement
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261008_rcv_switch_status
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -103,7 +106,10 @@ schemaMigrations =
|
||||
("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
|
||||
("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
|
||||
("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
|
||||
("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
|
||||
("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes),
|
||||
("m20260929_ratchet_indexes", m20260929_ratchet_indexes, Just down_m20260929_ratchet_indexes),
|
||||
("m20261005_commands_autoincrement", m20261005_commands_autoincrement, Just down_m20261005_commands_autoincrement),
|
||||
("m20261008_rcv_switch_status", m20261008_rcv_switch_status, Just down_m20261008_rcv_switch_status)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260929_ratchet_indexes where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
-- idx_skipped_messages_conn_id is not changed: SQLite index entries include rowid (skipped_message_id)
|
||||
m20260929_ratchet_indexes :: Query
|
||||
m20260929_ratchet_indexes =
|
||||
[sql|
|
||||
DELETE FROM processed_ratchet_key_hashes AS h
|
||||
WHERE EXISTS (
|
||||
SELECT 1 FROM processed_ratchet_key_hashes d
|
||||
WHERE d.conn_id = h.conn_id AND d.hash = h.hash AND d.processed_ratchet_key_hash_id < h.processed_ratchet_key_hash_id
|
||||
);
|
||||
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_hash;
|
||||
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(conn_id, processed_ratchet_key_hash_id);
|
||||
|]
|
||||
|
||||
down_m20260929_ratchet_indexes :: Query
|
||||
down_m20260929_ratchet_indexes =
|
||||
[sql|
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_conn_id;
|
||||
DROP INDEX idx_processed_ratchet_key_hashes_hash;
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|
||||
|]
|
||||
+33
@@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261005_commands_autoincrement where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20261005_commands_autoincrement :: Query
|
||||
m20261005_commands_autoincrement =
|
||||
[sql|
|
||||
INSERT INTO sqlite_sequence (name, seq)
|
||||
SELECT 'commands', MAX(ROWID) FROM commands;
|
||||
|
||||
PRAGMA writable_schema=1;
|
||||
|
||||
UPDATE sqlite_master SET sql = replace(sql, 'command_id INTEGER PRIMARY KEY,', 'command_id INTEGER PRIMARY KEY AUTOINCREMENT,')
|
||||
WHERE name = 'commands' AND type = 'table';
|
||||
|
||||
PRAGMA writable_schema=RESET;
|
||||
|]
|
||||
|
||||
down_m20261005_commands_autoincrement :: Query
|
||||
down_m20261005_commands_autoincrement =
|
||||
[sql|
|
||||
DELETE FROM sqlite_sequence WHERE name = 'commands';
|
||||
|
||||
PRAGMA writable_schema=1;
|
||||
|
||||
UPDATE sqlite_master SET sql = replace(sql, 'command_id INTEGER PRIMARY KEY AUTOINCREMENT,', 'command_id INTEGER PRIMARY KEY,')
|
||||
WHERE name = 'commands' AND type = 'table';
|
||||
|
||||
PRAGMA writable_schema=RESET;
|
||||
|]
|
||||
@@ -0,0 +1,19 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261008_rcv_switch_status where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20261008_rcv_switch_status :: Query
|
||||
m20261008_rcv_switch_status =
|
||||
[sql|
|
||||
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
|
||||
|]
|
||||
|
||||
down_m20261008_rcv_switch_status :: Query
|
||||
down_m20261008_rcv_switch_status =
|
||||
[sql|
|
||||
UPDATE rcv_queues SET switch_status = NULL WHERE switch_status = 'received_qend';
|
||||
DROP INDEX idx_rcv_queues_switch_status;
|
||||
|]
|
||||
@@ -247,7 +247,7 @@ CREATE TABLE ntf_subscriptions(
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
) WITHOUT ROWID, STRICT;
|
||||
CREATE TABLE commands(
|
||||
command_id INTEGER PRIMARY KEY,
|
||||
command_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
host TEXT,
|
||||
port TEXT,
|
||||
@@ -261,6 +261,7 @@ CREATE TABLE commands(
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
) STRICT;
|
||||
CREATE TABLE sqlite_sequence(name,seq);
|
||||
CREATE TABLE snd_message_deliveries(
|
||||
snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
@@ -269,7 +270,6 @@ CREATE TABLE snd_message_deliveries(
|
||||
failed INTEGER DEFAULT 0,
|
||||
FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
|
||||
) STRICT;
|
||||
CREATE TABLE sqlite_sequence(name,seq);
|
||||
CREATE TABLE users(
|
||||
user_id INTEGER PRIMARY KEY AUTOINCREMENT
|
||||
,
|
||||
@@ -573,10 +573,6 @@ CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hash
|
||||
conn_id,
|
||||
hash
|
||||
);
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
|
||||
conn_id,
|
||||
hash
|
||||
);
|
||||
CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(
|
||||
conn_id,
|
||||
rcpt_internal_id
|
||||
@@ -641,6 +637,15 @@ CREATE INDEX idx_connections_deleted ON connections(deleted);
|
||||
CREATE INDEX idx_connections_service_request_expires_at ON connections(
|
||||
service_request_expires_at
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
|
||||
conn_id,
|
||||
hash
|
||||
);
|
||||
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(
|
||||
conn_id,
|
||||
processed_ratchet_key_hash_id
|
||||
);
|
||||
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
|
||||
CREATE TRIGGER tr_rcv_queue_insert
|
||||
AFTER INSERT ON rcv_queues
|
||||
FOR EACH ROW
|
||||
|
||||
@@ -69,6 +69,7 @@ module Simplex.Messaging.Client
|
||||
enableSMPQueuesNtfs,
|
||||
disableSMPQueuesNtfs,
|
||||
sendSMPMessage,
|
||||
QueueDrained,
|
||||
ackSMPMessage,
|
||||
suspendSMPQueue,
|
||||
deleteSMPQueue,
|
||||
@@ -198,6 +199,7 @@ data PClient v err msg = PClient
|
||||
transportHost :: TransportHost,
|
||||
tcpConnectTimeout :: NetworkTimeout,
|
||||
tcpTimeout :: NetworkTimeout,
|
||||
proxiedRelayVRange :: VersionRange v,
|
||||
sendPings :: TVar Bool,
|
||||
lastReceived :: TVar UTCTime,
|
||||
timeoutErrorCount :: TVar Int,
|
||||
@@ -243,6 +245,7 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
transportHost = "localhost",
|
||||
tcpConnectTimeout,
|
||||
tcpTimeout,
|
||||
proxiedRelayVRange = supportedClientSMPRelayVRange,
|
||||
sendPings,
|
||||
lastReceived,
|
||||
timeoutErrorCount,
|
||||
@@ -480,6 +483,7 @@ data ProtocolClientConfig v = ProtocolClientConfig
|
||||
serviceCredentials :: Maybe ServiceCredentials,
|
||||
-- | client-server protocol version range
|
||||
serverVRange :: VersionRange v,
|
||||
proxiedRelayVRange :: VersionRange v,
|
||||
-- | agree shared session secret (used in SMP proxy for additional encryption layer)
|
||||
agreeSecret :: Bool,
|
||||
-- | Whether connecting client is a proxy server. See comment in ClientHandshake
|
||||
@@ -498,6 +502,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
|
||||
clientALPN,
|
||||
serviceCredentials = Nothing,
|
||||
serverVRange,
|
||||
proxiedRelayVRange = serverVRange,
|
||||
agreeSecret = False,
|
||||
proxyServer = False,
|
||||
useSNI
|
||||
@@ -508,6 +513,7 @@ defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
|
||||
defaultSMPClientConfig =
|
||||
(defaultClientConfig (Just alpnSupportedSMPHandshakes) False supportedClientSMPRelayVRange)
|
||||
{ defaultTransport = (show defaultSMPPort, transport @TLS),
|
||||
proxiedRelayVRange = supportedClientSMPRelayVRange,
|
||||
agreeSecret = True
|
||||
}
|
||||
{-# INLINE defaultSMPClientConfig #-}
|
||||
@@ -571,7 +577,7 @@ type SMPTransportSession = TransportSession BrokerMsg
|
||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||
-- as 'SMPServerTransmission' includes server information.
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
|
||||
getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, proxiedRelayVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
|
||||
@@ -596,6 +602,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
|
||||
transportHost,
|
||||
tcpConnectTimeout,
|
||||
tcpTimeout,
|
||||
proxiedRelayVRange,
|
||||
sendPings,
|
||||
lastReceived,
|
||||
timeoutErrorCount,
|
||||
@@ -1092,15 +1099,17 @@ resolvedNameOrNotFound d NameResponse {registration} = case registration of
|
||||
NRRegistered {nameRecord} -> T.toLower (nrName nameRecord) == fullDomainName d
|
||||
_ -> True
|
||||
|
||||
type QueueDrained = Bool
|
||||
|
||||
-- | Acknowledge message delivery (server deletes the message).
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
|
||||
-- This command is always sent in background request mode
|
||||
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
|
||||
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO QueueDrained
|
||||
ackSMPMessage c rpKey rId msgId =
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
|
||||
OK -> return ()
|
||||
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||
OK -> pure True
|
||||
cmd@MSG {} -> liftIO (writeSMPMessage c rId cmd) $> False
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Irreversibly suspend SMP queue.
|
||||
@@ -1126,10 +1135,10 @@ deleteSMPQueues = okSMPCommands DEL
|
||||
-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
|
||||
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
|
||||
connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {port = relayPort, keyHash = C.KeyHash kh} proxyAuth =
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout, proxiedRelayVRange}} nm relayServ@ProtocolServer {port = relayPort, keyHash = C.KeyHash kh} proxyAuth =
|
||||
sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (CertChainPubKey chain key) ->
|
||||
case supportedClientSMPRelayVRange `compatibleVersion` vr of
|
||||
case proxiedRelayVRange `compatibleVersion` vr of
|
||||
Nothing -> throwE $ transportErr TEVersion
|
||||
Just (Compatible v) -> do
|
||||
relayKey <- liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) =<< liftIO (runExceptT $ validateRelay chain key)
|
||||
@@ -1180,7 +1189,7 @@ instance StrEncoding ProxyClientError where
|
||||
-- consider how to process slow responses - is it handled somehow locally or delegated to the caller
|
||||
-- this method is used in the client
|
||||
-- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender
|
||||
-- receives PRES :: EncResponse -> BrokerMsg -- proxy to client
|
||||
-- receives PRES :: Maybe C.CbNonce -> EncResponse -> BrokerMsg -- proxy to client
|
||||
|
||||
-- When client sends message via proxy, there may be one successful scenario and 9 error scenarios
|
||||
-- as shown below (WTF stands for unexpected response, ??? for response that failed to parse).
|
||||
@@ -1233,20 +1242,20 @@ 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
|
||||
TBTransmission s _ : _ -> pure s
|
||||
TBTransmissions s _ _ : _ -> pure s
|
||||
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
|
||||
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret (encTransmissionNonce v nonce) b paddedProxiedTLength
|
||||
-- proxy interaction errors are wrapped
|
||||
let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
|
||||
tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
Right r -> case r of
|
||||
PRES (EncResponse er) -> do
|
||||
PRES nonce_ (EncResponse er) -> do
|
||||
-- server interaction errors are thrown directly
|
||||
t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
|
||||
t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (fromMaybe (C.reverseNonce nonce) nonce_) er
|
||||
case tParse serverThParams t' of
|
||||
t'' :| [] -> case tDecodeClient serverThParams t'' of
|
||||
(_, _, cmd) -> case cmd of
|
||||
@@ -1264,10 +1273,10 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
|
||||
-- this method is used in the proxy
|
||||
-- sends RFWD :: EncFwdTransmission -> Command Sender
|
||||
-- receives RRES :: EncFwdResponse -> BrokerMsg
|
||||
-- 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 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
|
||||
@@ -1279,11 +1288,11 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
|
||||
-- send
|
||||
sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
|
||||
RRES (EncFwdResponse efr) -> do
|
||||
RRES nonce_ (EncFwdResponse efr) -> do
|
||||
-- unwrap
|
||||
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
|
||||
FwdResponse {fwdCorrId = _, fwdResponse} <- liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode r'
|
||||
pure fwdResponse
|
||||
pure (nonce_, fwdResponse)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- get queue information - always sent interactively
|
||||
@@ -1411,7 +1420,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
|
||||
@@ -1430,14 +1439,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,
|
||||
|
||||
@@ -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
|
||||
@@ -931,6 +938,8 @@ data CryptoError
|
||||
CERatchetEarlierMessage Word32
|
||||
| -- | duplicate message number
|
||||
CERatchetDuplicateMessage
|
||||
| -- | KEM key generation failed, indicating a broken RNG
|
||||
CryptoKEMKeyGenError
|
||||
deriving (Eq, Show, Exception)
|
||||
|
||||
aesKeySize :: Int
|
||||
@@ -1045,9 +1054,7 @@ md5Hash = BA.convert . (hash :: ByteString -> Digest MD5)
|
||||
|
||||
-- | AEAD-GCM encryption with associated data.
|
||||
--
|
||||
-- Used as part of double ratchet encryption.
|
||||
-- This function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
|
||||
-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
|
||||
-- Used as part of double ratchet encryption, with a 16-byte IV (see @initAEAD@).
|
||||
encryptAEAD :: Key -> IV -> Int -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAEAD aesKey ivBytes paddedLen ad msg = do
|
||||
aead <- initAEAD @AES256 aesKey ivBytes
|
||||
@@ -1067,10 +1074,7 @@ encryptAEADNoPad aesKey ivBytes ad msg = do
|
||||
|
||||
-- | AEAD-GCM decryption with associated data.
|
||||
--
|
||||
-- Used as part of double ratchet encryption.
|
||||
-- This function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
|
||||
-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
|
||||
-- To make it compatible with WebCrypto we will need to start using initAEADGCM.
|
||||
-- Used as part of double ratchet encryption, with a 16-byte IV (see @initAEAD@).
|
||||
decryptAEAD :: Key -> IV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
|
||||
aead <- initAEAD @AES256 aesKey ivBytes
|
||||
@@ -1148,9 +1152,9 @@ maxLength :: forall i. KnownNat i => Int
|
||||
maxLength = fromIntegral (natVal $ Proxy @i)
|
||||
{-# INLINE maxLength #-}
|
||||
|
||||
-- this function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
|
||||
-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
|
||||
-- This is used for double ratchet encryption, so to make it compatible with WebCrypto we will need to deprecate it and start using initAEADGCM
|
||||
-- The 16-byte double ratchet IV is intentionally not the 96-bit IV recommended by NIST SP 800-38D, so GCM derives J0 = GHASH(IV || 0^64 || [128]_64),
|
||||
-- as in crypton_aes_gcm_init: https://hackage.haskell.org/package/crypton-0.34/src/cbits/crypton_aes.c
|
||||
-- WebCrypto and other SP 800-38D implementations interoperate only when given all 16 IV bytes.
|
||||
initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
|
||||
initAEAD (Key aesKey) (IV ivBytes) = do
|
||||
iv <- makeIV @c ivBytes
|
||||
@@ -1327,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
|
||||
@@ -1338,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).
|
||||
@@ -1386,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
|
||||
|
||||
@@ -1399,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
|
||||
@@ -1408,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
|
||||
@@ -1422,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)
|
||||
|
||||
@@ -72,6 +72,7 @@ module Simplex.Messaging.Crypto.Ratchet
|
||||
rcEncryptHeader,
|
||||
rcEncryptMsg,
|
||||
rcDecrypt,
|
||||
maxSkippedMsgKeys,
|
||||
-- used in tests
|
||||
MsgHeader (..),
|
||||
RatchetInitParams (..),
|
||||
@@ -119,7 +120,7 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, parseE, parseE')
|
||||
import Simplex.Messaging.Util (($>>=), (<$?>))
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import UnliftIO.STM
|
||||
@@ -327,9 +328,13 @@ instance StrEncoding AnyE2ERatchetParamsUri where
|
||||
Nothing -> pure $ AnyE2ERatchetParamsUri SRKSProposed a $ E2ERatchetParamsUri vr k1 k2 Nothing
|
||||
_ -> fail "bad e2e params"
|
||||
where
|
||||
kemP query =
|
||||
queryParam_ "kem_key" query
|
||||
$>>= \k -> Just . kemParams k <$> queryParam_ "kem_ct" query
|
||||
kemP query = do
|
||||
k_ <- queryParam_ "kem_key" query
|
||||
ct_ <- queryParam_ "kem_ct" query
|
||||
case (k_, ct_) of
|
||||
(Just k, _) -> pure $ Just $ kemParams k ct_
|
||||
(Nothing, Nothing) -> pure Nothing
|
||||
(Nothing, Just _) -> fail "bad e2e params: kem_ct without kem_key"
|
||||
kemParams k = \case
|
||||
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
|
||||
Just ct -> ARKP SRKSAccepted $ RKParamsAccepted ct k
|
||||
@@ -958,6 +963,9 @@ type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff
|
||||
maxSkip :: Word32
|
||||
maxSkip = 512
|
||||
|
||||
maxSkippedMsgKeys :: Int
|
||||
maxSkippedMsgKeys = 2000
|
||||
|
||||
rcDecrypt ::
|
||||
forall a.
|
||||
(AlgorithmI a, DhAlgorithm a) =>
|
||||
|
||||
@@ -16,6 +16,8 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad (when)
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Bifunctor (bimap)
|
||||
@@ -23,6 +25,7 @@ import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (rngFuncPtr, withDRG)
|
||||
@@ -55,14 +58,13 @@ pattern KEMSharedKey s <- KEMSharedKey_ s
|
||||
type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
|
||||
|
||||
sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair
|
||||
sntrup761Keypair drg =
|
||||
bimap KEMPublicKey_ KEMSecretKey
|
||||
<$> BA.allocRet
|
||||
c_SNTRUP761_SECRETKEY_SIZE
|
||||
( \skPtr ->
|
||||
BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr ->
|
||||
withDRG drg $ \cxtPtr -> c_sntrup761_keypair pkPtr skPtr cxtPtr rngFuncPtr
|
||||
)
|
||||
sntrup761Keypair drg = do
|
||||
((r, pk), sk) <-
|
||||
BA.allocRet c_SNTRUP761_SECRETKEY_SIZE $ \skPtr ->
|
||||
BA.allocRet c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr ->
|
||||
withDRG drg $ \cxtPtr -> c_sntrup761_keypair pkPtr skPtr cxtPtr rngFuncPtr
|
||||
when (r /= 0) $ throwIO C.CryptoKEMKeyGenError
|
||||
pure (KEMPublicKey_ pk, KEMSecretKey sk)
|
||||
|
||||
sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
|
||||
sntrup761Enc drg (KEMPublicKey pk) =
|
||||
|
||||
@@ -10,9 +10,9 @@ import Foreign
|
||||
import Foreign.C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGContext, RNGFunc)
|
||||
|
||||
-- void sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random);
|
||||
-- int sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random);
|
||||
foreign import ccall "sntrup761_keypair"
|
||||
c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO ()
|
||||
c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO CInt
|
||||
|
||||
-- void sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, void *random_ctx, sntrup761_random_func *random);
|
||||
foreign import ccall "sntrup761_enc"
|
||||
|
||||
@@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.ShortLink
|
||||
encodeSignUserData,
|
||||
newOwnerAuth,
|
||||
encryptLinkData,
|
||||
encryptFixedData,
|
||||
encryptUserData,
|
||||
decryptLinkData,
|
||||
)
|
||||
@@ -84,9 +85,10 @@ newOwnerAuth g ownerId signingKey = do
|
||||
pure (ownerPrivKey, OwnerAuth {ownerId, ownerKey, authOwnerSig})
|
||||
|
||||
encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> ExceptT AgentErrorType IO QueueLinkData
|
||||
encryptLinkData g k = bimapM (encrypt fixedDataPaddedLength) (encrypt userDataPaddedLength)
|
||||
where
|
||||
encrypt len = encryptData g k len
|
||||
encryptLinkData g k = bimapM (encryptFixedData g k) (encryptUserData g k)
|
||||
|
||||
encryptFixedData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
|
||||
encryptFixedData g k s = encryptData g k fixedDataPaddedLength s
|
||||
|
||||
encryptUserData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
|
||||
encryptUserData g k s = encryptData g k userDataPaddedLength s
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
|
||||
|
||||
|
||||
SET statement_timeout = 0;
|
||||
SET lock_timeout = 0;
|
||||
SET idle_in_transaction_session_timeout = 0;
|
||||
@@ -312,3 +313,4 @@ ALTER TABLE ONLY ntf_server.subscriptions
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -145,7 +145,10 @@ module Simplex.Messaging.Protocol
|
||||
RcvNtfDhSecret,
|
||||
Message (..),
|
||||
RcvMessage (..),
|
||||
MsgId,
|
||||
MsgId (unMsgId),
|
||||
mkMsgId,
|
||||
unsafeMsgId,
|
||||
randomMsgId,
|
||||
MsgBody,
|
||||
IdsHash (..),
|
||||
ServiceSub (..),
|
||||
@@ -168,6 +171,7 @@ module Simplex.Messaging.Protocol
|
||||
EncFwdTransmission (..),
|
||||
EncResponse (..),
|
||||
EncTransmission (..),
|
||||
encTransmissionNonce,
|
||||
FwdResponse (..),
|
||||
FwdTransmission (..),
|
||||
NameRecord (..),
|
||||
@@ -232,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
|
||||
@@ -268,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
|
||||
@@ -702,19 +708,24 @@ instance Encoding NewNtfCreds where
|
||||
newtype EncTransmission = EncTransmission ByteString
|
||||
deriving (Show)
|
||||
|
||||
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)
|
||||
@@ -737,8 +748,8 @@ data BrokerMsg where
|
||||
NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
|
||||
-- Should include certificate chain
|
||||
PKEY :: SessionId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
|
||||
RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
|
||||
PRES :: EncResponse -> BrokerMsg -- proxy to client
|
||||
RRES :: Maybe C.CbNonce -> EncFwdResponse -> BrokerMsg -- relay to proxy
|
||||
PRES :: Maybe C.CbNonce -> EncResponse -> BrokerMsg -- proxy to client
|
||||
END :: BrokerMsg
|
||||
ENDS :: Int64 -> IdsHash -> BrokerMsg
|
||||
DELD :: BrokerMsg
|
||||
@@ -760,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)
|
||||
@@ -792,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
|
||||
@@ -1493,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
|
||||
@@ -1818,8 +1856,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
encodeProtocol v = \case
|
||||
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
| v >= newNtfCredsSMPVersion -> new <> e (subMode, queueReqData, ntfCreds)
|
||||
| v >= shortLinksSMPVersion -> new <> e (subMode, queueReqData)
|
||||
| otherwise -> new <> e (subMode, senderCanSecure (queueReqMode <$> queueReqData))
|
||||
| otherwise -> new <> e (subMode, queueReqData)
|
||||
where
|
||||
new = e (NEW_, ' ', rKey, dhKey, auth_)
|
||||
SUB -> e SUB_
|
||||
@@ -1906,20 +1943,18 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
CT SCreator NEW_ -> Cmd SCreator <$> newCmd
|
||||
where
|
||||
newCmd
|
||||
| v >= newNtfCredsSMPVersion = new smpP smpP
|
||||
| v >= shortLinksSMPVersion = new smpP nothing
|
||||
| otherwise = new (qReq <$> smpP) nothing
|
||||
| v >= newNtfCredsSMPVersion = new smpP
|
||||
| otherwise = new nothing
|
||||
where
|
||||
nothing = pure Nothing
|
||||
new p2 p3 = NEW <$> do
|
||||
new p3 = NEW <$> do
|
||||
rcvAuthKey <- _smpP
|
||||
rcvDhKey <- smpP
|
||||
auth_ <- smpP
|
||||
subMode <- smpP
|
||||
queueReqData <- p2
|
||||
queueReqData <- smpP
|
||||
ntfCreds <- p3
|
||||
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
|
||||
CT SRecipient tag ->
|
||||
Cmd SRecipient <$> case tag of
|
||||
SUB_ -> pure SUB
|
||||
@@ -1970,8 +2005,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
|
||||
| v >= newNtfCredsSMPVersion -> ids <> e (queueMode, linkId, serviceId, serverNtfCreds)
|
||||
| v >= serviceCertsSMPVersion -> ids <> e (queueMode, linkId, serviceId)
|
||||
| v >= shortLinksSMPVersion -> ids <> e (queueMode, linkId)
|
||||
| otherwise -> ids <> e (senderCanSecure queueMode)
|
||||
| otherwise -> ids <> e (queueMode, linkId)
|
||||
where
|
||||
ids = e (IDS_, ' ', rcvId, sndId, srvDh)
|
||||
LNK sId d -> e (LNK_, ' ', sId, d)
|
||||
@@ -1985,8 +2019,8 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
|
||||
NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
|
||||
PKEY sid vr certKey -> e (PKEY_, ' ', sid, vr, certKey)
|
||||
RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
|
||||
PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
|
||||
RRES nonce_ (EncFwdResponse encBlock) -> fwdResp RRES_ nonce_ encBlock
|
||||
PRES nonce_ (EncResponse encBlock) -> fwdResp PRES_ nonce_ encBlock
|
||||
END -> e END_
|
||||
ENDS n idsHash -> serviceResp ENDS_ n idsHash
|
||||
DELD -> e DELD_
|
||||
@@ -2010,6 +2044,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
serviceResp tag n idsHash
|
||||
| v >= rcvServiceSMPVersion = e (tag, ' ', n, idsHash)
|
||||
| otherwise = e (tag, ' ', n)
|
||||
fwdResp tag nonce_ encBlock
|
||||
| v >= fwdNoncesSMPVersion = e (tag, ' ', nonce_, Tail encBlock)
|
||||
| otherwise = e (tag, ' ', Tail encBlock)
|
||||
|
||||
protocolP v = \case
|
||||
MSG_ -> do
|
||||
@@ -2019,19 +2056,17 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
bodyP = EncRcvMsgBody . unTail <$> smpP
|
||||
ALLS_ -> pure ALLS
|
||||
IDS_
|
||||
| v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
|
||||
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
|
||||
| v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
|
||||
| otherwise -> ids (qm <$> smpP) nothing nothing nothing
|
||||
| v >= newNtfCredsSMPVersion -> ids smpP smpP
|
||||
| v >= serviceCertsSMPVersion -> ids smpP nothing
|
||||
| otherwise -> ids nothing nothing
|
||||
where
|
||||
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
nothing = pure Nothing
|
||||
ids p1 p2 p3 p4 = do
|
||||
ids p3 p4 = do
|
||||
rcvId <- _smpP
|
||||
sndId <- smpP
|
||||
rcvPublicDhKey <- smpP
|
||||
queueMode <- p1
|
||||
linkId <- p2
|
||||
queueMode <- smpP
|
||||
linkId <- smpP
|
||||
serviceId <- p3
|
||||
serverNtfCreds <- p4
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
|
||||
@@ -2041,8 +2076,8 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
NID_ -> NID <$> _smpP <*> smpP
|
||||
NMSG_ -> NMSG <$> _smpP <*> smpP
|
||||
PKEY_ -> PKEY <$> _smpP <*> smpP <*> smpP
|
||||
RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
|
||||
PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
|
||||
RRES_ -> fwdRespP RRES EncFwdResponse
|
||||
PRES_ -> fwdRespP PRES EncResponse
|
||||
END_ -> pure END
|
||||
ENDS_ -> serviceRespP ENDS
|
||||
DELD_ -> pure DELD
|
||||
@@ -2059,6 +2094,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
serviceRespP resp
|
||||
| v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP
|
||||
| otherwise = resp <$> _smpP <*> pure mempty
|
||||
fwdRespP :: (Maybe C.CbNonce -> a -> BrokerMsg) -> (ByteString -> a) -> Parser BrokerMsg
|
||||
fwdRespP resp enc = resp <$> (A.space *> nonceP) <*> (enc <$> A.takeByteString)
|
||||
nonceP = if v >= fwdNoncesSMPVersion then smpP else pure Nothing
|
||||
|
||||
fromProtocolError = \case
|
||||
PECmdSyntax -> CMD SYNTAX
|
||||
@@ -2075,7 +2113,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
-- PONG response must not have queue ID
|
||||
PONG -> noEntityMsg
|
||||
PKEY {} -> noEntityMsg
|
||||
RRES _ -> noEntityMsg
|
||||
RRES {} -> noEntityMsg
|
||||
ALLS -> noEntityMsg
|
||||
RNAME {} -> noEntityMsg
|
||||
-- other broker responses must have queue ID
|
||||
@@ -2411,7 +2449,9 @@ tDecodeServer THandleParams {sessionId, thVersion = v, implySessId} = \case
|
||||
where
|
||||
cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials tAuth entityId
|
||||
t :: a -> (CorrId, EntityId, a)
|
||||
t = (corrId,entityId,)
|
||||
-- IDs are slices of the ~16 KB received block and are kept as subscription keys,
|
||||
-- so without a copy one live key retains the whole block
|
||||
t = (CorrId $ B.copy $ bs corrId,EntityId $ B.copy $ unEntityId entityId,)
|
||||
Left _ -> tError corrId PEBlock
|
||||
| otherwise -> tError corrId PESession
|
||||
Left _ -> tError "" PEBlock
|
||||
|
||||
@@ -1145,14 +1145,16 @@ cancelSub s = case subThread s of
|
||||
type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s)
|
||||
|
||||
receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s ()
|
||||
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do
|
||||
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms c@Client {rcvQ, rcvActiveAt} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
|
||||
sa <- asks serverActive
|
||||
stats <- asks serverStats
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
liftIO $ forever $ do
|
||||
ts <- tGetServer h
|
||||
unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
|
||||
atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
|
||||
receivedAt <- getSystemTime
|
||||
atomically $ writeTVar rcvActiveAt $! receivedAt
|
||||
let (es, ts') = partitionEithers $ L.toList ts
|
||||
errs = map (second ERR) es
|
||||
errs' <- case ts' of
|
||||
@@ -1168,7 +1170,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
|
||||
mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds
|
||||
pure $ errs ++ errs'
|
||||
[] -> pure errs
|
||||
mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs'
|
||||
mapM_ (sendResponses c stats authDelay receivedAt . (,[])) $ L.nonEmpty errs'
|
||||
where
|
||||
sameParty :: SParty p -> SignedTransmission Cmd -> Bool
|
||||
sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p'
|
||||
@@ -1191,6 +1193,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
|
||||
GET -> incStat $ msgGetAuth stats
|
||||
_ -> pure ()
|
||||
|
||||
isAuthError :: Transmission BrokerMsg -> Bool
|
||||
isAuthError (_, _, r) = case r of
|
||||
ERR AUTH -> True
|
||||
_ -> False
|
||||
|
||||
sendResponses :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
|
||||
sendResponses c@Client {sndQ} stats authDelay since rs@(ts, _)
|
||||
| any isAuthError ts = sendAfterDelay c stats authDelay since rs
|
||||
| otherwise = atomically $ writeTBQueue sndQ rs
|
||||
|
||||
sendAfterDelay :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
|
||||
sendAfterDelay c@Client {sndQ, clientTHParams = THandleParams {sessionId}} stats delay since rs
|
||||
| delay > 0 = do
|
||||
elapsed <- subtract (microseconds since) . microseconds <$> getSystemTime
|
||||
when (elapsed >= delay) $ incStat $ authDelayExceeded stats
|
||||
forkClient c (B.unpack $ "client $" <> encode sessionId <> " auth") $ threadDelay' (delay - elapsed `mod` delay) >> write
|
||||
| otherwise = write
|
||||
where
|
||||
write = atomically $ writeTBQueue sndQ rs
|
||||
microseconds (MkSystemTime s ns) = s * 1000000 + fromIntegral (ns `div` 1000)
|
||||
|
||||
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
|
||||
send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
|
||||
@@ -1319,11 +1342,6 @@ isContactQueue QueueRec {queueMode, senderKey} = case queueMode of
|
||||
Just QMContact -> True
|
||||
Nothing -> isNothing senderKey -- for backward compatibility with pre-SKEY contact addresses
|
||||
|
||||
isSecuredMsgQueue :: QueueRec -> Bool
|
||||
isSecuredMsgQueue QueueRec {queueMode, senderKey} = case queueMode of
|
||||
Just QMContact -> False
|
||||
_ -> isJust senderKey
|
||||
|
||||
-- Random correlation ID is used as a nonce in case crypto_box authenticator is used to authorize transmission
|
||||
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> C.APublicAuthKey -> Bool
|
||||
verifyCmdAuthorization thAuth tAuth authorized corrId key = maybe False (verify key) tAuth
|
||||
@@ -1339,7 +1357,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
|
||||
@@ -1379,15 +1397,18 @@ client
|
||||
ms
|
||||
clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
|
||||
stats <- asks serverStats
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
|
||||
process batchSubs t acc@(rs, msgs) =
|
||||
(maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_)))
|
||||
<$> processCommand clntServiceId batchSubs t
|
||||
forever $ do
|
||||
batch <- atomically (readTBQueue rcvQ)
|
||||
processedAt <- liftIO getSystemTime
|
||||
batchSubs <- prepareBatchSubs clntServiceId batch
|
||||
foldrM (process batchSubs) ([], []) batch
|
||||
>>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_)
|
||||
>>= \(rs_, msgs) -> mapM_ (liftIO . sendResponses clnt stats authDelay processedAt . (,msgs)) (L.nonEmpty rs_)
|
||||
where
|
||||
prepareBatchSubs ::
|
||||
Maybe ServiceId ->
|
||||
@@ -1458,17 +1479,18 @@ 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
|
||||
Right r -> PRES r <$ inc own pSuccesses
|
||||
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
|
||||
PCEResponseTimeout -> do
|
||||
inc own pErrorsOther
|
||||
liftIO $ closeTimedOutClient (smpPingCount $ networkConfig $ smpCfg $ agentCfg a) smp
|
||||
_ -> 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)
|
||||
@@ -1958,7 +1980,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 ()
|
||||
@@ -2004,7 +2026,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
|
||||
@@ -2117,7 +2139,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}
|
||||
@@ -2126,15 +2148,16 @@ client
|
||||
|
||||
processForwardedCommand :: EncFwdTransmission -> M s (Maybe BrokerMsg)
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do
|
||||
startedAt <- liftIO getSystemTime
|
||||
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
|
||||
b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret clientNonce et
|
||||
clientNonce = fwdCorrId
|
||||
b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret (encTransmissionNonce fwdVersion clientNonce) et
|
||||
let clntTHParams = smpTHParamsSetVersion fwdVersion thParams'
|
||||
-- only allowing single forwarded transactions
|
||||
t' <- case tParse clntTHParams b of
|
||||
@@ -2147,9 +2170,13 @@ client
|
||||
TBError _ _ : _ -> throwE BLOCK
|
||||
TBTransmission b' _ : _ -> pure b'
|
||||
TBTransmissions b' _ _ : _ -> pure b'
|
||||
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength
|
||||
nonce_ <-
|
||||
if fwdVersion >= fwdNoncesSMPVersion
|
||||
then Just <$> (atomically . C.randomCbNonce =<< asks random)
|
||||
else pure Nothing
|
||||
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (fromMaybe (C.reverseNonce clientNonce) nonce_) r' paddedProxiedTLength
|
||||
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
|
||||
pure $ RRES $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
|
||||
pure $ RRES nonce_ $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
|
||||
-- the inner response, or Nothing if forked (RSLV).
|
||||
r_ <- lift (rejectOrVerify clntThAuth t') >>= \case
|
||||
-- rejectOrVerify filters allowed commands, no need to repeat it here.
|
||||
@@ -2165,7 +2192,11 @@ client
|
||||
_ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'')
|
||||
stats <- asks serverStats
|
||||
incStat $ pMsgFwdsRecv stats
|
||||
traverse encodeResp r_
|
||||
traverse encodeResp r_ >>= \case
|
||||
Just rres | any isAuthError r_ -> do
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
Nothing <$ liftIO (sendAfterDelay clnt stats authDelay startedAt ([(corrId, NoEntity, rres)], []))
|
||||
rres_ -> pure rres_
|
||||
where
|
||||
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s)
|
||||
rejectOrVerify clntThAuth = \case
|
||||
@@ -2191,7 +2222,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
|
||||
|
||||
@@ -2240,7 +2271,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
|
||||
|
||||
@@ -68,6 +68,7 @@ module Simplex.Messaging.Server.Env.STM
|
||||
defaultInactiveClientExpiration,
|
||||
defaultProxyClientConcurrency,
|
||||
defaultNameResolverConcurrency,
|
||||
defaultAuthErrorDelayMs,
|
||||
defaultMaxJournalMsgCount,
|
||||
defaultMaxJournalStateLines,
|
||||
defaultIdleQueueInterval,
|
||||
@@ -187,6 +188,7 @@ data ServerConfig s = ServerConfig
|
||||
ntfDeliveryInterval :: Int,
|
||||
-- | interval between sending pending END events to unsubscribed clients, seconds
|
||||
pendingENDInterval :: Int,
|
||||
authErrorDelay :: Int64,
|
||||
smpCredentials :: ServerCredentials,
|
||||
httpCredentials :: Maybe ServerCredentials,
|
||||
-- | SMP client-server protocol version range
|
||||
@@ -255,6 +257,9 @@ defaultProxyClientConcurrency = 32
|
||||
defaultNameResolverConcurrency :: Int
|
||||
defaultNameResolverConcurrency = 1000
|
||||
|
||||
defaultAuthErrorDelayMs :: Int64
|
||||
defaultAuthErrorDelayMs = 50
|
||||
|
||||
journalMsgStoreDepth :: Int
|
||||
journalMsgStoreDepth = 5
|
||||
|
||||
@@ -571,7 +576,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
|
||||
|
||||
@@ -580,6 +580,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
|
||||
pendingENDInterval = 15000000, -- 15 seconds
|
||||
ntfDeliveryInterval = 1500000, -- 1.5 second
|
||||
authErrorDelay = 1000 * readIniDefault defaultAuthErrorDelayMs "TRANSPORT" "auth_error_delay_ms" ini,
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig =
|
||||
mkTransportServerConfig
|
||||
|
||||
@@ -130,7 +130,9 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
|
||||
<> ("host = " <> T.pack host <> "\n")
|
||||
<> ("port = " <> defaultServerPorts <> "\n")
|
||||
<> "log_tls_errors = off\n\n\
|
||||
\# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
|
||||
\# Minimum time to respond with AUTH error, milliseconds.\n"
|
||||
<> ("# auth_error_delay_ms = " <> tshow defaultAuthErrorDelayMs <> "\n\n")
|
||||
<> "# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
|
||||
\# This option is deprecated and should be used for testing only.\n\
|
||||
\# , port 443 should be specified in port above\n\
|
||||
\websockets = off\n"
|
||||
|
||||
@@ -114,7 +114,9 @@ instance MsgStoreClass PostgresMsgStore where
|
||||
where
|
||||
st = dbStore $ queueStore_ ms
|
||||
oldMsg = now - ttl
|
||||
batchSize = 10000 :: Int
|
||||
-- expired messages read per page in expire_old_messages, and the page is one
|
||||
-- transaction: queues in it stay row-locked against SEND and ACK until it commits.
|
||||
batchSize = 100 :: Int
|
||||
toMessageStats (expiredMsgsCount, storedMsgsCount, storedQueues) =
|
||||
MessageStats {expiredMsgsCount, storedMsgsCount, storedQueues}
|
||||
|
||||
@@ -200,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)
|
||||
@@ -269,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)
|
||||
@@ -295,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
|
||||
@@ -363,8 +365,8 @@ deleteAllMessages ms =
|
||||
db
|
||||
[sql|
|
||||
UPDATE msg_queues
|
||||
SET msg_queue_size = 0, msg_can_write = TRUE, msg_queue_expire = FALSE
|
||||
WHERE msg_queue_size != 0 OR msg_can_write = FALSE OR msg_queue_expire = TRUE
|
||||
SET msg_queue_size = 0, msg_can_write = TRUE
|
||||
WHERE msg_queue_size != 0 OR msg_can_write = FALSE
|
||||
|]
|
||||
|
||||
updateQueueCounts :: PostgresMsgStore -> IO ()
|
||||
@@ -384,16 +386,15 @@ updateQueueCounts ms =
|
||||
db
|
||||
[sql|
|
||||
UPDATE msg_queues
|
||||
SET msg_queue_size = 0, msg_can_write = TRUE, msg_queue_expire = FALSE
|
||||
WHERE msg_queue_size != 0 OR msg_can_write = FALSE OR msg_queue_expire = TRUE
|
||||
SET msg_queue_size = 0, msg_can_write = TRUE
|
||||
WHERE msg_queue_size != 0 OR msg_can_write = FALSE
|
||||
|]
|
||||
void $ DB.execute_
|
||||
db
|
||||
[sql|
|
||||
UPDATE msg_queues q
|
||||
SET msg_queue_size = s.size,
|
||||
msg_can_write = s.quota_count = 0,
|
||||
msg_queue_expire = s.size > s.quota_count
|
||||
msg_can_write = s.quota_count = 0
|
||||
FROM queue_stats s
|
||||
WHERE q.recipient_id = s.recipient_id
|
||||
|]
|
||||
@@ -428,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),
|
||||
|
||||
@@ -126,6 +126,7 @@ prometheusMetrics sm rtm ts =
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg,
|
||||
_rcvServicesSubDuplicate,
|
||||
_authDelayExceeded,
|
||||
_qCount,
|
||||
_msgCount,
|
||||
_ntfCount,
|
||||
@@ -192,6 +193,10 @@ prometheusMetrics sm rtm ts =
|
||||
\# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\
|
||||
\# TYPE simplex_smp_queues_notify_monthly gauge\n\
|
||||
\simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\
|
||||
\\n\
|
||||
\# HELP simplex_smp_auth_delay_exceeded Responses with AUTH errors sent without delay, as processing took longer than the delay.\n\
|
||||
\# TYPE simplex_smp_auth_delay_exceeded counter\n\
|
||||
\simplex_smp_auth_delay_exceeded " <> mshow _authDelayExceeded <> "\n# authDelayExceeded\n\
|
||||
\\n"
|
||||
subscriptions =
|
||||
"# Subscriptions\n\
|
||||
|
||||
@@ -13,12 +13,14 @@ module Simplex.Messaging.Server.QueueStore
|
||||
ServiceRec (..),
|
||||
CertFingerprint,
|
||||
ServerEntityStatus (..),
|
||||
isSecuredMsgQueue,
|
||||
) where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Simplex.Messaging.Encoding
|
||||
@@ -48,6 +50,11 @@ data QueueRec = QueueRec
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
isSecuredMsgQueue :: QueueRec -> Bool
|
||||
isSecuredMsgQueue QueueRec {queueMode, senderKey} = case queueMode of
|
||||
Just QMContact -> False
|
||||
_ -> isJust senderKey
|
||||
|
||||
data NtfCreds = NtfCreds
|
||||
{ notifierId :: NotifierId,
|
||||
notifierKey :: NtfPublicAuthKey,
|
||||
|
||||
@@ -314,9 +314,9 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
addQueueLinkData st sq lnkId d =
|
||||
withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
|
||||
Nothing ->
|
||||
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId))
|
||||
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId, QMContact))
|
||||
Just (lnkId', _) | lnkId' == lnkId ->
|
||||
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data = ?)") (d :. (lnkId, rId, fst d))
|
||||
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data = ?)") (d :. (lnkId, rId, QMContact, fst d))
|
||||
_ -> throwE AUTH
|
||||
where
|
||||
rId = recipientId sq
|
||||
@@ -324,7 +324,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
assertUpdated $ withDB' "addQueueLinkData" st update
|
||||
atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just (lnkId, d)}
|
||||
withLog "addQueueLinkData" st $ \s -> logCreateLink s rId lnkId d
|
||||
qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL"
|
||||
-- the sender key condition is checked in SQL because without cache each command reads its own copy of the queue record
|
||||
qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL AND (sender_key IS NULL OR queue_mode = ?)"
|
||||
|
||||
deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData st sq =
|
||||
@@ -824,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)
|
||||
|
||||
@@ -22,7 +22,8 @@ serverSchemaMigrations =
|
||||
("20250903_store_messages", m20250903_store_messages, Just down_m20250903_store_messages),
|
||||
("20250915_queue_ids_hash", m20250915_queue_ids_hash, Just down_m20250915_queue_ids_hash),
|
||||
("20260916_prometheus_indexes", m20260916_prometheus_indexes, Just down_m20260916_prometheus_indexes),
|
||||
("20260917_msg_queues_hot", m20260917_msg_queues_hot, Just down_m20260917_msg_queues_hot)
|
||||
("20260917_msg_queues_hot", m20260917_msg_queues_hot, Just down_m20260917_msg_queues_hot),
|
||||
("20260918_expire_messages", m20260918_expire_messages, Just down_m20260918_expire_messages)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -734,3 +735,504 @@ ALTER TABLE msg_queues RESET (fillfactor, autovacuum_vacuum_scale_factor, autova
|
||||
ALTER TABLE messages RESET (autovacuum_vacuum_scale_factor, autovacuum_analyze_scale_factor, toast.autovacuum_vacuum_scale_factor);
|
||||
ALTER TABLE services RESET (fillfactor, autovacuum_vacuum_threshold, autovacuum_vacuum_scale_factor);
|
||||
|]
|
||||
|
||||
m20260918_expire_messages :: Text
|
||||
m20260918_expire_messages =
|
||||
[r|
|
||||
CREATE INDEX idx_messages_expire ON messages (msg_ts, recipient_id) WHERE NOT msg_quota;
|
||||
|
||||
DROP INDEX idx_messages_recipient_id_msg_ts;
|
||||
|
||||
DROP INDEX idx_msg_queues_expire;
|
||||
|
||||
DROP PROCEDURE expire_old_messages(bigint, integer);
|
||||
|
||||
CREATE PROCEDURE expire_old_messages(IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
rids BYTEA[];
|
||||
rid BYTEA;
|
||||
last_ts BIGINT := -1;
|
||||
last_rid BYTEA := '\x';
|
||||
next_ts BIGINT;
|
||||
next_rid BYTEA;
|
||||
del_count BIGINT;
|
||||
total_deleted BIGINT := 0;
|
||||
BEGIN
|
||||
LOOP
|
||||
-- The page is scanned in (msg_ts, recipient_id) order, so its last row is the next
|
||||
-- keyset cursor. Advancing it past every row read, including queues left unexpired
|
||||
-- because delete_expired_msgs skipped a locked row or raised, is what terminates the
|
||||
-- loop; re-reading from the start instead would repeat those queues forever.
|
||||
SELECT array_agg(DISTINCT recipient_id),
|
||||
(array_agg(msg_ts ORDER BY msg_ts DESC, recipient_id DESC))[1],
|
||||
(array_agg(recipient_id ORDER BY msg_ts DESC, recipient_id DESC))[1]
|
||||
INTO rids, next_ts, next_rid
|
||||
FROM (
|
||||
SELECT msg_ts, recipient_id
|
||||
FROM messages
|
||||
WHERE NOT msg_quota
|
||||
AND msg_ts < p_old_ts
|
||||
AND (msg_ts, recipient_id) > (last_ts, last_rid)
|
||||
ORDER BY msg_ts ASC, recipient_id ASC
|
||||
LIMIT batch_size
|
||||
) m;
|
||||
|
||||
EXIT WHEN rids IS NULL;
|
||||
|
||||
FOREACH rid IN ARRAY rids
|
||||
LOOP
|
||||
BEGIN
|
||||
del_count := delete_expired_msgs(rid, p_old_ts);
|
||||
total_deleted := total_deleted + del_count;
|
||||
EXCEPTION WHEN OTHERS THEN
|
||||
RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
|
||||
CONTINUE;
|
||||
END;
|
||||
END LOOP;
|
||||
COMMIT;
|
||||
|
||||
last_ts := next_ts;
|
||||
last_rid := next_rid;
|
||||
END LOOP;
|
||||
|
||||
r_expired_msgs_count := total_deleted;
|
||||
r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
|
||||
r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION delete_expired_msgs(p_recipient_id bytea, p_old_ts bigint) RETURNS bigint
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
keep_min_id BIGINT;
|
||||
del_count BIGINT;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE SKIP LOCKED;
|
||||
|
||||
IF NOT FOUND OR q_size = 0 THEN
|
||||
RETURN 0;
|
||||
END IF;
|
||||
|
||||
SELECT MIN(message_id) INTO keep_min_id
|
||||
FROM messages WHERE recipient_id = p_recipient_id AND msg_ts >= p_old_ts AND msg_quota = FALSE;
|
||||
|
||||
IF keep_min_id IS NULL THEN
|
||||
DELETE FROM messages WHERE recipient_id = p_recipient_id AND msg_quota = FALSE;
|
||||
ELSE
|
||||
DELETE FROM messages WHERE recipient_id = p_recipient_id AND message_id < keep_min_id AND msg_quota = FALSE;
|
||||
END IF;
|
||||
|
||||
GET DIAGNOSTICS del_count = ROW_COUNT;
|
||||
IF del_count > 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
|
||||
msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN del_count;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION write_message(p_recipient_id bytea, p_msg_id bytea, p_msg_ts bigint, p_msg_quota boolean, p_msg_ntf_flag boolean, p_msg_body bytea, p_quota integer) RETURNS TABLE(quota_written boolean, was_empty boolean)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_can_write BOOLEAN;
|
||||
q_size BIGINT;
|
||||
BEGIN
|
||||
SELECT msg_can_write, msg_queue_size INTO q_can_write, q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF q_can_write OR q_size = 0 THEN
|
||||
quota_written := p_msg_quota OR q_size >= p_quota;
|
||||
was_empty := q_size = 0;
|
||||
|
||||
INSERT INTO messages(recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
|
||||
VALUES (p_recipient_id, p_msg_id, p_msg_ts, quota_written, p_msg_ntf_flag AND NOT quota_written, CASE WHEN quota_written THEN '' :: BYTEA ELSE p_msg_body END);
|
||||
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = NOT quota_written,
|
||||
msg_queue_size = msg_queue_size + 1
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
|
||||
RETURN QUERY VALUES (quota_written, was_empty);
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION try_del_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
msg RECORD;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
IF msg.msg_id = p_msg_id THEN
|
||||
DELETE FROM messages WHERE message_id = msg.message_id;
|
||||
IF FOUND THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION try_del_peek_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
msg RECORD;
|
||||
msg_deleted BOOLEAN;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
IF msg.msg_id = p_msg_id THEN
|
||||
DELETE FROM messages WHERE message_id = msg.message_id;
|
||||
|
||||
msg_deleted := FOUND;
|
||||
IF msg_deleted THEN
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
|
||||
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF FOUND THEN
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
IF msg_deleted THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
ELSIF msg_deleted OR q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
ELSE
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
ALTER TABLE msg_queues DROP COLUMN msg_queue_expire;
|
||||
|]
|
||||
|
||||
down_m20260918_expire_messages :: Text
|
||||
down_m20260918_expire_messages =
|
||||
[r|
|
||||
ALTER TABLE msg_queues ADD COLUMN msg_queue_expire boolean NOT NULL DEFAULT FALSE;
|
||||
|
||||
-- ADD COLUMN already defaulted every row to FALSE, so the backfill only needs the rows
|
||||
-- that become TRUE, which avoids rewriting the whole table. The flag is only read to pick
|
||||
-- queues for delete_expired_msgs, and that returns 0 without deleting when msg_queue_size
|
||||
-- is 0, so excluding empty queues here cannot change what expires.
|
||||
UPDATE msg_queues q
|
||||
SET msg_queue_expire = TRUE
|
||||
WHERE msg_queue_size > 0
|
||||
AND EXISTS (SELECT 1 FROM messages m WHERE m.recipient_id = q.recipient_id AND NOT m.msg_quota);
|
||||
|
||||
CREATE INDEX idx_msg_queues_expire ON msg_queues (recipient_id) WHERE deleted_at IS NULL AND msg_queue_expire;
|
||||
|
||||
CREATE INDEX idx_messages_recipient_id_msg_ts ON messages (recipient_id, msg_ts);
|
||||
|
||||
DROP INDEX idx_messages_expire;
|
||||
|
||||
CREATE OR REPLACE FUNCTION delete_expired_msgs(p_recipient_id bytea, p_old_ts bigint) RETURNS bigint
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
keep_min_id BIGINT;
|
||||
del_count BIGINT;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE SKIP LOCKED;
|
||||
|
||||
IF NOT FOUND OR q_size = 0 THEN
|
||||
RETURN 0;
|
||||
END IF;
|
||||
|
||||
SELECT MIN(message_id) INTO keep_min_id
|
||||
FROM messages WHERE recipient_id = p_recipient_id AND msg_ts >= p_old_ts AND msg_quota = FALSE;
|
||||
|
||||
IF keep_min_id IS NULL THEN
|
||||
DELETE FROM messages WHERE recipient_id = p_recipient_id AND msg_quota = FALSE;
|
||||
ELSE
|
||||
DELETE FROM messages WHERE recipient_id = p_recipient_id AND message_id < keep_min_id AND msg_quota = FALSE;
|
||||
END IF;
|
||||
|
||||
GET DIAGNOSTICS del_count = ROW_COUNT;
|
||||
IF del_count > 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
|
||||
msg_queue_expire = msg_queue_size > del_count AND keep_min_id IS NOT NULL,
|
||||
msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN del_count;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION write_message(p_recipient_id bytea, p_msg_id bytea, p_msg_ts bigint, p_msg_quota boolean, p_msg_ntf_flag boolean, p_msg_body bytea, p_quota integer) RETURNS TABLE(quota_written boolean, was_empty boolean)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_can_write BOOLEAN;
|
||||
q_size BIGINT;
|
||||
BEGIN
|
||||
SELECT msg_can_write, msg_queue_size INTO q_can_write, q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF q_can_write OR q_size = 0 THEN
|
||||
quota_written := p_msg_quota OR q_size >= p_quota;
|
||||
was_empty := q_size = 0;
|
||||
|
||||
INSERT INTO messages(recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
|
||||
VALUES (p_recipient_id, p_msg_id, p_msg_ts, quota_written, p_msg_ntf_flag AND NOT quota_written, CASE WHEN quota_written THEN '' :: BYTEA ELSE p_msg_body END);
|
||||
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = NOT quota_written,
|
||||
msg_queue_expire = TRUE,
|
||||
msg_queue_size = msg_queue_size + 1
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
|
||||
RETURN QUERY VALUES (quota_written, was_empty);
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION try_del_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
msg RECORD;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
IF msg.msg_id = p_msg_id THEN
|
||||
DELETE FROM messages WHERE message_id = msg.message_id;
|
||||
IF FOUND THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_expire = msg_queue_size > 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
CREATE OR REPLACE FUNCTION try_del_peek_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
q_size BIGINT;
|
||||
msg RECORD;
|
||||
msg_deleted BOOLEAN;
|
||||
BEGIN
|
||||
SELECT msg_queue_size INTO q_size
|
||||
FROM msg_queues
|
||||
WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
|
||||
FOR UPDATE;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF NOT FOUND THEN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
RETURN;
|
||||
END IF;
|
||||
|
||||
IF msg.msg_id = p_msg_id THEN
|
||||
DELETE FROM messages WHERE message_id = msg.message_id;
|
||||
|
||||
msg_deleted := FOUND;
|
||||
IF msg_deleted THEN
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
|
||||
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
|
||||
INTO msg
|
||||
FROM messages
|
||||
WHERE recipient_id = p_recipient_id
|
||||
ORDER BY message_id ASC LIMIT 1;
|
||||
|
||||
IF FOUND THEN
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
IF msg_deleted THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_expire = msg_queue_size > 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
ELSIF msg_deleted OR q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
ELSE
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
END IF;
|
||||
END;
|
||||
$$;
|
||||
|
||||
DROP PROCEDURE expire_old_messages(bigint, integer);
|
||||
|
||||
CREATE PROCEDURE expire_old_messages(IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
rids BYTEA[];
|
||||
rid BYTEA;
|
||||
last_rid BYTEA := '\x';
|
||||
del_count BIGINT;
|
||||
total_deleted BIGINT := 0;
|
||||
BEGIN
|
||||
LOOP
|
||||
SELECT array_agg(recipient_id)
|
||||
INTO rids
|
||||
FROM (
|
||||
SELECT recipient_id
|
||||
FROM msg_queues
|
||||
WHERE deleted_at IS NULL
|
||||
AND msg_queue_expire = TRUE
|
||||
AND recipient_id > last_rid
|
||||
ORDER BY recipient_id ASC
|
||||
LIMIT batch_size
|
||||
) qs;
|
||||
|
||||
EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
|
||||
|
||||
FOREACH rid IN ARRAY rids
|
||||
LOOP
|
||||
BEGIN
|
||||
del_count := delete_expired_msgs(rid, p_old_ts);
|
||||
total_deleted := total_deleted + del_count;
|
||||
EXCEPTION WHEN OTHERS THEN
|
||||
RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
|
||||
CONTINUE;
|
||||
END;
|
||||
COMMIT;
|
||||
END LOOP;
|
||||
last_rid := rids[cardinality(rids)];
|
||||
END LOOP;
|
||||
|
||||
r_expired_msgs_count := total_deleted;
|
||||
r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
|
||||
r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
|
||||
END;
|
||||
$$;
|
||||
|]
|
||||
@@ -47,7 +47,6 @@ BEGIN
|
||||
IF del_count > 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
|
||||
msg_queue_expire = msg_queue_size > del_count AND keep_min_id IS NOT NULL,
|
||||
msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
@@ -63,24 +62,33 @@ CREATE PROCEDURE smp_server.expire_old_messages(IN p_old_ts bigint, IN batch_siz
|
||||
DECLARE
|
||||
rids BYTEA[];
|
||||
rid BYTEA;
|
||||
last_ts BIGINT := -1;
|
||||
last_rid BYTEA := '\x';
|
||||
next_ts BIGINT;
|
||||
next_rid BYTEA;
|
||||
del_count BIGINT;
|
||||
total_deleted BIGINT := 0;
|
||||
BEGIN
|
||||
LOOP
|
||||
SELECT array_agg(recipient_id)
|
||||
INTO rids
|
||||
-- The page is scanned in (msg_ts, recipient_id) order, so its last row is the next
|
||||
-- keyset cursor. Advancing it past every row read, including queues left unexpired
|
||||
-- because delete_expired_msgs skipped a locked row or raised, is what terminates the
|
||||
-- loop; re-reading from the start instead would repeat those queues forever.
|
||||
SELECT array_agg(DISTINCT recipient_id),
|
||||
(array_agg(msg_ts ORDER BY msg_ts DESC, recipient_id DESC))[1],
|
||||
(array_agg(recipient_id ORDER BY msg_ts DESC, recipient_id DESC))[1]
|
||||
INTO rids, next_ts, next_rid
|
||||
FROM (
|
||||
SELECT recipient_id
|
||||
FROM msg_queues
|
||||
WHERE deleted_at IS NULL
|
||||
AND msg_queue_expire = TRUE
|
||||
AND recipient_id > last_rid
|
||||
ORDER BY recipient_id ASC
|
||||
SELECT msg_ts, recipient_id
|
||||
FROM messages
|
||||
WHERE NOT msg_quota
|
||||
AND msg_ts < p_old_ts
|
||||
AND (msg_ts, recipient_id) > (last_ts, last_rid)
|
||||
ORDER BY msg_ts ASC, recipient_id ASC
|
||||
LIMIT batch_size
|
||||
) qs;
|
||||
) m;
|
||||
|
||||
EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
|
||||
EXIT WHEN rids IS NULL;
|
||||
|
||||
FOREACH rid IN ARRAY rids
|
||||
LOOP
|
||||
@@ -91,9 +99,11 @@ BEGIN
|
||||
RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
|
||||
CONTINUE;
|
||||
END;
|
||||
COMMIT;
|
||||
END LOOP;
|
||||
last_rid := rids[cardinality(rids)];
|
||||
COMMIT;
|
||||
|
||||
last_ts := next_ts;
|
||||
last_rid := next_rid;
|
||||
END LOOP;
|
||||
|
||||
r_expired_msgs_count := total_deleted;
|
||||
@@ -195,7 +205,6 @@ BEGIN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
@@ -207,7 +216,6 @@ BEGIN
|
||||
IF FOUND THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_expire = msg_queue_size > 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
|
||||
@@ -245,7 +253,6 @@ BEGIN
|
||||
IF q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
@@ -271,14 +278,12 @@ BEGIN
|
||||
IF msg_deleted THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
|
||||
msg_queue_expire = msg_queue_size > 1,
|
||||
msg_queue_size = GREATEST(msg_queue_size - 1, 0)
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
ELSIF msg_deleted OR q_size != 0 THEN
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = TRUE,
|
||||
msg_queue_expire = FALSE,
|
||||
msg_queue_size = 0
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
END IF;
|
||||
@@ -348,7 +353,6 @@ BEGIN
|
||||
|
||||
UPDATE msg_queues
|
||||
SET msg_can_write = NOT quota_written,
|
||||
msg_queue_expire = TRUE,
|
||||
msg_queue_size = msg_queue_size + 1
|
||||
WHERE recipient_id = p_recipient_id;
|
||||
|
||||
@@ -440,7 +444,6 @@ CREATE TABLE smp_server.msg_queues (
|
||||
rcv_service_id bytea,
|
||||
ntf_service_id bytea,
|
||||
msg_can_write boolean DEFAULT true NOT NULL,
|
||||
msg_queue_expire boolean DEFAULT false NOT NULL,
|
||||
msg_queue_size bigint DEFAULT 0 NOT NULL
|
||||
)
|
||||
WITH (fillfactor='80', autovacuum_vacuum_scale_factor='0.02', autovacuum_analyze_scale_factor='0.01', autovacuum_vacuum_cost_limit='1000');
|
||||
@@ -485,6 +488,10 @@ ALTER TABLE ONLY smp_server.services
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_messages_expire ON smp_server.messages USING btree (msg_ts, recipient_id) WHERE (NOT msg_quota);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_messages_recipient_id_message_id ON smp_server.messages USING btree (recipient_id, message_id);
|
||||
|
||||
|
||||
@@ -493,14 +500,6 @@ CREATE INDEX idx_messages_recipient_id_msg_quota ON smp_server.messages USING bt
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_messages_recipient_id_msg_ts ON smp_server.messages USING btree (recipient_id, msg_ts);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_msg_queues_expire ON smp_server.msg_queues USING btree (recipient_id) WHERE ((deleted_at IS NULL) AND msg_queue_expire);
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id);
|
||||
|
||||
|
||||
|
||||
@@ -173,6 +173,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
rId = recipientId sq
|
||||
qr = queueRec sq
|
||||
add q = case queueData q of
|
||||
_ | isSecuredMsgQueue q -> pure $ Left AUTH
|
||||
Nothing -> addLink
|
||||
Just (lnkId', d') | lnkId' == lnkId && fst d' == fst d -> addLink
|
||||
_ -> pure $ Left AUTH
|
||||
|
||||
@@ -128,6 +128,7 @@ data ServerStats = ServerStats
|
||||
ntfServices :: ServiceStats,
|
||||
rcvServicesSubMsg :: IORef Int,
|
||||
rcvServicesSubDuplicate :: IORef Int,
|
||||
authDelayExceeded :: IORef Int,
|
||||
qCount :: IORef Int,
|
||||
msgCount :: IORef Int,
|
||||
ntfCount :: IORef Int,
|
||||
@@ -190,6 +191,7 @@ data ServerStatsData = ServerStatsData
|
||||
_rcvServices :: ServiceStatsData,
|
||||
_rcvServicesSubMsg :: Int,
|
||||
_rcvServicesSubDuplicate :: Int,
|
||||
_authDelayExceeded :: Int,
|
||||
_qCount :: Int,
|
||||
_msgCount :: Int,
|
||||
_ntfCount :: Int,
|
||||
@@ -254,6 +256,7 @@ newServerStats ts = do
|
||||
ntfServices <- newServiceStats
|
||||
rcvServicesSubMsg <- newIORef 0
|
||||
rcvServicesSubDuplicate <- newIORef 0
|
||||
authDelayExceeded <- newIORef 0
|
||||
qCount <- newIORef 0
|
||||
msgCount <- newIORef 0
|
||||
ntfCount <- newIORef 0
|
||||
@@ -315,6 +318,7 @@ newServerStats ts = do
|
||||
ntfServices,
|
||||
rcvServicesSubMsg,
|
||||
rcvServicesSubDuplicate,
|
||||
authDelayExceeded,
|
||||
qCount,
|
||||
msgCount,
|
||||
ntfCount,
|
||||
@@ -378,6 +382,7 @@ getServerStatsData s = do
|
||||
_ntfServices <- getServiceStatsData $ ntfServices s
|
||||
_rcvServicesSubMsg <- readIORef $ rcvServicesSubMsg s
|
||||
_rcvServicesSubDuplicate <- readIORef $ rcvServicesSubDuplicate s
|
||||
_authDelayExceeded <- readIORef $ authDelayExceeded s
|
||||
_qCount <- readIORef $ qCount s
|
||||
_msgCount <- readIORef $ msgCount s
|
||||
_ntfCount <- readIORef $ ntfCount s
|
||||
@@ -439,6 +444,7 @@ getServerStatsData s = do
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg,
|
||||
_rcvServicesSubDuplicate,
|
||||
_authDelayExceeded,
|
||||
_qCount,
|
||||
_msgCount,
|
||||
_ntfCount,
|
||||
@@ -503,6 +509,7 @@ setServerStats s d = do
|
||||
setServiceStats (ntfServices s) $! _ntfServices d
|
||||
writeIORef (rcvServicesSubMsg s) $! _rcvServicesSubMsg d
|
||||
writeIORef (rcvServicesSubDuplicate s) $! _rcvServicesSubDuplicate d
|
||||
writeIORef (authDelayExceeded s) $! _authDelayExceeded d
|
||||
writeIORef (qCount s) $! _qCount d
|
||||
writeIORef (msgCount s) $! _msgCount d
|
||||
writeIORef (ntfCount s) $! _ntfCount d
|
||||
@@ -705,6 +712,7 @@ instance StrEncoding ServerStatsData where
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg = 0,
|
||||
_rcvServicesSubDuplicate = 0,
|
||||
_authDelayExceeded = 0,
|
||||
_qCount,
|
||||
_msgCount = 0,
|
||||
_ntfCount = 0,
|
||||
|
||||
@@ -46,7 +46,6 @@ module Simplex.Messaging.Transport
|
||||
minServerSMPRelayVersion,
|
||||
currentClientSMPRelayVersion,
|
||||
currentServerSMPRelayVersion,
|
||||
shortLinksSMPVersion,
|
||||
serviceCertsSMPVersion,
|
||||
newNtfCredsSMPVersion,
|
||||
clientNoticesSMPVersion,
|
||||
@@ -54,6 +53,7 @@ module Simplex.Messaging.Transport
|
||||
namesSMPVersion,
|
||||
serverInfoSMPVersion,
|
||||
nameAvailSMPVersion,
|
||||
fwdNoncesSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -177,6 +177,7 @@ smpBlockSize = 16384
|
||||
-- 20 - public namespaces resolver, RSLV command (6/20/2026)
|
||||
-- 21 - server public information in handshake (7/5/2026)
|
||||
-- 22 - RNAME answers name availability as well as the record (7/25/2026)
|
||||
-- 23 - version in forwarded command nonce, random nonce in forwarded responses (10/2/2026)
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -189,11 +190,8 @@ type VersionRangeSMP = VersionRange SMPVersion
|
||||
pattern VersionSMP :: Word16 -> VersionSMP
|
||||
pattern VersionSMP v = Version v
|
||||
|
||||
_proxyServerHandshakeSMPVersion :: VersionSMP
|
||||
_proxyServerHandshakeSMPVersion = VersionSMP 14
|
||||
|
||||
shortLinksSMPVersion :: VersionSMP
|
||||
shortLinksSMPVersion = VersionSMP 15
|
||||
_shortLinksSMPVersion :: VersionSMP
|
||||
_shortLinksSMPVersion = VersionSMP 15
|
||||
|
||||
serviceCertsSMPVersion :: VersionSMP
|
||||
serviceCertsSMPVersion = VersionSMP 16
|
||||
@@ -218,29 +216,32 @@ serverInfoSMPVersion = VersionSMP 21
|
||||
nameAvailSMPVersion :: VersionSMP
|
||||
nameAvailSMPVersion = VersionSMP 22
|
||||
|
||||
fwdNoncesSMPVersion :: VersionSMP
|
||||
fwdNoncesSMPVersion = VersionSMP 23
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 14
|
||||
minClientSMPRelayVersion = VersionSMP 15
|
||||
|
||||
minServerSMPRelayVersion :: VersionSMP
|
||||
minServerSMPRelayVersion = VersionSMP 14
|
||||
minServerSMPRelayVersion = VersionSMP 15
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 22
|
||||
currentClientSMPRelayVersion = VersionSMP 23
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 22
|
||||
currentServerSMPRelayVersion = VersionSMP 23
|
||||
|
||||
-- Max SMP protocol version to be used in e2e encrypted connection between
|
||||
-- client and server, as defined by SMP proxy. Normally set below the current
|
||||
-- version to prevent client version fingerprinting by the destination relays
|
||||
-- when clients upgrade at different times. Pinned to the current version (22)
|
||||
-- for this release because a proxied RSLV only carries availability from
|
||||
-- nameAvailSMPVersion (22), so the one-version anti-fingerprinting buffer does
|
||||
-- not apply yet; it reappears once the current version advances past 22.
|
||||
-- when clients upgrade at different times. Pinned to the current version (23)
|
||||
-- for this release because forwarded commands use the nonces from
|
||||
-- fwdNoncesSMPVersion (23), so the one-version anti-fingerprinting buffer does
|
||||
-- not apply yet; it reappears once the current version advances past 23.
|
||||
proxiedSMPRelayVersion :: VersionSMP
|
||||
proxiedSMPRelayVersion = VersionSMP 22
|
||||
proxiedSMPRelayVersion = VersionSMP 23
|
||||
|
||||
-- minimal supported protocol version is 14
|
||||
-- minimal supported protocol version is 15
|
||||
supportedClientSMPRelayVRange :: VersionRangeSMP
|
||||
supportedClientSMPRelayVRange = mkVersionRange minClientSMPRelayVersion currentClientSMPRelayVersion
|
||||
|
||||
|
||||
@@ -26,6 +26,7 @@ module Simplex.RemoteControl.Client
|
||||
-- for tests only
|
||||
sendRCPacket,
|
||||
receiveRCPacket,
|
||||
findRCCtrlPairing,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
@@ -46,7 +47,7 @@ import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Data.Tuple (swap)
|
||||
import Data.Word (Word16)
|
||||
import qualified Data.X509 as X
|
||||
@@ -395,8 +396,10 @@ findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErro
|
||||
findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
|
||||
(pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
|
||||
signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr
|
||||
inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv
|
||||
inv@(RCVerifiedInvitation RCInvitation {dh = invDh, ts}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv
|
||||
unless (invDh == dhPubKey) $ throwE RCEInvitation
|
||||
now <- systemSeconds <$> liftIO getSystemTime
|
||||
unless (now - 3660 <= systemSeconds ts && systemSeconds ts <= now + 3600) $ throwE RCEInvitation
|
||||
pure (pairing, inv)
|
||||
where
|
||||
decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
|
||||
|
||||
@@ -122,18 +122,22 @@ closeListener subscribers sock =
|
||||
joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
|
||||
joinMulticast subscribers sock group = do
|
||||
now <- atomically $ takeTMVar subscribers
|
||||
when (now == 0) $ do
|
||||
setMembership sock group True >>= \case
|
||||
Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
|
||||
Right () -> atomically $ putTMVar subscribers (now + 1)
|
||||
if now == 0
|
||||
then
|
||||
setMembership sock group True >>= \case
|
||||
Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
|
||||
Right () -> atomically $ putTMVar subscribers (now + 1)
|
||||
else atomically $ putTMVar subscribers (now + 1)
|
||||
|
||||
partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
|
||||
partMulticast subscribers sock group = do
|
||||
now <- atomically $ takeTMVar subscribers
|
||||
when (now == 1) $
|
||||
setMembership sock group False >>= \case
|
||||
Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
|
||||
Right () -> atomically $ putTMVar subscribers (now - 1)
|
||||
if now == 1
|
||||
then
|
||||
setMembership sock group False >>= \case
|
||||
Left e -> atomically (putTMVar subscribers (now - 1)) >> logError ("setMembership failed " <> tshow e)
|
||||
Right () -> atomically $ putTMVar subscribers (now - 1)
|
||||
else atomically $ putTMVar subscribers (max 0 (now - 1))
|
||||
|
||||
listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress
|
||||
listenerHostAddr4 sock = case UDP.mySockAddr sock of
|
||||
|
||||
Reference in new issue
Block a user