mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 00:44:38 +00:00
smp protocol: short links and other changes from RFC (#1489)
* smp protocol: short links types and other changes from RFC * add fields for queue link ID and data * create queue and ntf credentials with NEW command * all tests * simplfiy types, update rfc * update rfc * include SenderId in NEW request in case queue data is sent * store queue data and generate link ID if needed * update rfc * agent API and types * SMP commands and persistence for short links * SMP client functions for short links * agent client functions for short links * create rcv queue with short link (TODO secret_box) * encryption and encoding for link data, postgres client migration * test creating short link * get link and data, tests * comments * type signature
This commit is contained in:
Evgeny
+140
-28
@@ -56,6 +56,7 @@ module Simplex.Messaging.Agent
|
||||
deleteConnectionAsync,
|
||||
deleteConnectionsAsync,
|
||||
createConnection,
|
||||
getConnShortLink,
|
||||
changeConnectionUser,
|
||||
prepareConnectionToJoin,
|
||||
prepareConnectionToAccept,
|
||||
@@ -181,13 +182,14 @@ import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), Server
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.ShortLink as SL
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parse)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
@@ -340,10 +342,27 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
|
||||
{-# INLINE deleteConnectionsAsync #-}
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs
|
||||
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
|
||||
createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs
|
||||
{-# INLINE createConnection #-}
|
||||
|
||||
-- | Create or update user's contact connection short link
|
||||
-- TODO [short links]
|
||||
setConnShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact)
|
||||
setConnShortLink c = withAgentEnv c .: setConnShortLink' c
|
||||
{-# INLINE setConnShortLink #-}
|
||||
|
||||
-- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries
|
||||
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo)
|
||||
getConnShortLink c = withAgentEnv c .: getConnShortLink' c
|
||||
{-# INLINE getConnShortLink #-}
|
||||
|
||||
-- | This irreversible deletes short link data, and it won't be retrievable again
|
||||
-- TODO [short links]
|
||||
delInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE ()
|
||||
delInvShortLink c = withAgentEnv c . delInvShortLink' c
|
||||
{-# INLINE delInvShortLink #-}
|
||||
|
||||
-- | Changes the user id associated with a connection
|
||||
changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
|
||||
changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId
|
||||
@@ -776,12 +795,45 @@ switchConnectionAsync' c corrId connId =
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
|
||||
|
||||
newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
|
||||
newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do
|
||||
newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
|
||||
newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
|
||||
srv <- getSMPServer c userId
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
|
||||
pure (connId, cReq)
|
||||
(connId,) <$> newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv
|
||||
`catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e
|
||||
|
||||
setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact)
|
||||
setConnShortLink' = undefined
|
||||
|
||||
getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo)
|
||||
getConnShortLink' c userId = \case
|
||||
CSLInvitation srv linkId linkKey -> do
|
||||
g <- asks random
|
||||
invLink <- withStore' c $ \db -> do
|
||||
getInvShortLink db srv linkId >>= \case
|
||||
Just sl@InvShortLink {linkKey = lk} | linkKey == lk -> pure sl
|
||||
_ -> do
|
||||
(sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey}
|
||||
createInvShortLink db sl
|
||||
pure sl
|
||||
let k = SL.invShortLinkKdf linkKey
|
||||
secureGetQueueLink c userId invLink >>= decryptData srv linkKey k
|
||||
CSLContact srv _ linkKey -> do
|
||||
let (linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
getQueueLink c userId srv linkId >>= decryptData srv linkKey k
|
||||
where
|
||||
decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo)
|
||||
decryptData srv linkKey k (sndId, d) = do
|
||||
r <- liftEither $ SL.decryptLinkData @c linkKey k d
|
||||
checkSameQueue $ case fst r of CRInvitationUri crd _ -> crd; CRContactUri crd -> crd
|
||||
pure r
|
||||
where
|
||||
checkSameQueue ConnReqUriData {crSmpQueues = SMPQueueUri {queueAddress = SMPQueueAddress srv' sndId' _ _} :| _} =
|
||||
unless (srv == srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address"
|
||||
|
||||
delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM ()
|
||||
delInvShortLink' = undefined
|
||||
|
||||
changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
|
||||
changeConnectionUser' c oldUserId connId newUserId = do
|
||||
@@ -793,28 +845,86 @@ changeConnectionUser' c oldUserId connId newUserId = do
|
||||
where
|
||||
updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
|
||||
|
||||
newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
newRcvConnSrv :: ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode =
|
||||
fmap fst .:: newRcvConnSrv_ c userId connId enableNtfs cMode Nothing
|
||||
{-# INLINE newRcvConnSrv #-}
|
||||
|
||||
newRcvConnSrv_ :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c))
|
||||
newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
case (cMode, pqInitKeys) of
|
||||
(SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
|
||||
_ -> pure ()
|
||||
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
let sndSecure = case cMode of SCMInvitation -> True; SCMContact -> False
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode sndSecure `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
|
||||
case cMode of
|
||||
SCMContact -> pure $ CRContactUri crData
|
||||
SCMInvitation -> do
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
case userData_ of
|
||||
Just d -> do
|
||||
(nonce, qUri, cReq, qd) <- prepareLinkData d $ fst e2eKeys
|
||||
(rq, qUri') <- createRcvQueue (Just nonce) qd e2eKeys
|
||||
connReqWithShortLink qUri cReq qUri' (shortLink rq)
|
||||
Nothing -> do
|
||||
let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing
|
||||
(_, qUri) <- createRcvQueue Nothing qd e2eKeys
|
||||
(,Nothing) <$> createConnReq qUri
|
||||
where
|
||||
createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
|
||||
createRcvQueue nonce_ qd e2eKeys = do
|
||||
AgentConfig {smpClientVRange = vr} <- asks config
|
||||
let ntfCreds_ = Nothing -- TODO [short links]
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode ntfCreds_ nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
pure (rq', qUri)
|
||||
createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c)
|
||||
createConnReq qUri = do
|
||||
AgentConfig {smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
|
||||
case cMode of
|
||||
SCMContact -> pure $ CRContactUri crData
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
prepareLinkData :: ConnInfo -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
|
||||
prepareLinkData userData e2eDhKey = do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
|
||||
sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g
|
||||
AgentConfig {smpClientVRange = vr, smpAgentVRange = agentVRange} <- asks config
|
||||
let sndId = SMP.EntityId $ C.sha3_256 corrId
|
||||
sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True
|
||||
qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure
|
||||
connReq <- createConnReq qUri
|
||||
let (linkKey, linkData) = SL.encodeSignLinkData sigKeys agentVRange connReq userData
|
||||
qd <- case cMode of
|
||||
SCMContact -> do
|
||||
let (linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
srvData <- liftIO $ SL.encryptLinkData g k linkData
|
||||
pure $ CQRContact $ Just CQRData {linkKey, privSigKey, srvReq = (linkId, (sndId, srvData))}
|
||||
SCMInvitation -> do
|
||||
let k = SL.invShortLinkKdf linkKey
|
||||
srvData <- liftIO $ SL.encryptLinkData g k linkData
|
||||
pure $ CQRMessaging $ Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)}
|
||||
pure (nonce, qUri, connReq, qd)
|
||||
connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c))
|
||||
connReqWithShortLink qUri cReq qUri' shortLink = case shortLink of
|
||||
Just ShortLinkCreds {shortLinkId, shortLinkKey}
|
||||
| qUri == qUri' ->
|
||||
let link = case cReq of
|
||||
CRContactUri _ -> CSLContact srv CCTContact shortLinkKey
|
||||
CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey
|
||||
in pure (cReq, Just link)
|
||||
| otherwise -> throwE $ INTERNAL "different rcv queue address"
|
||||
Nothing ->
|
||||
let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData)
|
||||
cReq' = case cReq of
|
||||
CRContactUri crData -> CRContactUri (updated crData)
|
||||
CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams
|
||||
in pure (cReq', Nothing)
|
||||
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
|
||||
@@ -842,6 +952,7 @@ newConnToAccept c connId enableNtfs invId pqSup = do
|
||||
newConnToJoin c userId connId enableNtfs connReq pqSup
|
||||
_ -> throwE $ CMD PROHIBITED "newConnToAccept"
|
||||
|
||||
-- TODO [short link] joining queue that was already secured with LKEY
|
||||
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
|
||||
joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
|
||||
srv <- getNextSMPServer c userId [qServer cReqQueue]
|
||||
@@ -958,8 +1069,8 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode
|
||||
|
||||
createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo
|
||||
createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
|
||||
let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure
|
||||
-- TODO [short links] ntf credentials
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode Nothing
|
||||
atomically $ incSMPServerStat c userId (qServer rq) connCreated
|
||||
let qInfo = toVersionT qUri smpClientVersion
|
||||
rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
|
||||
@@ -1727,7 +1838,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False
|
||||
-- TODO [short links] send correct NTF credentials here
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe Nothing
|
||||
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
lift $ addNewQueueSubscription c rq'' tSess sessId
|
||||
|
||||
@@ -26,6 +26,8 @@ module Simplex.Messaging.Agent.Client
|
||||
( AgentClient (..),
|
||||
ProtocolTestFailure (..),
|
||||
ProtocolTestStep (..),
|
||||
ClntQueueReqData (..),
|
||||
CQRData (..),
|
||||
newAgentClient,
|
||||
withConnLock,
|
||||
withConnLocks,
|
||||
@@ -43,6 +45,7 @@ module Simplex.Messaging.Agent.Client
|
||||
runNTFServerTest,
|
||||
getXFTPWorkPath,
|
||||
newRcvQueue,
|
||||
newRcvQueue_,
|
||||
subscribeQueues,
|
||||
getQueueMessage,
|
||||
decryptSMPMessage,
|
||||
@@ -57,6 +60,10 @@ module Simplex.Messaging.Agent.Client
|
||||
serverHostError,
|
||||
secureQueue,
|
||||
secureSndQueue,
|
||||
addQueueLink,
|
||||
deleteQueueLink,
|
||||
secureGetQueueLink,
|
||||
getQueueLink,
|
||||
enableQueueNotifications,
|
||||
EnableQueueNtfReq (..),
|
||||
enableQueuesNtfs,
|
||||
@@ -256,22 +263,25 @@ import Simplex.Messaging.Protocol
|
||||
RcvNtfPublicDhKey,
|
||||
SMPMsgMeta (..),
|
||||
SProtocolType (..),
|
||||
SenderCanSecure,
|
||||
SndPublicAuthKey,
|
||||
SubscriptionMode (..),
|
||||
QueueReqData (..),
|
||||
QueueLinkData,
|
||||
NewNtfCreds,
|
||||
UserProtocol,
|
||||
VersionRangeSMPC,
|
||||
VersionSMPC,
|
||||
XFTPServer,
|
||||
XFTPServerWithAuth,
|
||||
pattern NoEntity,
|
||||
senderCanSecure,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId), TransportError (..))
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
@@ -1076,9 +1086,24 @@ sendOrProxySMPCommand ::
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO ()) ->
|
||||
AM (Maybe SMPServer)
|
||||
sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
|
||||
sendOrProxySMPCommand c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly =
|
||||
fst <$> sendOrProxySMPCommand_ c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly
|
||||
{-# INLINE sendOrProxySMPCommand #-}
|
||||
|
||||
sendOrProxySMPCommand_ ::
|
||||
forall a.
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
SMPServer ->
|
||||
ConnId -> -- session entity ID, for short links LinkId is used
|
||||
ByteString ->
|
||||
SMP.EntityId -> -- sender or link ID
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO a) ->
|
||||
AM (Maybe SMPServer, a)
|
||||
sendOrProxySMPCommand_ c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do
|
||||
tSess <- mkTransportSession c userId destSrv connId
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess)
|
||||
where
|
||||
shouldUseProxy = do
|
||||
cfg <- getNetworkConfig c
|
||||
@@ -1096,13 +1121,13 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
SPFAllowProtected -> ipAddressProtected cfg destSrv
|
||||
SPFProhibit -> False
|
||||
unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a)
|
||||
sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
|
||||
let proxySrv = protocolClientServer' smp
|
||||
case r' of
|
||||
Right () -> pure $ Just proxySrv
|
||||
Right r -> pure (Just proxySrv, r)
|
||||
Left proxyErr -> do
|
||||
case proxyErr of
|
||||
ProxyProtocolError (SMP.PROXY SMP.NO_SESSION) -> do
|
||||
@@ -1136,18 +1161,17 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp')
|
||||
sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
|
||||
case r of
|
||||
Right r' -> do
|
||||
Right r'@(srv_, _) -> do
|
||||
atomically $ incSMPServerStat c userId destSrv sentViaProxy
|
||||
forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
|
||||
forM_ srv_ $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
|
||||
pure r'
|
||||
Left e
|
||||
| serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e)
|
||||
| serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
|
||||
| otherwise -> throwE e
|
||||
sendDirectly tSess =
|
||||
withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
|
||||
case r of
|
||||
Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
|
||||
withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
tryAgentError (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case
|
||||
Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect)
|
||||
Left e -> throwE e
|
||||
|
||||
ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
|
||||
@@ -1222,11 +1246,11 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
r <- runExceptT $ do
|
||||
SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing
|
||||
liftError (testErr TSSecureQueue) $
|
||||
if sndSecure
|
||||
then secureSndSMPQueue smp spKey sndId sKey
|
||||
else secureSMPQueue smp rpKey rcvId sKey
|
||||
case queueMode of
|
||||
Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey
|
||||
_ -> secureSMPQueue smp rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
|
||||
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
@@ -1333,19 +1357,42 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
|
||||
getSessionMode = fmap sessionMode . getNetworkConfig
|
||||
{-# INLINE getSessionMode #-}
|
||||
|
||||
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do
|
||||
-- TODO [short links] add ntf credentials to RcvQueue
|
||||
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> Maybe NewNtfCreds -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c userId connId srv vRange cMode subMode ntfCreds = do
|
||||
let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
newRcvQueue_ c userId connId srv vRange qrd subMode ntfCreds Nothing e2eKeys
|
||||
|
||||
data ClntQueueReqData
|
||||
= CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
|
||||
| CQRContact (Maybe (CQRData (SMP.LinkId, (SMP.SenderId, QueueLinkData))))
|
||||
|
||||
data CQRData r = CQRData
|
||||
{ linkKey :: LinkKey,
|
||||
privSigKey :: C.PrivateKeyEd25519,
|
||||
srvReq :: r
|
||||
}
|
||||
|
||||
queueReqData :: ClntQueueReqData -> QueueReqData
|
||||
queueReqData = \case
|
||||
CQRMessaging d -> QRMessaging $ srvReq <$> d
|
||||
CQRContact d -> QRContact $ srvReq <$> d
|
||||
|
||||
newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe NewNtfCreds -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode ntfCreds nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
C.AuthAlg a <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
(e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
|
||||
logServer "-->" c srv NoEntity "NEW"
|
||||
tSess <- mkTransportSession c userId srv connId
|
||||
(sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <-
|
||||
-- TODO [short links] serverNtfCreds
|
||||
r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serverNtfCreds}) <-
|
||||
withClient c tSess $ \(SMPConnectedClient smp _) ->
|
||||
(sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure
|
||||
(thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
shortLink <- mkShortLinkCreds r
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ userId,
|
||||
@@ -1358,17 +1405,47 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender
|
||||
e2eDhSecret = Nothing,
|
||||
sndId,
|
||||
sndSecure,
|
||||
shortLink,
|
||||
status = New,
|
||||
dbQueueId = DBNewQueue,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
rcvSwchStatus = Nothing,
|
||||
smpClientVersion = maxVersion vRange,
|
||||
clientNtfCreds = Nothing,
|
||||
clientNtfCreds = Nothing, -- TODO [short links]
|
||||
deleteErrors = 0
|
||||
}
|
||||
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure
|
||||
pure (rq, qUri, tSess, sessId)
|
||||
-- TODO [short links] maybe switch to queue mode?
|
||||
sndSecure = senderCanSecure queueMode
|
||||
pure (rq, qUri, tSess, sessionId thParams')
|
||||
where
|
||||
mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds (thParams', QIK {sndId, queueMode, linkId}) = case (cqrd, queueMode) of
|
||||
(CQRMessaging ld, Just QMMessaging) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
|
||||
if sndId == sndId'
|
||||
then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d)
|
||||
else newErr "different sender ID"
|
||||
(CQRContact ld, Just QMContact) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (lnkId', (sndId', d))} ->
|
||||
if sndId == sndId' && lnkId == lnkId'
|
||||
then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d)
|
||||
else newErr "different sender or link IDs"
|
||||
(_, Nothing) -> case linkId of
|
||||
Nothing | v < sndAuthKeySMPVersion -> pure 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)
|
||||
newErr = throwE . BROKER (B.unpack $ strEncode srv) . UNEXPECTED . ("Create queue: " <>)
|
||||
|
||||
processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError () -> STM ()
|
||||
processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
|
||||
@@ -1611,6 +1688,28 @@ secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPubl
|
||||
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
|
||||
secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey
|
||||
|
||||
addQueueLink :: AgentClient -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
|
||||
addQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
|
||||
withSMPClient c rq "LSET" $ \smp -> addSMPQueueLink smp rcvPrivateKey rcvId lnkId d
|
||||
|
||||
deleteQueueLink :: AgentClient -> RcvQueue -> AM ()
|
||||
deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId
|
||||
|
||||
secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
|
||||
secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
|
||||
snd <$> sendOrProxySMPCommand_ c userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
|
||||
where
|
||||
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey
|
||||
secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey
|
||||
|
||||
getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
|
||||
getQueueLink c userId server lnkId =
|
||||
snd <$> sendOrProxySMPCommand_ c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly
|
||||
where
|
||||
getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId
|
||||
getDirectly smp = getSMPQueueLink smp lnkId
|
||||
|
||||
enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
|
||||
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
|
||||
withSMPClient c rq "NKEY <nkey>" $ \smp ->
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -108,6 +110,11 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnReqUriData (..),
|
||||
CRClientData,
|
||||
ServiceScheme,
|
||||
FixedLinkData (..),
|
||||
UserLinkData (..),
|
||||
ConnShortLink (..),
|
||||
ContactConnType (..),
|
||||
LinkKey (..),
|
||||
sameConnReqContact,
|
||||
simplexChat,
|
||||
connReqUriP',
|
||||
@@ -151,8 +158,10 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isDigit)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
@@ -1042,6 +1051,11 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
|
||||
<> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
|
||||
strP = connReqUriP' (Just SSSimplex)
|
||||
|
||||
-- TODO [short links] do not use StrEncoding instance
|
||||
instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where
|
||||
smpEncode = smpEncode . Large . strEncode
|
||||
smpP = strDecode . unLarge <$?> smpP
|
||||
|
||||
connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m)
|
||||
connReqUriP' overrideScheme = do
|
||||
ACR m cr <- connReqUriP overrideScheme
|
||||
@@ -1188,7 +1202,7 @@ data SMPQueueAddress = SMPQueueAddress
|
||||
{ smpServer :: SMPServer,
|
||||
senderId :: SMP.SenderId,
|
||||
dhPublicKey :: C.PublicKeyX25519,
|
||||
sndSecure :: Bool
|
||||
sndSecure :: Bool -- TODO [short links] replace with queueMode?
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -1271,6 +1285,65 @@ instance Eq AConnectionRequestUri where
|
||||
|
||||
deriving instance Show AConnectionRequestUri
|
||||
|
||||
data ConnShortLink (m :: ConnectionMode) where
|
||||
CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation
|
||||
CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact
|
||||
|
||||
deriving instance Show (ConnShortLink m)
|
||||
|
||||
newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (FromField, StrEncoding)
|
||||
|
||||
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
|
||||
|
||||
data ContactConnType = CCTContact | CCTGroup deriving (Show)
|
||||
|
||||
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
|
||||
|
||||
-- TODO [short link] parser, parsing tests
|
||||
data AConnectionLink = ACLFull AConnectionRequestUri | ACLShort AConnShortLink
|
||||
|
||||
instance ConnectionModeI m => StrEncoding (ConnShortLink m) where
|
||||
strEncode = \case
|
||||
CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i"
|
||||
CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g"
|
||||
where
|
||||
encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType =
|
||||
"https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> B64.encodeUnpadded kh <> "@" <> hosts <> B64.encodeUnpadded linkUri
|
||||
where
|
||||
port' = if null port then "" else B.pack (':' : port)
|
||||
hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/"
|
||||
strP = do
|
||||
ACSL m l <- strP
|
||||
case testEquality m $ sConnectionMode @m of
|
||||
Just Refl -> pure l
|
||||
_ -> fail "bad short link mode"
|
||||
|
||||
instance StrEncoding AConnShortLink where
|
||||
strEncode (ACSL _ l) = strEncode l
|
||||
strP = do
|
||||
h <- "https://" *> strP
|
||||
port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure ""
|
||||
linkType <- A.char '/' *> A.anyChar
|
||||
keyHash <- optional (A.char '/') *> A.char '#' *> strP <* A.char '@'
|
||||
TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ [])
|
||||
linkUri <- strP
|
||||
let srv = SMPServer (h :| hs) port keyHash
|
||||
case linkType of
|
||||
'i'
|
||||
| B.length linkUri == 56 ->
|
||||
let (lnkId, k) = B.splitAt 24 linkUri
|
||||
in pure $ ACSL SCMInvitation $ CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k)
|
||||
| otherwise -> fail "bad ConnShortLink: incorrect linkID and key length"
|
||||
'c' -> contactP srv CCTContact linkUri
|
||||
'g' -> contactP srv CCTGroup linkUri
|
||||
_ -> fail "bad ConnShortLink: unknown link type"
|
||||
where
|
||||
contactP srv ct k
|
||||
| B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k)
|
||||
| otherwise = fail "bad ConnShortLink: incorrect key length"
|
||||
|
||||
sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
|
||||
sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
|
||||
L.length qs == L.length qs' && all same (L.zip qs qs')
|
||||
@@ -1287,6 +1360,31 @@ data ConnReqUriData = ConnReqUriData
|
||||
|
||||
type CRClientData = Text
|
||||
|
||||
data FixedLinkData c = FixedLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
sigKey :: C.PublicKeyEd25519,
|
||||
connReq :: ConnectionRequestUri c
|
||||
}
|
||||
|
||||
data UserLinkData = UserLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
userData :: ConnInfo
|
||||
}
|
||||
|
||||
instance ConnectionModeI c => Encoding (FixedLinkData c) where
|
||||
smpEncode FixedLinkData {agentVRange, sigKey, connReq} =
|
||||
smpEncode (agentVRange, sigKey, connReq)
|
||||
smpP = do
|
||||
(agentVRange, sigKey, connReq) <- smpP
|
||||
pure FixedLinkData {agentVRange, sigKey, connReq}
|
||||
|
||||
instance Encoding UserLinkData where
|
||||
smpEncode UserLinkData {agentVRange, userData} =
|
||||
smpEncode (agentVRange, Large userData)
|
||||
smpP = do
|
||||
(agentVRange, Large userData) <- smpP
|
||||
pure UserLinkData {agentVRange, userData}
|
||||
|
||||
-- | SMP queue status.
|
||||
data QueueStatus
|
||||
= -- | queue is created
|
||||
@@ -1419,6 +1517,8 @@ data SMPAgentError
|
||||
A_PROHIBITED {prohibitedErr :: String}
|
||||
| -- | incompatible version of SMP client, agent or encryption protocols
|
||||
A_VERSION
|
||||
| -- | failed signature, hash or senderId verification of retrieved link data
|
||||
A_LINK {linkErr :: String}
|
||||
| -- | cannot decrypt message
|
||||
A_CRYPTO {cryptoErr :: AgentCryptoError}
|
||||
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
|
||||
|
||||
@@ -93,6 +93,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
|
||||
sndId :: SMP.SenderId,
|
||||
-- | sender can secure the queue
|
||||
sndSecure :: SenderCanSecure,
|
||||
-- | short link ID and credentials
|
||||
shortLink :: Maybe ShortLinkCreds,
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
@@ -110,6 +112,14 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ShortLinkCreds = ShortLinkCreds
|
||||
{ shortLinkId :: SMP.LinkId,
|
||||
shortLinkKey :: LinkKey,
|
||||
linkPrivSigKey :: C.PrivateKeyEd25519,
|
||||
linkEncFixedData :: SMP.EncFixedDataBytes
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
|
||||
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
|
||||
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
|
||||
@@ -137,6 +147,18 @@ data ClientNtfCreds = ClientNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- This record is stored in inv_short_links table.
|
||||
-- It is needed only for 1-time invitation links because of "secure-on-read" property of link data,
|
||||
-- that prevents undetected access to link data from link observers.
|
||||
data InvShortLink = InvShortLink
|
||||
{ server :: SMPServer,
|
||||
linkId :: SMP.LinkId,
|
||||
linkKey :: LinkKey,
|
||||
sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries
|
||||
sndPublicKey :: SndPublicAuthKey
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type SndQueue = StoredSndQueue 'QSStored
|
||||
|
||||
type NewSndQueue = StoredSndQueue 'QSNew
|
||||
|
||||
@@ -58,6 +58,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
getRcvQueueById,
|
||||
getSndQueueById,
|
||||
deleteConn,
|
||||
deleteConnRecord,
|
||||
upgradeRcvConnToDuplex,
|
||||
upgradeSndConnToDuplex,
|
||||
addConnRcvQueue,
|
||||
@@ -88,6 +89,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
acceptInvitation,
|
||||
unacceptInvitation,
|
||||
deleteInvitation,
|
||||
getInvShortLink,
|
||||
createInvShortLink,
|
||||
-- Messages
|
||||
updateRcvIds,
|
||||
createRcvMsg,
|
||||
@@ -410,6 +413,9 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup
|
||||
|]
|
||||
(userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True)
|
||||
|
||||
deleteConnRecord :: DB.Connection -> ConnId -> IO ()
|
||||
deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId)
|
||||
|
||||
checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
|
||||
checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
|
||||
fromMaybe False
|
||||
@@ -442,7 +448,7 @@ deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of
|
||||
(pure Nothing)
|
||||
)
|
||||
where
|
||||
delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId
|
||||
delete = deleteConnRecord db connId $> Just connId
|
||||
checkNoPendingDeliveries_ = do
|
||||
r :: (Maybe Int64) <-
|
||||
maybeFirstRow fromOnly $
|
||||
@@ -756,6 +762,40 @@ deleteInvitation db contactConnId invId =
|
||||
Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
|
||||
getInvShortLink db server linkId =
|
||||
maybeFirstRow toInvShortLink $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT link_key, snd_private_key
|
||||
FROM inv_short_links
|
||||
WHERE host = ? AND port = ? AND link_id = ?
|
||||
|]
|
||||
(host server, port server, linkId)
|
||||
where
|
||||
toInvShortLink :: (LinkKey, C.APrivateAuthKey) -> InvShortLink
|
||||
toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk)) =
|
||||
let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk
|
||||
in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey}
|
||||
|
||||
createInvShortLink :: DB.Connection -> InvShortLink -> IO ()
|
||||
createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey} = do
|
||||
serverKeyHash_ <- createServer_ db server
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO inv_short_links
|
||||
(host, port, server_key_hash, link_id, link_key, snd_private_key)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
ON CONFLICT (host, port, link_id)
|
||||
DO UPDATE SET
|
||||
server_key_hash = EXCLUDED.server_key_hash,
|
||||
link_key = EXCLUDED.link_key,
|
||||
snd_private_key = EXCLUDED.snd_private_key
|
||||
|]
|
||||
(host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey)
|
||||
|
||||
updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
|
||||
updateRcvIds db connId = do
|
||||
(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId
|
||||
@@ -1884,9 +1924,15 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO rcv_queues
|
||||
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
|
||||
snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
|
||||
link_id, link_key, link_priv_sig_key, link_enc_fixed_data
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
|
||||
( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
|
||||
:. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
|
||||
:. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
|
||||
)
|
||||
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
|
||||
|
||||
-- * createSndConn helpers
|
||||
@@ -2054,7 +2100,8 @@ rcvQueueQuery =
|
||||
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
|
||||
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
|
||||
q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
@@ -2063,15 +2110,24 @@ rcvQueueQuery =
|
||||
toRcvQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt)
|
||||
:. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret)
|
||||
:. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) ->
|
||||
RcvQueue
|
||||
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
|
||||
toRcvQueue
|
||||
( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure)
|
||||
:. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
|
||||
:. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)
|
||||
:. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_)
|
||||
) =
|
||||
let server = SMPServer host port keyHash
|
||||
smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_
|
||||
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
_ -> Nothing
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
|
||||
(Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
|
||||
_ -> Nothing
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
|
||||
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById db connId dbRcvId =
|
||||
|
||||
@@ -6,12 +6,14 @@ import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
schemaMigrations =
|
||||
[ ("20241210_initial", m20241210_initial, Nothing),
|
||||
("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
|
||||
("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20250322_short_links :: Text
|
||||
m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BYTEA;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BYTEA,
|
||||
link_id BYTEA NOT NULL,
|
||||
link_key BYTEA NOT NULL,
|
||||
snd_private_key BYTEA NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Text
|
||||
down_m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|]
|
||||
@@ -42,6 +42,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_d
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -83,7 +84,8 @@ schemaMigrations =
|
||||
("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
|
||||
("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
|
||||
("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
|
||||
("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
|
||||
("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20250322_short_links :: Query
|
||||
m20250322_short_links =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BLOB;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Query
|
||||
down_m20250322_short_links =
|
||||
[sql|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|]
|
||||
@@ -57,6 +57,10 @@ CREATE TABLE rcv_queues(
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
snd_secure INTEGER NOT NULL DEFAULT 0,
|
||||
last_broker_ts TEXT,
|
||||
link_id BLOB,
|
||||
link_key BLOB,
|
||||
link_priv_sig_key BLOB,
|
||||
link_enc_fixed_data BLOB,
|
||||
PRIMARY KEY(host, port, rcv_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE,
|
||||
@@ -422,6 +426,16 @@ CREATE TABLE snd_message_bodies(
|
||||
snd_message_body_id INTEGER PRIMARY KEY,
|
||||
agent_msg BLOB NOT NULL DEFAULT x''
|
||||
);
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
|
||||
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
|
||||
@@ -551,3 +565,9 @@ CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
|
||||
CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(
|
||||
snd_message_body_id
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(
|
||||
host,
|
||||
port,
|
||||
link_id
|
||||
);
|
||||
|
||||
@@ -49,6 +49,12 @@ module Simplex.Messaging.Client
|
||||
secureSMPQueue,
|
||||
secureSndSMPQueue,
|
||||
proxySecureSndSMPQueue,
|
||||
addSMPQueueLink,
|
||||
deleteSMPQueueLink,
|
||||
secureGetSMPQueueLink,
|
||||
proxySecureGetSMPQueueLink,
|
||||
getSMPQueueLink,
|
||||
proxyGetSMPQueueLink,
|
||||
enableSMPQueueNotifications,
|
||||
disableSMPQueueNotifications,
|
||||
enableSMPQueuesNtfs,
|
||||
@@ -706,14 +712,16 @@ smpProxyError = \case
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
|
||||
createSMPQueue ::
|
||||
SMPClient ->
|
||||
Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
|
||||
C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
|
||||
RcvPublicDhKey ->
|
||||
Maybe BasicAuth ->
|
||||
SubscriptionMode ->
|
||||
Bool ->
|
||||
QueueReqData ->
|
||||
Maybe NewNtfCreds ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
|
||||
sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
|
||||
createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
|
||||
sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -799,9 +807,47 @@ secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey
|
||||
{-# INLINE secureSndSMPQueue #-}
|
||||
|
||||
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
{-# INLINE proxySecureSndSMPQueue #-}
|
||||
|
||||
-- | Add or update date for queue link
|
||||
addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
|
||||
addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId
|
||||
{-# INLINE addSMPQueueLink #-}
|
||||
|
||||
-- | Delete queue link
|
||||
deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueueLink = okSMPCommand LDEL
|
||||
{-# INLINE deleteSMPQueueLink #-}
|
||||
|
||||
-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
|
||||
secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
secureGetSMPQueueLink c spKey lnkId senderKey =
|
||||
sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey =
|
||||
proxySMPCommand c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Get contact address SMP queue link data.
|
||||
getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
getSMPQueueLink c lnkId =
|
||||
sendSMPCommand c Nothing lnkId LGET >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxyGetSMPQueueLink c proxiedRelay lnkId =
|
||||
proxySMPCommand c proxiedRelay Nothing lnkId LGET >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Enable notifications for the queue for push notifications server.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
|
||||
@@ -843,7 +889,7 @@ sendSMPMessage c spKey sId flags msg =
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg)
|
||||
proxySMPMessage c proxiedRelay spKey sId flags msg = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg)
|
||||
|
||||
-- | Acknowledge message delivery (server deletes the message).
|
||||
--
|
||||
@@ -955,15 +1001,24 @@ instance StrEncoding ProxyClientError where
|
||||
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
|
||||
|
||||
-- This function proxies Sender commands that return OK or ERR
|
||||
proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxyOKSMPCommand c proxiedRelay spKey sId command =
|
||||
proxySMPCommand c proxiedRelay spKey sId command >>= \case
|
||||
Right OK -> pure $ Right ()
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
proxySMPCommand ::
|
||||
forall p.
|
||||
PartyI p =>
|
||||
SMPClient ->
|
||||
-- proxy session from PKEY
|
||||
ProxiedRelay ->
|
||||
-- message to deliver
|
||||
Maybe SndPrivateAuthKey ->
|
||||
SenderId ->
|
||||
Command 'Sender ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
Command p ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
-- prepare params
|
||||
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
|
||||
@@ -972,7 +1027,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
let cmdSecret = C.dh' serverKey cmdPrivKey
|
||||
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
|
||||
-- encode
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
|
||||
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
|
||||
b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
|
||||
[] -> throwE $ PCETransportError TELargeMsg
|
||||
@@ -990,9 +1045,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
case tParse serverThParams t' of
|
||||
t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
|
||||
(_auth, _signed, (_c, _e, cmd)) -> case cmd of
|
||||
Right OK -> pure $ Right ()
|
||||
Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
|
||||
Right r' -> throwE $ unexpectedResponse r'
|
||||
Right r' -> pure $ Right r'
|
||||
Left e -> throwE $ PCEResponseError e
|
||||
_ -> throwE $ PCETransportError TEBadBlock
|
||||
ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
|
||||
@@ -1101,6 +1155,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
|
||||
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
|
||||
-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does.
|
||||
-- But a better solution is to process delayed delete responses.
|
||||
--
|
||||
-- Please note: if nonce is passed it is also used as a correlation ID
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
|
||||
|
||||
@@ -142,6 +142,8 @@ module Simplex.Messaging.Crypto
|
||||
cbDecryptNoPad,
|
||||
sbDecrypt_,
|
||||
sbEncrypt_,
|
||||
sbEncryptNoPad,
|
||||
sbDecryptNoPad,
|
||||
cbNonce,
|
||||
randomCbNonce,
|
||||
reverseNonce,
|
||||
@@ -160,6 +162,7 @@ module Simplex.Messaging.Crypto
|
||||
SbKeyNonce,
|
||||
sbcInit,
|
||||
sbcHkdf,
|
||||
hkdf,
|
||||
|
||||
-- * pseudo-random bytes
|
||||
randomBytes,
|
||||
@@ -167,6 +170,7 @@ module Simplex.Messaging.Crypto
|
||||
-- * digests
|
||||
sha256Hash,
|
||||
sha512Hash,
|
||||
sha3_256,
|
||||
|
||||
-- * Message padding / un-padding
|
||||
canPad,
|
||||
@@ -207,7 +211,7 @@ import Crypto.Cipher.AES (AES256)
|
||||
import qualified Crypto.Cipher.Types as AES
|
||||
import qualified Crypto.Cipher.XSalsa as XSalsa
|
||||
import qualified Crypto.Error as CE
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA3_256, SHA512 (..), hash, hashDigestSize)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import qualified Crypto.MAC.Poly1305 as Poly1305
|
||||
import qualified Crypto.PubKey.Curve25519 as X25519
|
||||
@@ -887,6 +891,7 @@ x448_size = 448 `quot` 8
|
||||
validSignatureSize :: Int -> Bool
|
||||
validSignatureSize n =
|
||||
n == Ed25519.signatureSize || n == Ed448.signatureSize
|
||||
{-# INLINE validSignatureSize #-}
|
||||
|
||||
-- | AES key newtype.
|
||||
newtype Key = Key {unKey :: ByteString}
|
||||
@@ -961,10 +966,17 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
|
||||
-- | SHA256 digest.
|
||||
sha256Hash :: ByteString -> ByteString
|
||||
sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
|
||||
{-# INLINE sha256Hash #-}
|
||||
|
||||
-- | SHA512 digest.
|
||||
sha512Hash :: ByteString -> ByteString
|
||||
sha512Hash = BA.convert . (hash :: ByteString -> Digest SHA512)
|
||||
{-# INLINE sha512Hash #-}
|
||||
|
||||
-- | SHA3-256 digest.
|
||||
sha3_256 :: ByteString -> ByteString
|
||||
sha3_256 = BA.convert . (hash :: ByteString -> Digest SHA3_256)
|
||||
{-# INLINE sha3_256 #-}
|
||||
|
||||
-- | AEAD-GCM encryption with associated data.
|
||||
--
|
||||
@@ -981,6 +993,7 @@ encryptAEAD aesKey ivBytes paddedLen ad msg = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAESNoPad key iv = encryptAEADNoPad key iv ""
|
||||
{-# INLINE encryptAESNoPad #-}
|
||||
|
||||
encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAEADNoPad aesKey ivBytes ad msg = do
|
||||
@@ -1002,6 +1015,7 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
decryptAESNoPad :: Key -> GCMIV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAESNoPad key iv = decryptAEADNoPad key iv ""
|
||||
{-# INLINE decryptAESNoPad #-}
|
||||
|
||||
decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
|
||||
@@ -1054,6 +1068,7 @@ maxLenBS s
|
||||
|
||||
unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
|
||||
unsafeMaxLenBS = MLBS
|
||||
{-# INLINE unsafeMaxLenBS #-}
|
||||
|
||||
padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
|
||||
padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
|
||||
@@ -1066,6 +1081,7 @@ appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
|
||||
|
||||
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
|
||||
@@ -1086,12 +1102,15 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
|
||||
-- | Random AES256 key.
|
||||
randomAesKey :: TVar ChaChaDRG -> STM Key
|
||||
randomAesKey = fmap Key . randomBytes aesKeySize
|
||||
{-# INLINE randomAesKey #-}
|
||||
|
||||
randomGCMIV :: TVar ChaChaDRG -> STM GCMIV
|
||||
randomGCMIV = fmap GCMIV . randomBytes gcmIVSize
|
||||
{-# INLINE randomGCMIV #-}
|
||||
|
||||
ivSize :: forall c. AES.BlockCipher c => Int
|
||||
ivSize = AES.blockSize (undefined :: c)
|
||||
{-# INLINE ivSize #-}
|
||||
|
||||
gcmIVSize :: Int
|
||||
gcmIVSize = 12
|
||||
@@ -1101,6 +1120,7 @@ makeIV bs = maybeError CryptoIVError $ AES.makeIV bs
|
||||
|
||||
maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a
|
||||
maybeError e = maybe (throwE e) return
|
||||
{-# INLINE maybeError #-}
|
||||
|
||||
cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a
|
||||
cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
@@ -1111,12 +1131,15 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
|
||||
sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
|
||||
sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
|
||||
{-# INLINE sign' #-}
|
||||
|
||||
sign :: APrivateSignKey -> ByteString -> ASignature
|
||||
sign (APrivateSignKey a k) = ASignature a . sign' k
|
||||
{-# INLINE sign #-}
|
||||
|
||||
signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
|
||||
signCertificate = signX509
|
||||
{-# INLINE signCertificate #-}
|
||||
|
||||
signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
|
||||
signX509 key = fst . objectToSignedExact f
|
||||
@@ -1141,6 +1164,7 @@ verifyX509 key exact = do
|
||||
|
||||
certificateFingerprint :: SignedCertificate -> KeyHash
|
||||
certificateFingerprint = signedFingerprint
|
||||
{-# INLINE certificateFingerprint #-}
|
||||
|
||||
signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
|
||||
signedFingerprint o = KeyHash fp
|
||||
@@ -1154,16 +1178,20 @@ instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
|
||||
signatureAlgorithmX509 = \case
|
||||
SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
|
||||
SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
instance SignatureAlgorithmX509 APrivateSignKey where
|
||||
signatureAlgorithmX509 (APrivateSignKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
instance SignatureAlgorithmX509 APublicVerifyKey where
|
||||
signatureAlgorithmX509 (APublicVerifyKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | An instance for 'ASignatureKeyPair' / ('PublicKeyType' pk, pk), without touching its type family.
|
||||
instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
|
||||
signatureAlgorithmX509 = signatureAlgorithmX509 . snd
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | A wrapper to marshall signed ASN1 objects, like certificates.
|
||||
newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
|
||||
@@ -1198,6 +1226,7 @@ certChainP = do
|
||||
verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool
|
||||
verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig
|
||||
verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig
|
||||
{-# INLINE verify' #-}
|
||||
|
||||
verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool
|
||||
verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of
|
||||
@@ -1207,25 +1236,35 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
|
||||
dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
|
||||
dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
|
||||
dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
|
||||
{-# INLINE dh' #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
|
||||
cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret
|
||||
{-# INLINE cbEncrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding).
|
||||
cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString
|
||||
cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce
|
||||
{-# INLINE cbEncryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt (SbKey key) = sbEncrypt_ key
|
||||
{-# INLINE sbEncrypt #-}
|
||||
|
||||
sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt_ secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
|
||||
{-# INLINE sbEncrypt_ #-}
|
||||
|
||||
sbEncryptNoPad :: SbKey -> CbNonce -> ByteString -> ByteString
|
||||
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
|
||||
{-# INLINE cbEncryptMaxLenBS #-}
|
||||
|
||||
cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
|
||||
cryptoBox secret nonce s = BA.convert tag <> c
|
||||
@@ -1236,18 +1275,26 @@ cryptoBox secret nonce s = BA.convert tag <> 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
|
||||
{-# INLINE cbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret
|
||||
{-# INLINE cbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt (SbKey key) = sbDecrypt_ key
|
||||
{-# INLINE sbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
|
||||
sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce
|
||||
{-# INLINE sbDecrypt_ #-}
|
||||
|
||||
sbDecryptNoPad :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecryptNoPad (SbKey key) = sbDecryptNoPad_ key
|
||||
{-# INLINE sbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
@@ -1356,20 +1403,23 @@ newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
|
||||
sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
|
||||
sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
|
||||
where
|
||||
prk = H.extract salt secret :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
|
||||
(ck1, ck2) = B.splitAt 32 out
|
||||
(ck1, ck2) = B.splitAt 32 $ hkdf salt secret "SimpleXSbChainInit" 64
|
||||
|
||||
type SbKeyNonce = (SbKey, CbNonce)
|
||||
|
||||
sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
|
||||
sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
|
||||
where
|
||||
prk = H.extract B.empty ck :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
out = hkdf "" ck "SimpleXSbChain" 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
(ck', rest) = B.splitAt 32 out
|
||||
(sk, nonce) = B.splitAt 32 rest
|
||||
|
||||
hkdf :: ByteArrayAccess secret => ByteString -> secret -> ByteString -> Int -> ByteString
|
||||
hkdf salt ikm info n =
|
||||
let prk = H.extract salt ikm :: H.PRK SHA512
|
||||
in H.expand prk info n
|
||||
{-# INLINE hkdf #-}
|
||||
|
||||
xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
|
||||
xSalsa20 secret nonce msg = (rs, msg')
|
||||
where
|
||||
|
||||
@@ -94,8 +94,6 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Cipher.AES (AES256)
|
||||
import Crypto.Hash (SHA512)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
@@ -1130,8 +1128,7 @@ chainKdf (RatchetKey ck) =
|
||||
hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
|
||||
hkdf3 salt ikm info = (s1, s2, s3)
|
||||
where
|
||||
prk = H.extract salt ikm :: H.PRK SHA512
|
||||
out = H.expand prk info 96
|
||||
out = hkdf salt ikm info 96
|
||||
(s1, rest) = B.splitAt 32 out
|
||||
(s2, s3) = B.splitAt 32 rest
|
||||
|
||||
|
||||
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.ShortLink where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Simplex.Messaging.Agent.Client (cryptoError)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Protocol (EntityId (..), LinkId, EncDataBytes (..), QueueLinkData)
|
||||
|
||||
contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey)
|
||||
contactShortLinkKdf (LinkKey k) =
|
||||
let (lnkId, sbKey) = B.splitAt 24 $ C.hkdf "" k "SimpleXContactLink" 56
|
||||
in (EntityId lnkId, C.unsafeSbKey sbKey)
|
||||
|
||||
invShortLinkKdf :: LinkKey -> C.SbKey
|
||||
invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
|
||||
|
||||
encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
|
||||
encodeSignLinkData (sigKey, pk) agentVRange connReq userData =
|
||||
let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq}
|
||||
ud = smpEncode UserLinkData {agentVRange, userData}
|
||||
in (LinkKey (C.sha3_256 fd), (sign fd, sign ud))
|
||||
where
|
||||
sign s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s
|
||||
|
||||
-- TODO [short links] possibly use padded encryption for fixed and for user data
|
||||
encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> IO QueueLinkData
|
||||
encryptLinkData g k = bimapM encrypt encrypt
|
||||
where
|
||||
encrypt s = do
|
||||
nonce <- atomically $ C.randomCbNonce g
|
||||
pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s
|
||||
|
||||
decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo)
|
||||
decryptLinkData linkKey k (encFD, encUD) = do
|
||||
(sig1, fd) <- decrypt encFD
|
||||
(sig2, ud) <- decrypt encUD
|
||||
FixedLinkData {sigKey, connReq} <- decode fd
|
||||
UserLinkData {userData} <- decode ud
|
||||
if
|
||||
| LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash"
|
||||
| not (C.verify' sigKey sig1 fd) -> linkErr "link data signature"
|
||||
| not (C.verify' sigKey sig2 ud) -> linkErr "user data signature"
|
||||
| otherwise -> Right (connReq, userData)
|
||||
where
|
||||
decrypt (EncDataBytes d) = do
|
||||
(nonce, Tail ct) <- decode d
|
||||
(sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecryptNoPad k nonce ct)
|
||||
(,s) <$> msgErr (C.decodeSignature sigBytes)
|
||||
decode :: Encoding a => ByteString -> Either AgentErrorType a
|
||||
decode = msgErr . smpDecode
|
||||
msgErr = first (const $ AGENT A_MESSAGE)
|
||||
linkErr = Left . AGENT . A_LINK
|
||||
@@ -58,6 +58,14 @@ module Simplex.Messaging.Protocol
|
||||
Command (..),
|
||||
SubscriptionMode (..),
|
||||
SenderCanSecure,
|
||||
NewQueueReq (..),
|
||||
QueueReqData (..),
|
||||
QueueMode (..),
|
||||
QueueLinkData,
|
||||
EncFixedDataBytes,
|
||||
EncUserDataBytes,
|
||||
EncDataBytes (..),
|
||||
NewNtfCreds (..),
|
||||
Party (..),
|
||||
Cmd (..),
|
||||
DirectParty,
|
||||
@@ -65,6 +73,7 @@ module Simplex.Messaging.Protocol
|
||||
SParty (..),
|
||||
PartyI (..),
|
||||
QueueIdsKeys (..),
|
||||
ServerNtfCreds (..),
|
||||
ProtocolErrorType (..),
|
||||
ErrorType (..),
|
||||
CommandError (..),
|
||||
@@ -108,6 +117,7 @@ module Simplex.Messaging.Protocol
|
||||
QueueId,
|
||||
RecipientId,
|
||||
SenderId,
|
||||
LinkId,
|
||||
NotifierId,
|
||||
RcvPrivateAuthKey,
|
||||
RcvPublicAuthKey,
|
||||
@@ -140,6 +150,8 @@ module Simplex.Messaging.Protocol
|
||||
MsgFlags (..),
|
||||
initialSMPClientVersion,
|
||||
currentSMPClientVersion,
|
||||
senderCanSecure,
|
||||
queueReqMode,
|
||||
userProtocol,
|
||||
rcvMessageMeta,
|
||||
noMsgFlags,
|
||||
@@ -215,6 +227,7 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
|
||||
import qualified GHC.TypeLits as TE
|
||||
import qualified GHC.TypeLits as Type
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
@@ -281,7 +294,7 @@ e2eEncMessageLength :: Int
|
||||
e2eEncMessageLength = 16000 -- 15988 .. 16005
|
||||
|
||||
-- | SMP protocol clients
|
||||
data Party = Recipient | Sender | Notifier | ProxiedClient
|
||||
data Party = Recipient | Sender | Notifier | LinkClient | ProxiedClient
|
||||
deriving (Show)
|
||||
|
||||
-- | Singleton types for SMP protocol clients
|
||||
@@ -289,12 +302,14 @@ data SParty :: Party -> Type where
|
||||
SRecipient :: SParty Recipient
|
||||
SSender :: SParty Sender
|
||||
SNotifier :: SParty Notifier
|
||||
SLinkClient :: SParty LinkClient
|
||||
SProxiedClient :: SParty ProxiedClient
|
||||
|
||||
instance TestEquality SParty where
|
||||
testEquality SRecipient SRecipient = Just Refl
|
||||
testEquality SSender SSender = Just Refl
|
||||
testEquality SNotifier SNotifier = Just Refl
|
||||
testEquality SLinkClient SLinkClient = Just Refl
|
||||
testEquality SProxiedClient SProxiedClient = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
@@ -308,12 +323,15 @@ instance PartyI Sender where sParty = SSender
|
||||
|
||||
instance PartyI Notifier where sParty = SNotifier
|
||||
|
||||
instance PartyI LinkClient where sParty = SLinkClient
|
||||
|
||||
instance PartyI ProxiedClient where sParty = SProxiedClient
|
||||
|
||||
type family DirectParty (p :: Party) :: Constraint where
|
||||
DirectParty Recipient = ()
|
||||
DirectParty Sender = ()
|
||||
DirectParty Notifier = ()
|
||||
DirectParty LinkClient = ()
|
||||
DirectParty p =
|
||||
(Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not direct"))
|
||||
|
||||
@@ -377,6 +395,8 @@ type SenderId = QueueId
|
||||
-- | SMP queue ID for notifications.
|
||||
type NotifierId = QueueId
|
||||
|
||||
type LinkId = QueueId
|
||||
|
||||
-- | SMP queue ID on the server.
|
||||
type QueueId = EntityId
|
||||
|
||||
@@ -395,9 +415,11 @@ data Command (p :: Party) where
|
||||
-- v6 of SMP servers only support signature algorithm for command authorization.
|
||||
-- v7 of SMP servers additionally support additional layer of authenticated encryption.
|
||||
-- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys.
|
||||
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
|
||||
NEW :: NewQueueReq -> Command Recipient
|
||||
SUB :: Command Recipient
|
||||
KEY :: SndPublicAuthKey -> Command Recipient
|
||||
LSET :: LinkId -> QueueLinkData -> Command Recipient
|
||||
LDEL :: Command Recipient
|
||||
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
|
||||
NDEL :: Command Recipient
|
||||
GET :: Command Recipient
|
||||
@@ -411,6 +433,9 @@ data Command (p :: Party) where
|
||||
-- SEND :: MsgBody -> Command Sender
|
||||
SEND :: MsgFlags -> MsgBody -> Command Sender
|
||||
PING :: Command Sender
|
||||
-- Client accessing short links
|
||||
LKEY :: SndPublicAuthKey -> Command LinkClient
|
||||
LGET :: Command LinkClient
|
||||
-- SMP notification subscriber commands
|
||||
NSUB :: Command Notifier
|
||||
PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
|
||||
@@ -427,9 +452,58 @@ data Command (p :: Party) where
|
||||
|
||||
deriving instance Show (Command p)
|
||||
|
||||
data NewQueueReq = NewQueueReq
|
||||
{ rcvAuthKey :: RcvPublicAuthKey,
|
||||
rcvDhKey :: RcvPublicDhKey,
|
||||
auth_ :: Maybe BasicAuth,
|
||||
subMode :: SubscriptionMode,
|
||||
queueReqData :: Maybe QueueReqData,
|
||||
ntfCreds :: Maybe NewNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data SubscriptionMode = SMSubscribe | SMOnlyCreate
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- SenderId must be computed client-side as `sha3-256(corr_id)`, `corr_id` - a random transmission ID.
|
||||
-- The server must verify and reject it if it does not match (and in case of collision).
|
||||
-- This allows to include SenderId in FixedDataBytes in full connection request,
|
||||
-- and at the same time prevents the possibility of checking whether a queue with a known ID exists.
|
||||
data QueueReqData = QRMessaging (Maybe (SenderId, QueueLinkData)) | QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
|
||||
deriving (Show)
|
||||
|
||||
queueReqMode :: QueueReqData -> QueueMode
|
||||
queueReqMode = \case
|
||||
QRMessaging _ -> QMMessaging
|
||||
QRContact _ -> QMContact
|
||||
|
||||
senderCanSecure :: Maybe QueueMode -> Bool
|
||||
senderCanSecure = \case
|
||||
Just QMMessaging -> True
|
||||
_ -> False
|
||||
|
||||
type QueueLinkData = (EncFixedDataBytes, EncUserDataBytes)
|
||||
|
||||
type EncFixedDataBytes = EncDataBytes
|
||||
|
||||
type EncUserDataBytes = EncDataBytes
|
||||
|
||||
newtype EncDataBytes = EncDataBytes ByteString
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (FromField, StrEncoding)
|
||||
|
||||
instance Encoding EncDataBytes where
|
||||
smpEncode (EncDataBytes s) = smpEncode (Large s)
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = EncDataBytes . unLarge <$> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance ToField EncDataBytes where
|
||||
toField (EncDataBytes s) = toField (Binary s)
|
||||
{-# INLINE toField #-}
|
||||
|
||||
data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
|
||||
|
||||
instance StrEncoding SubscriptionMode where
|
||||
strEncode = \case
|
||||
SMSubscribe -> "subscribe"
|
||||
@@ -449,6 +523,20 @@ instance Encoding SubscriptionMode where
|
||||
'C' -> pure SMOnlyCreate
|
||||
_ -> fail "bad SubscriptionMode"
|
||||
|
||||
instance Encoding QueueReqData where
|
||||
smpEncode = \case
|
||||
QRMessaging d -> smpEncode ('M', d)
|
||||
QRContact d -> smpEncode ('C', d)
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'M' -> QRMessaging <$> smpP
|
||||
'C' -> QRContact <$> smpP
|
||||
_ -> fail "bad QueueReqData"
|
||||
|
||||
instance Encoding NewNtfCreds where
|
||||
smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
|
||||
smpP = NewNtfCreds <$> smpP <*> smpP
|
||||
|
||||
type SenderCanSecure = Bool
|
||||
|
||||
newtype EncTransmission = EncTransmission ByteString
|
||||
@@ -474,6 +562,7 @@ newtype EncFwdTransmission = EncFwdTransmission ByteString
|
||||
data BrokerMsg where
|
||||
-- SMP broker messages (responses, client messages, notifications)
|
||||
IDS :: QueueIdsKeys -> BrokerMsg
|
||||
LNK :: SenderId -> QueueLinkData -> BrokerMsg
|
||||
-- MSG v1/2 has to be supported for encoding/decoding
|
||||
-- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
|
||||
-- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
|
||||
@@ -679,6 +768,8 @@ data CommandTag (p :: Party) where
|
||||
NEW_ :: CommandTag Recipient
|
||||
SUB_ :: CommandTag Recipient
|
||||
KEY_ :: CommandTag Recipient
|
||||
LSET_ :: CommandTag Recipient
|
||||
LDEL_ :: CommandTag Recipient
|
||||
NKEY_ :: CommandTag Recipient
|
||||
NDEL_ :: CommandTag Recipient
|
||||
GET_ :: CommandTag Recipient
|
||||
@@ -689,6 +780,8 @@ data CommandTag (p :: Party) where
|
||||
SKEY_ :: CommandTag Sender
|
||||
SEND_ :: CommandTag Sender
|
||||
PING_ :: CommandTag Sender
|
||||
LKEY_ :: CommandTag LinkClient
|
||||
LGET_ :: CommandTag LinkClient
|
||||
PRXY_ :: CommandTag ProxiedClient
|
||||
PFWD_ :: CommandTag ProxiedClient
|
||||
RFWD_ :: CommandTag Sender
|
||||
@@ -702,6 +795,7 @@ deriving instance Show CmdTag
|
||||
|
||||
data BrokerMsgTag
|
||||
= IDS_
|
||||
| LNK_
|
||||
| MSG_
|
||||
| NID_
|
||||
| NMSG_
|
||||
@@ -729,6 +823,8 @@ instance PartyI p => Encoding (CommandTag p) where
|
||||
NEW_ -> "NEW"
|
||||
SUB_ -> "SUB"
|
||||
KEY_ -> "KEY"
|
||||
LSET_ -> "LSET"
|
||||
LDEL_ -> "LDEL"
|
||||
NKEY_ -> "NKEY"
|
||||
NDEL_ -> "NDEL"
|
||||
GET_ -> "GET"
|
||||
@@ -739,6 +835,8 @@ instance PartyI p => Encoding (CommandTag p) where
|
||||
SKEY_ -> "SKEY"
|
||||
SEND_ -> "SEND"
|
||||
PING_ -> "PING"
|
||||
LKEY_ -> "LKEY"
|
||||
LGET_ -> "LGET"
|
||||
PRXY_ -> "PRXY"
|
||||
PFWD_ -> "PFWD"
|
||||
RFWD_ -> "RFWD"
|
||||
@@ -750,6 +848,8 @@ instance ProtocolMsgTag CmdTag where
|
||||
"NEW" -> Just $ CT SRecipient NEW_
|
||||
"SUB" -> Just $ CT SRecipient SUB_
|
||||
"KEY" -> Just $ CT SRecipient KEY_
|
||||
"LSET" -> Just $ CT SRecipient LSET_
|
||||
"LDEL" -> Just $ CT SRecipient LDEL_
|
||||
"NKEY" -> Just $ CT SRecipient NKEY_
|
||||
"NDEL" -> Just $ CT SRecipient NDEL_
|
||||
"GET" -> Just $ CT SRecipient GET_
|
||||
@@ -760,6 +860,8 @@ instance ProtocolMsgTag CmdTag where
|
||||
"SKEY" -> Just $ CT SSender SKEY_
|
||||
"SEND" -> Just $ CT SSender SEND_
|
||||
"PING" -> Just $ CT SSender PING_
|
||||
"LKEY" -> Just $ CT SLinkClient LKEY_
|
||||
"LGET" -> Just $ CT SLinkClient LGET_
|
||||
"PRXY" -> Just $ CT SProxiedClient PRXY_
|
||||
"PFWD" -> Just $ CT SProxiedClient PFWD_
|
||||
"RFWD" -> Just $ CT SSender RFWD_
|
||||
@@ -776,6 +878,7 @@ instance PartyI p => ProtocolMsgTag (CommandTag p) where
|
||||
instance Encoding BrokerMsgTag where
|
||||
smpEncode = \case
|
||||
IDS_ -> "IDS"
|
||||
LNK_ -> "LNK"
|
||||
MSG_ -> "MSG"
|
||||
NID_ -> "NID"
|
||||
NMSG_ -> "NMSG"
|
||||
@@ -793,6 +896,7 @@ instance Encoding BrokerMsgTag where
|
||||
instance ProtocolMsgTag BrokerMsgTag where
|
||||
decodeTag = \case
|
||||
"IDS" -> Just IDS_
|
||||
"LNK" -> Just LNK_
|
||||
"MSG" -> Just MSG_
|
||||
"NID" -> Just NID_
|
||||
"NMSG" -> Just NMSG_
|
||||
@@ -1138,10 +1242,19 @@ data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId,
|
||||
sndId :: SenderId,
|
||||
rcvPublicDhKey :: RcvPublicDhKey,
|
||||
sndSecure :: SenderCanSecure
|
||||
queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
|
||||
linkId :: Maybe LinkId,
|
||||
serverNtfCreds :: Maybe ServerNtfCreds
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding ServerNtfCreds where
|
||||
smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
|
||||
smpP = ServerNtfCreds <$> smpP <*> smpP
|
||||
|
||||
-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
|
||||
--
|
||||
-- Only used by SMP agent, kept here so its definition is close to respective public key.
|
||||
@@ -1368,14 +1481,17 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -
|
||||
instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
type Tag (Command p) = CommandTag p
|
||||
encodeProtocol v = \case
|
||||
NEW rKey dhKey auth_ subMode sndSecure
|
||||
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure)
|
||||
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
| v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
|
||||
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
|
||||
| otherwise -> new <> auth <> e subMode
|
||||
where
|
||||
new = e (NEW_, ' ', rKey, dhKey)
|
||||
auth = maybe "" (e . ('A',)) auth_
|
||||
SUB -> e SUB_
|
||||
KEY k -> e (KEY_, ' ', k)
|
||||
LSET lnkId d -> e (LSET_, ' ', lnkId, d)
|
||||
LDEL -> e LDEL_
|
||||
NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
|
||||
NDEL -> e NDEL_
|
||||
GET -> e GET_
|
||||
@@ -1387,6 +1503,8 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
|
||||
PING -> e PING_
|
||||
NSUB -> e NSUB_
|
||||
LKEY k -> e (LKEY_, ' ', k)
|
||||
LGET -> e LGET_
|
||||
PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
|
||||
PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
|
||||
RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
|
||||
@@ -1409,15 +1527,10 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
SEND {}
|
||||
| B.null entId -> Left $ CMD NO_ENTITY
|
||||
| otherwise -> Right cmd
|
||||
SKEY _
|
||||
| isNothing auth || B.null entId -> Left $ CMD NO_AUTH
|
||||
| otherwise -> Right cmd
|
||||
LGET -> entityCmd
|
||||
PING -> noAuthCmd
|
||||
PRXY {} -> noAuthCmd
|
||||
PFWD {}
|
||||
| B.null entId -> Left $ CMD NO_ENTITY
|
||||
| isNothing auth -> Right cmd
|
||||
| otherwise -> Left $ CMD HAS_AUTH
|
||||
PFWD {} -> entityCmd
|
||||
RFWD _ -> noAuthCmd
|
||||
-- other client commands must have both signature and queue ID
|
||||
_
|
||||
@@ -1429,6 +1542,11 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
noAuthCmd
|
||||
| isNothing auth && B.null entId = Right cmd
|
||||
| otherwise = Left $ CMD HAS_AUTH
|
||||
entityCmd :: Either ErrorType (Command p)
|
||||
entityCmd
|
||||
| B.null entId = Left $ CMD NO_ENTITY
|
||||
| isNothing auth = Right cmd
|
||||
| otherwise = Left $ CMD HAS_AUTH
|
||||
|
||||
instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
type Tag Cmd = CmdTag
|
||||
@@ -1438,13 +1556,24 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
CT SRecipient tag ->
|
||||
Cmd SRecipient <$> case tag of
|
||||
NEW_
|
||||
| v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP
|
||||
| otherwise -> new <*> auth <*> smpP <*> pure False
|
||||
| v >= shortLinksSMPVersion -> NEW <$> new smpP smpP smpP
|
||||
| v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP) (pure Nothing)
|
||||
| otherwise -> NEW <$> new auth (pure Nothing) (pure Nothing)
|
||||
where
|
||||
new = NEW <$> _smpP <*> smpP
|
||||
new p1 p2 p3 = do
|
||||
rcvAuthKey <- _smpP
|
||||
rcvDhKey <- smpP
|
||||
auth_ <- p1
|
||||
subMode <- smpP
|
||||
queueReqData <- p2
|
||||
ntfCreds <- p3
|
||||
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
auth = optional (A.char 'A' *> smpP)
|
||||
qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
|
||||
SUB_ -> pure SUB
|
||||
KEY_ -> KEY <$> _smpP
|
||||
LSET_ -> LSET <$> _smpP <*> smpP
|
||||
LDEL_ -> pure LDEL
|
||||
NKEY_ -> NKEY <$> _smpP <*> smpP
|
||||
NDEL_ -> pure NDEL
|
||||
GET_ -> pure GET
|
||||
@@ -1458,6 +1587,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
|
||||
PING_ -> pure PING
|
||||
RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
|
||||
CT SLinkClient tag ->
|
||||
Cmd SLinkClient <$> case tag of
|
||||
LKEY_ -> LKEY <$> _smpP
|
||||
LGET_ -> pure LGET
|
||||
CT SProxiedClient tag ->
|
||||
Cmd SProxiedClient <$> case tag of
|
||||
PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP)
|
||||
@@ -1472,11 +1605,13 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
type Tag BrokerMsg = BrokerMsgTag
|
||||
encodeProtocol v = \case
|
||||
IDS (QIK rcvId sndId srvDh sndSecure)
|
||||
| v >= sndAuthKeySMPVersion -> ids <> e sndSecure
|
||||
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serverNtfCreds}
|
||||
| v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId <> e serverNtfCreds
|
||||
| v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
|
||||
| otherwise -> ids
|
||||
where
|
||||
ids = e (IDS_, ' ', rcvId, sndId, srvDh)
|
||||
LNK sId d -> e (LNK_, ' ', sId, d)
|
||||
MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
|
||||
e (MSG_, ' ', msgId, Tail body)
|
||||
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
|
||||
@@ -1505,10 +1640,14 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
where
|
||||
bodyP = EncRcvMsgBody . unTail <$> smpP
|
||||
IDS_
|
||||
| v >= sndAuthKeySMPVersion -> ids smpP
|
||||
| otherwise -> ids $ pure False
|
||||
| v >= shortLinksSMPVersion -> ids smpP smpP smpP
|
||||
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
|
||||
| otherwise -> ids nothing nothing nothing
|
||||
where
|
||||
ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p)
|
||||
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
nothing = pure Nothing
|
||||
ids p1 p2 p3 = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p1 <*> p2 <*> p3)
|
||||
LNK_ -> LNK <$> _smpP <*> smpP
|
||||
NID_ -> NID <$> _smpP <*> smpP
|
||||
NMSG_ -> NMSG <$> _smpP <*> smpP
|
||||
PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP))
|
||||
|
||||
+103
-70
@@ -849,8 +849,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
q <- liftIO $ getQueueRec st SSender sId
|
||||
liftIO $ hPutStrLn h $ case q of
|
||||
Left e -> "error: " <> show e
|
||||
Right (_, QueueRec {sndSecure, status, updatedAt}) ->
|
||||
"status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure
|
||||
Right (_, QueueRec {queueMode, status, updatedAt}) ->
|
||||
"status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", queueMode: " <> show queueMode
|
||||
CPBlock sId info -> withUserRole $ unliftIO u $ do
|
||||
AMS _ _ (st :: s) <- asks msgStore
|
||||
r <- liftIO $ runExceptT $ do
|
||||
@@ -1060,13 +1060,15 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail
|
||||
verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s)
|
||||
verifyTransmission ms auth_ tAuth authorized queueId cmd =
|
||||
case cmd of
|
||||
Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
|
||||
Cmd SRecipient (NEW NewQueueReq {rcvAuthKey = k}) -> pure $ Nothing `verifiedWith` k
|
||||
Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey (snd q)) <$> get SRecipient
|
||||
-- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command
|
||||
Cmd SSender (SKEY k) -> verifyQueue (\q -> if maybe True (k ==) (senderKey $ snd q) then Just q `verifiedWith` k else dummyVerify) <$> get SSender
|
||||
Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey $ snd q)) <$> get SSender
|
||||
Cmd SSender (SKEY k) -> verifySecure SSender k
|
||||
-- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command
|
||||
Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender
|
||||
Cmd SSender PING -> pure $ VRVerified Nothing
|
||||
Cmd SSender RFWD {} -> pure $ VRVerified Nothing
|
||||
Cmd SLinkClient (LKEY k) -> verifySecure SLinkClient k
|
||||
Cmd SLinkClient LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SLinkClient
|
||||
-- NSUB will not be accepted without authorization
|
||||
Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier
|
||||
Cmd SProxiedClient _ -> pure $ VRVerified Nothing
|
||||
@@ -1075,9 +1077,16 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd =
|
||||
dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed
|
||||
verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s) -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s
|
||||
verifyQueue = either (const dummyVerify)
|
||||
verified q cond = if cond then VRVerified q else VRFailed
|
||||
verifySecure :: DirectParty p => SParty p -> SndPublicAuthKey -> M (VerificationResult s)
|
||||
verifySecure p k = verifyQueue (\q -> if k `allowedKey` snd q then Just q `verifiedWith` k else dummyVerify) <$> get p
|
||||
verifiedWith :: Maybe (StoreQueue s, QueueRec) -> C.APublicAuthKey -> VerificationResult s
|
||||
verifiedWith q k = q `verified` verify k
|
||||
verifiedWith q_ k = if verify k then VRVerified q_ else VRFailed
|
||||
allowedKey k = \case
|
||||
QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey
|
||||
_ -> False
|
||||
isContact = \case
|
||||
QueueRec {queueMode = Just QMContact} -> True
|
||||
_ -> False
|
||||
get :: DirectParty p => SParty p -> M (Either ErrorType (StoreQueue s, QueueRec))
|
||||
get party = liftIO $ getQueueRec ms party queueId
|
||||
|
||||
@@ -1233,84 +1242,106 @@ client
|
||||
processCommand clntVersion (q_, (corrId, entId, cmd)) = case cmd of
|
||||
Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
|
||||
Cmd SSender command -> Just <$> case command of
|
||||
SKEY sKey ->
|
||||
withQueue $ \q QueueRec {sndSecure} ->
|
||||
(corrId,entId,) <$> if sndSecure then secureQueue_ q sKey else pure $ ERR AUTH
|
||||
SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k
|
||||
SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody
|
||||
PING -> pure (corrId, NoEntity, PONG)
|
||||
RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
|
||||
Cmd SLinkClient command -> Just <$> case command of
|
||||
LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
|
||||
LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr
|
||||
Cmd SNotifier NSUB -> Just <$> subscribeNotifications
|
||||
Cmd SRecipient command ->
|
||||
Just <$> case command of
|
||||
NEW rKey dhKey auth subMode sndSecure ->
|
||||
ifM
|
||||
allowNew
|
||||
(createQueue rKey dhKey subMode sndSecure)
|
||||
(pure (corrId, entId, ERR AUTH))
|
||||
-- TODO [short links] idempotent NEW
|
||||
NEW nqr@NewQueueReq {auth_} ->
|
||||
ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
|
||||
where
|
||||
allowNew = do
|
||||
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
|
||||
pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
|
||||
pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth
|
||||
SUB -> withQueue subscribeQueue
|
||||
GET -> withQueue getMessage
|
||||
ACK msgId -> withQueue $ acknowledgeMsg msgId
|
||||
KEY sKey -> withQueue $ \q _ -> (corrId,entId,) <$> secureQueue_ q sKey
|
||||
KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey
|
||||
LSET lnkId d ->
|
||||
withQueue $ \q qr -> checkMode QMContact qr $ liftIO $
|
||||
OK <$$ addQueueLinkData (queueStore ms) q lnkId d
|
||||
LDEL ->
|
||||
withQueue $ \q _ -> liftIO $ (corrId,entId,) . either ERR (const OK) <$>
|
||||
deleteQueueLinkData (queueStore ms) q
|
||||
NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey
|
||||
NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q
|
||||
OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_
|
||||
DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_
|
||||
QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr
|
||||
where
|
||||
createQueue :: RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg)
|
||||
createQueue recipientKey dhKey subMode sndSecure = time "NEW" $ do
|
||||
(rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
createQueue :: NewQueueReq -> M (Transmission BrokerMsg)
|
||||
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds} = time "NEW" $ do
|
||||
g <- asks random
|
||||
idSize <- asks $ queueIdBytes . config
|
||||
updatedAt <- Just <$> liftIO getSystemDate
|
||||
let rcvDhSecret = C.dh' dhKey privDhKey
|
||||
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}
|
||||
qRec senderId =
|
||||
QueueRec
|
||||
{ senderId,
|
||||
recipientKey,
|
||||
rcvDhSecret,
|
||||
senderKey = Nothing,
|
||||
notifier = Nothing,
|
||||
status = EntityActive,
|
||||
sndSecure,
|
||||
updatedAt
|
||||
}
|
||||
(corrId,entId,) <$> addQueueRetry 3 qik qRec
|
||||
where
|
||||
addQueueRetry ::
|
||||
Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> (SenderId -> QueueRec) -> M BrokerMsg
|
||||
addQueueRetry 0 _ _ = pure $ ERR INTERNAL
|
||||
addQueueRetry n qik qRec = do
|
||||
ids@(rId, sId) <- getIds
|
||||
let qr = qRec sId
|
||||
liftIO (addQueue ms rId qr) >>= \case
|
||||
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
|
||||
Left e -> pure $ ERR e
|
||||
Right q -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qCreated stats
|
||||
incStat $ qCount stats
|
||||
case subMode of
|
||||
SMOnlyCreate -> pure ()
|
||||
SMSubscribe -> void $ subscribeQueue q qr
|
||||
pure $ IDS (qik ids)
|
||||
(rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
|
||||
(ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
|
||||
let randId = EntityId <$> atomically (C.randomBytes idSize g)
|
||||
tryCreate 0 = pure $ ERR INTERNAL
|
||||
tryCreate n = do
|
||||
(sndId, clntIds, queueData) <- case queueReqData of
|
||||
Just (QRMessaging (Just (sId, d))) -> (\linkId -> (sId, True, Just (linkId, d))) <$> randId
|
||||
Just (QRContact (Just (linkId, (sId, d)))) -> pure (sId, True, Just (linkId, d))
|
||||
_ -> (,False,Nothing) <$> randId
|
||||
-- The condition that client-provided sender ID must match hash of correlation ID
|
||||
-- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check
|
||||
-- if queue with this ID still exists.
|
||||
if clntIds && unEntityId sndId /= C.sha3_256 (bs corrId)
|
||||
then pure $ ERR $ CMD PROHIBITED
|
||||
else do
|
||||
rcvId <- randId
|
||||
ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
|
||||
notifierId <- randId
|
||||
pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey)
|
||||
let queueMode = queueReqMode <$> queueReqData
|
||||
qr =
|
||||
QueueRec
|
||||
{ senderId = sndId,
|
||||
recipientKey = rcvAuthKey,
|
||||
rcvDhSecret = C.dh' rcvDhKey privDhKey,
|
||||
senderKey = Nothing,
|
||||
queueMode,
|
||||
queueData,
|
||||
notifier = fst <$> ntf,
|
||||
status = EntityActive,
|
||||
updatedAt
|
||||
}
|
||||
liftIO (addQueue ms rcvId qr) >>= \case
|
||||
Left DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied?
|
||||
| clntIds -> pure $ ERR AUTH -- no retry on collision if sender ID is client-supplied
|
||||
| otherwise -> tryCreate (n - 1)
|
||||
Left e -> pure $ ERR e
|
||||
Right q -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qCreated stats
|
||||
incStat $ qCount stats
|
||||
when (isJust ntf) $ incStat $ ntfCreated stats
|
||||
case subMode of
|
||||
SMOnlyCreate -> pure ()
|
||||
SMSubscribe -> void $ subscribeQueue q qr
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serverNtfCreds = snd <$> ntf}
|
||||
(corrId,entId,) <$> tryCreate (3 :: Int)
|
||||
|
||||
getIds :: M (RecipientId, SenderId)
|
||||
getIds = do
|
||||
n <- asks $ queueIdBytes . config
|
||||
liftM2 (,) (randomId n) (randomId n)
|
||||
checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg)
|
||||
checkMode qm QueueRec {queueMode} a =
|
||||
(corrId,entId,) . either ERR id
|
||||
<$> if queueMode == Just qm then a else pure $ Left AUTH
|
||||
|
||||
secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M BrokerMsg
|
||||
secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M (Either ErrorType BrokerMsg)
|
||||
secureQueue_ q sKey = do
|
||||
liftIO (secureQueue (queueStore ms) q sKey) >>= \case
|
||||
Left e -> pure $ ERR e
|
||||
Right () -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qSecured stats
|
||||
pure OK
|
||||
liftIO (secureQueue (queueStore ms) q sKey)
|
||||
$>> (asks serverStats >>= incStat . qSecured) $> Right OK
|
||||
|
||||
getQueueLink_ :: StoreQueue s -> QueueRec -> M (Either ErrorType BrokerMsg)
|
||||
getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId
|
||||
|
||||
addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg)
|
||||
addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do
|
||||
@@ -1617,7 +1648,7 @@ client
|
||||
pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta}
|
||||
|
||||
processForwardedCommand :: EncFwdTransmission -> M BrokerMsg
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR RRES) . runExceptT $ do
|
||||
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
|
||||
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
|
||||
let proxyNonce = C.cbNonce $ bs corrId
|
||||
@@ -1652,7 +1683,7 @@ client
|
||||
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
|
||||
stats <- asks serverStats
|
||||
incStat $ pMsgFwdsRecv stats
|
||||
pure $ RRES r3
|
||||
pure r3
|
||||
where
|
||||
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe (StoreQueue s, QueueRec), Transmission Cmd))
|
||||
rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) =
|
||||
@@ -1665,6 +1696,8 @@ client
|
||||
allowed = case cmd' of
|
||||
Cmd SSender SEND {} -> True
|
||||
Cmd SSender (SKEY _) -> True
|
||||
Cmd SLinkClient (LKEY _) -> True
|
||||
Cmd SLinkClient LGET -> True
|
||||
_ -> False
|
||||
verified = \case
|
||||
VRVerified q -> Right (q, (corrId', entId', cmd'))
|
||||
@@ -1720,12 +1753,12 @@ client
|
||||
|
||||
getQueueInfo :: StoreQueue s -> QueueRec -> M BrokerMsg
|
||||
getQueueInfo q QueueRec {senderKey, notifier} = do
|
||||
fmap (either ERR id) $ liftIO $ runExceptT $ do
|
||||
fmap (either ERR INFO) $ liftIO $ runExceptT $ do
|
||||
qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub
|
||||
qiSize <- getQueueSize ms q
|
||||
qiMsg <- toMsgInfo <$$> tryPeekMsg ms q
|
||||
let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
|
||||
pure $ INFO info
|
||||
pure info
|
||||
where
|
||||
mkQSub Sub {subThread, delivered} = do
|
||||
qSubThread <- case subThread of
|
||||
@@ -1787,7 +1820,7 @@ exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
|
||||
exportMessages tty ms f drainMsgs = do
|
||||
logInfo $ "saving messages to file " <> T.pack f
|
||||
liftIO $ withFile f WriteMode $ \h ->
|
||||
tryAny (unsafeWithAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case
|
||||
tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case
|
||||
Right (Sum total) -> logInfo $ "messages saved: " <> tshow total
|
||||
Left e -> do
|
||||
logError $ "error exporting messages: " <> tshow e
|
||||
@@ -1824,7 +1857,7 @@ processServerMessages StartOptions {skipWarnings} = do
|
||||
run processValidateQueue
|
||||
| otherwise = logWarn "skipping message expiration" $> Nothing
|
||||
where
|
||||
run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
|
||||
run a = unsafeWithAllMsgQueues False False ms a `catchAny` \_ -> exitFailure
|
||||
processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
|
||||
processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
|
||||
mq <- getMsgQueue ms q False
|
||||
|
||||
@@ -210,7 +210,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
|
||||
ps <- newJournalMsgStore $ PQStoreCfg storeCfg
|
||||
sl <- openWriteStoreLog False storeLogFilePath
|
||||
Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
||||
Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
||||
putStrLn $ "Export completed: " <> show qCnt <> " queues"
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
|
||||
|
||||
@@ -321,6 +321,12 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
|
||||
{-# INLINE addQueue_ #-}
|
||||
getQueue_ = withQS getQueue_
|
||||
{-# INLINE getQueue_ #-}
|
||||
addQueueLinkData = withQS addQueueLinkData
|
||||
{-# INLINE addQueueLinkData #-}
|
||||
getQueueLinkData = withQS getQueueLinkData
|
||||
{-# INLINE getQueueLinkData #-}
|
||||
deleteQueueLinkData = withQS deleteQueueLinkData
|
||||
{-# INLINE deleteQueueLinkData #-}
|
||||
secureQueue = withQS secureQueue
|
||||
{-# INLINE secureQueue #-}
|
||||
addQueueNotifier = withQS addQueueNotifier
|
||||
@@ -389,11 +395,11 @@ instance MsgStoreClass (JournalMsgStore s) where
|
||||
|
||||
-- This function can only be used in server CLI commands or before server is started.
|
||||
-- It does not cache queues and is NOT concurrency safe.
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
|
||||
unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
|
||||
unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of
|
||||
MQStore st -> withLoadedQueues st run
|
||||
#if defined(dbServerPostgres)
|
||||
PQStore st -> foldQueueRecs tty st Nothing $ uncurry (mkTempQueue ms) >=> run
|
||||
PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkTempQueue ms) >=> run
|
||||
#endif
|
||||
where
|
||||
run q = do
|
||||
@@ -413,7 +419,7 @@ instance MsgStoreClass (JournalMsgStore s) where
|
||||
#if defined(dbServerPostgres)
|
||||
PQStore st -> do
|
||||
let JournalMsgStore {queueLocks, sharedLock} = ms
|
||||
foldQueueRecs tty st (Just veryOld) $ \(rId, qr) -> do
|
||||
foldQueueRecs tty False st (Just veryOld) $ \(rId, qr) -> do
|
||||
q <- mkTempQueue ms rId qr
|
||||
withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $
|
||||
getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old
|
||||
|
||||
@@ -80,7 +80,7 @@ instance MsgStoreClass STMMsgStore where
|
||||
{-# INLINE closeMsgStore #-}
|
||||
withActiveMsgQueues = withLoadedQueues . queueStore_
|
||||
{-# INLINE withActiveMsgQueues #-}
|
||||
unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
|
||||
unsafeWithAllMsgQueues _ _ = withLoadedQueues . queueStore_
|
||||
{-# INLINE unsafeWithAllMsgQueues #-}
|
||||
|
||||
expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
|
||||
|
||||
@@ -37,7 +37,8 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M
|
||||
closeMsgStore :: s -> IO ()
|
||||
withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- This function can only be used in server CLI commands or before server is started.
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- tty, withData, store
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- tty, store, now, ttl
|
||||
expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
|
||||
logQueueStates :: s -> IO ()
|
||||
|
||||
@@ -25,14 +25,15 @@ import Simplex.Messaging.Util (eitherToMaybe)
|
||||
#endif
|
||||
|
||||
data QueueRec = QueueRec
|
||||
{ recipientKey :: !RcvPublicAuthKey,
|
||||
rcvDhSecret :: !RcvDhSecret,
|
||||
senderId :: !SenderId,
|
||||
senderKey :: !(Maybe SndPublicAuthKey),
|
||||
sndSecure :: !SenderCanSecure,
|
||||
notifier :: !(Maybe NtfCreds),
|
||||
status :: !ServerEntityStatus,
|
||||
updatedAt :: !(Maybe RoundedSystemTime)
|
||||
{ recipientKey :: RcvPublicAuthKey,
|
||||
rcvDhSecret :: RcvDhSecret,
|
||||
senderId :: SenderId,
|
||||
senderKey :: Maybe SndPublicAuthKey,
|
||||
queueMode :: Maybe QueueMode,
|
||||
queueData :: Maybe (LinkId, QueueLinkData),
|
||||
notifier :: Maybe NtfCreds,
|
||||
status :: ServerEntityStatus,
|
||||
updatedAt :: Maybe RoundedSystemTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@@ -35,7 +35,6 @@ import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (Builder)
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.Either (fromRight)
|
||||
@@ -43,10 +42,10 @@ import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError)
|
||||
import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..))
|
||||
import qualified Database.PostgreSQL.Simple as DB
|
||||
import qualified Database.PostgreSQL.Simple.Copy as DB
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
@@ -146,10 +145,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
>>= bimapM handleDuplicate pure
|
||||
atomically $ TM.insert rId sq queues
|
||||
atomically $ TM.insert (senderId qr) rId senders
|
||||
forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
|
||||
withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
|
||||
pure sq
|
||||
where
|
||||
PostgresQueueStore {queues, senders} = st
|
||||
PostgresQueueStore {queues, senders, notifiers} = st
|
||||
-- Not doing duplicate checks in maps as the probability of duplicates is very low.
|
||||
-- It needs to be reconsidered when IDs are supplied by the users.
|
||||
-- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
|
||||
@@ -160,12 +160,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
SRecipient -> getRcvQueue qId
|
||||
SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue
|
||||
SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue
|
||||
SLinkClient -> loadLinkQueue
|
||||
where
|
||||
PostgresQueueStore {queues, senders, notifiers} = st
|
||||
getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right)
|
||||
loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure ()
|
||||
loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders
|
||||
loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare
|
||||
loadLinkQueue = loadQueue " WHERE link_id = ?" $ \_ -> pure ()
|
||||
loadQueue condition insertRef =
|
||||
E.uninterruptibleMask_ $ runExceptT $ do
|
||||
(rId, qRec) <-
|
||||
@@ -187,6 +189,43 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
TM.insert rId sq queues
|
||||
pure sq
|
||||
|
||||
getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
getQueueLinkData st sq lnkId = runExceptT $ do
|
||||
qr <- ExceptT $ readQueueRecIO $ queueRec sq
|
||||
case queueData qr of
|
||||
Just (lnkId', _) | lnkId' == lnkId ->
|
||||
withDB "getQueueLinkData" st $ \db -> firstRow id AUTH $
|
||||
DB.query db "SELECT fixed_data, user_data FROM msg_queues WHERE link_id = ? AND deleted_at IS NULL" (Only lnkId)
|
||||
_ -> throwE AUTH
|
||||
|
||||
addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
addQueueLinkData st sq lnkId d =
|
||||
withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
|
||||
Nothing ->
|
||||
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId))
|
||||
Just (lnkId', _) | lnkId' == lnkId ->
|
||||
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data != ?)") (d :. (lnkId, rId, fst d))
|
||||
_ -> throwE AUTH
|
||||
where
|
||||
rId = recipientId sq
|
||||
addLink q update = do
|
||||
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"
|
||||
|
||||
deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData st sq =
|
||||
withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of
|
||||
Just _ -> do
|
||||
assertUpdated $ withDB' "deleteQueueLinkData" st $ \db ->
|
||||
DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId)
|
||||
atomically $ writeTVar (queueRec sq) $ Just q {queueData = Nothing}
|
||||
withLog "deleteQueueLinkData" st (`logDeleteLink` rId)
|
||||
_ -> throwE AUTH
|
||||
where
|
||||
rId = recipientId sq
|
||||
|
||||
secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
secureQueue st sq sKey =
|
||||
withQueueRec sq "secureQueue" $ \q -> do
|
||||
@@ -320,15 +359,15 @@ insertQueueQuery :: Query
|
||||
insertQueueQuery =
|
||||
[sql|
|
||||
INSERT INTO msg_queues
|
||||
(recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
(recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
|
||||
foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
|
||||
foldQueueRecs tty st skipOld_ f = do
|
||||
foldQueueRecs :: forall a q. Monoid a => Bool -> Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
|
||||
foldQueueRecs tty withData st skipOld_ f = do
|
||||
(n, r) <- withConnection (dbStore st) $ \db ->
|
||||
foldRecs db (0 :: Int, mempty) $ \(i, acc) row -> do
|
||||
r <- f $ rowToQueueRec row
|
||||
foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
|
||||
r <- f qr
|
||||
let !i' = i + 1
|
||||
!acc' = acc <> r
|
||||
when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout
|
||||
@@ -336,29 +375,49 @@ foldQueueRecs tty st skipOld_ f = do
|
||||
when tty $ putStrLn $ progress n
|
||||
pure r
|
||||
where
|
||||
foldRecs db = case skipOld_ of
|
||||
Nothing -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL")
|
||||
Just old -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old)
|
||||
foldRecs db acc f' = case skipOld_ of
|
||||
Nothing
|
||||
| withData -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
|
||||
| otherwise -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
|
||||
Just old
|
||||
| withData -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
|
||||
| otherwise -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
|
||||
query = if withData then queueRecQueryWithData else queueRecQuery
|
||||
progress i = "Processed: " <> show i <> " records"
|
||||
|
||||
queueRecQuery :: Query
|
||||
queueRecQuery =
|
||||
[sql|
|
||||
SELECT recipient_id, recipient_key, rcv_dh_secret,
|
||||
sender_id, sender_key, snd_secure,
|
||||
sender_id, sender_key, queue_mode,
|
||||
notifier_id, notifier_key, rcv_ntf_dh_secret,
|
||||
status, updated_at
|
||||
status, updated_at,
|
||||
link_id
|
||||
FROM msg_queues
|
||||
|]
|
||||
|
||||
type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime)
|
||||
queueRecQueryWithData :: Query
|
||||
queueRecQueryWithData =
|
||||
[sql|
|
||||
SELECT recipient_id, recipient_key, rcv_dh_secret,
|
||||
sender_id, sender_key, queue_mode,
|
||||
notifier_id, notifier_key, rcv_ntf_dh_secret,
|
||||
status, updated_at,
|
||||
link_id, fixed_data, user_data
|
||||
FROM msg_queues
|
||||
|]
|
||||
|
||||
queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow
|
||||
queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
|
||||
(rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt)
|
||||
type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId)
|
||||
|
||||
queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes)
|
||||
queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
|
||||
(rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_)
|
||||
:. (fst <$> queueData_, snd <$> queueData_)
|
||||
where
|
||||
(linkId_, queueData_) = queueDataColumns queueData
|
||||
|
||||
queueRecToText :: (RecipientId, QueueRec) -> ByteString
|
||||
queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
|
||||
queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
|
||||
LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
|
||||
where
|
||||
tabFields = BB.char7 ',' `intersperse` fields
|
||||
@@ -368,13 +427,17 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s
|
||||
renderField (toField rcvDhSecret),
|
||||
renderField (toField senderId),
|
||||
nullable senderKey,
|
||||
renderField (toField sndSecure),
|
||||
nullable queueMode,
|
||||
nullable (notifierId <$> n),
|
||||
nullable (notifierKey <$> n),
|
||||
nullable (rcvNtfDhSecret <$> n),
|
||||
BB.char7 '"' <> renderField (toField status) <> BB.char7 '"',
|
||||
nullable updatedAt
|
||||
nullable updatedAt,
|
||||
nullable linkId_,
|
||||
nullable (fst <$> queueData_),
|
||||
nullable (snd <$> queueData_)
|
||||
]
|
||||
(linkId_, queueData_) = queueDataColumns queueData
|
||||
nullable :: ToField a => Maybe a -> Builder
|
||||
nullable = maybe mempty (renderField . toField)
|
||||
renderField :: Action -> Builder
|
||||
@@ -385,10 +448,23 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s
|
||||
EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
|
||||
Many as -> mconcat (map renderField as)
|
||||
|
||||
queueDataColumns :: Maybe (LinkId, QueueLinkData) -> (Maybe LinkId, Maybe QueueLinkData)
|
||||
queueDataColumns = \case
|
||||
Just (linkId, linkData) -> (Just linkId, Just linkData)
|
||||
Nothing -> (Nothing, Nothing)
|
||||
|
||||
rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec)
|
||||
rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) =
|
||||
rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) =
|
||||
let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt})
|
||||
queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
|
||||
|
||||
rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec)
|
||||
rowToQueueRecWithData ((rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) =
|
||||
let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
|
||||
encData = fromMaybe (EncDataBytes "")
|
||||
queueData = (,(encData immutableData_, encData userData_)) <$> linkId_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
|
||||
|
||||
setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
|
||||
setStatusDB op st sq status writeLog =
|
||||
@@ -441,4 +517,8 @@ instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder str
|
||||
instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey
|
||||
|
||||
instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey
|
||||
|
||||
instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s)
|
||||
|
||||
deriving newtype instance FromField EncDataBytes
|
||||
#endif
|
||||
|
||||
@@ -12,7 +12,8 @@ import Text.RawString.QQ (r)
|
||||
serverSchemaMigrations :: [(String, Text, Maybe Text)]
|
||||
serverSchemaMigrations =
|
||||
[ ("20250207_initial", m20250207_initial, Nothing),
|
||||
("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index)
|
||||
("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index),
|
||||
("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -61,3 +62,37 @@ down_m20250319_updated_index =
|
||||
DROP INDEX idx_msg_queues_updated_at;
|
||||
CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at);
|
||||
|]
|
||||
|
||||
m20250320_short_links :: Text
|
||||
m20250320_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE msg_queues
|
||||
ADD COLUMN queue_mode TEXT,
|
||||
ADD COLUMN link_id BYTEA,
|
||||
ADD COLUMN fixed_data BYTEA,
|
||||
ADD COLUMN user_data BYTEA;
|
||||
|
||||
UPDATE msg_queues SET queue_mode = 'M' WHERE snd_secure IS TRUE;
|
||||
|
||||
ALTER TABLE msg_queues DROP COLUMN snd_secure;
|
||||
|
||||
CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id);
|
||||
|]
|
||||
|
||||
down_m20250320_short_links :: Text
|
||||
down_m20250320_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE;
|
||||
|
||||
UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M';
|
||||
|
||||
ALTER TABLE
|
||||
DROP COLUMN queue_mode,
|
||||
DROP COLUMN link_id,
|
||||
DROP COLUMN fixed_data,
|
||||
DROP COLUMN user_data;
|
||||
|
||||
DROP INDEX idx_msg_queues_link_id;
|
||||
|]
|
||||
|
||||
@@ -1,3 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Messaging.Server.QueueStore.QueueInfo where
|
||||
@@ -12,6 +15,14 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
||||
import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
#endif
|
||||
|
||||
data QueueInfo = QueueInfo
|
||||
{ qiSnd :: Bool,
|
||||
qiNtf :: Bool,
|
||||
@@ -40,6 +51,24 @@ data MsgInfo = MsgInfo
|
||||
data MsgType = MTMessage | MTQuota
|
||||
deriving (Eq, Show)
|
||||
|
||||
data QueueMode = QMMessaging | QMContact deriving (Eq, Show)
|
||||
|
||||
instance Encoding QueueMode where
|
||||
smpEncode = \case
|
||||
QMMessaging -> "M"
|
||||
QMContact -> "C"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'M' -> pure QMMessaging
|
||||
'C' -> pure QMContact
|
||||
_ -> fail "bad QueueMode"
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
|
||||
|
||||
instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode
|
||||
#endif
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "Q") ''QSubThread)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''QSub)
|
||||
|
||||
@@ -44,6 +44,7 @@ data STMQueueStore q = STMQueueStore
|
||||
{ queues :: TMap RecipientId q,
|
||||
senders :: TMap SenderId RecipientId,
|
||||
notifiers :: TMap NotifierId RecipientId,
|
||||
links :: TMap LinkId RecipientId,
|
||||
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
|
||||
}
|
||||
|
||||
@@ -58,8 +59,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
queues <- TM.emptyIO
|
||||
senders <- TM.emptyIO
|
||||
notifiers <- TM.emptyIO
|
||||
links <- TM.emptyIO
|
||||
storeLog <- newTVarIO Nothing
|
||||
pure STMQueueStore {queues, senders, notifiers, storeLog}
|
||||
pure STMQueueStore {queues, senders, notifiers, links, storeLog}
|
||||
|
||||
closeQueueStore :: STMQueueStore q -> IO ()
|
||||
closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do
|
||||
@@ -80,17 +82,19 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
pure QueueCounts {queueCount, notifierCount}
|
||||
|
||||
addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
|
||||
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier} = do
|
||||
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do
|
||||
sq <- mkQ rId qr
|
||||
add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
|
||||
where
|
||||
STMQueueStore {queues, senders, notifiers} = st
|
||||
STMQueueStore {queues, senders, notifiers, links} = st
|
||||
add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do
|
||||
TM.insert rId q queues
|
||||
TM.insert sId rId senders
|
||||
forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
|
||||
hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier]
|
||||
forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links
|
||||
hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink]
|
||||
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
|
||||
hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
|
||||
|
||||
getQueue_ :: DirectParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
|
||||
getQueue_ st _ party qId =
|
||||
@@ -98,8 +102,44 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
SRecipient -> TM.lookupIO qId queues
|
||||
SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
|
||||
SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
|
||||
SLinkClient -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues)
|
||||
where
|
||||
STMQueueStore {queues, senders, notifiers} = st
|
||||
STMQueueStore {queues, senders, notifiers, links} = st
|
||||
|
||||
getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData
|
||||
where
|
||||
getData qr = case queueData qr of
|
||||
Just (lnkId', d) | lnkId' == lnkId -> Right d
|
||||
_ -> Left AUTH
|
||||
|
||||
addQueueLinkData :: STMQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
addQueueLinkData st sq lnkId d =
|
||||
atomically (readQueueRec qr $>>= add)
|
||||
$>> withLog "addQueueLinkData" st (\s -> logCreateLink s rId lnkId d)
|
||||
where
|
||||
rId = recipientId sq
|
||||
qr = queueRec sq
|
||||
add q = case queueData q of
|
||||
Nothing -> addLink
|
||||
Just (lnkId', d') | lnkId' == lnkId && fst d' == fst d -> addLink
|
||||
_ -> pure $ Left AUTH
|
||||
where
|
||||
addLink = do
|
||||
let !q' = q {queueData = Just (lnkId, d)}
|
||||
writeTVar qr $ Just q'
|
||||
TM.insert lnkId rId $ links st
|
||||
pure $ Right ()
|
||||
|
||||
deleteQueueLinkData :: STMQueueStore q -> q -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData st sq =
|
||||
withQueueRec qr delete
|
||||
$>> withLog "deleteQueueLinkData" st (`logDeleteLink` recipientId sq)
|
||||
where
|
||||
qr = queueRec sq
|
||||
delete q = forM (queueData q) $ \(lnkId, _) -> do
|
||||
TM.delete lnkId $ links st
|
||||
writeTVar qr $ Just q {queueData = Nothing}
|
||||
|
||||
secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
secureQueue st sq sKey =
|
||||
|
||||
@@ -30,6 +30,9 @@ class StoreQueueClass q => QueueStoreClass q s where
|
||||
compactQueues :: s -> IO Int64
|
||||
addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
|
||||
getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
|
||||
getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData :: s -> q -> IO (Either ErrorType ())
|
||||
secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
|
||||
deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId))
|
||||
|
||||
@@ -18,6 +18,8 @@ module Simplex.Messaging.Server.StoreLog
|
||||
closeStoreLog,
|
||||
writeStoreLogRecord,
|
||||
logCreateQueue,
|
||||
logCreateLink,
|
||||
logDeleteLink,
|
||||
logSecureQueue,
|
||||
logAddNotifier,
|
||||
logSuspendQueue,
|
||||
@@ -37,6 +39,7 @@ import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.List (sort, stripPrefix)
|
||||
@@ -45,6 +48,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
|
||||
import GHC.IO (catchAny)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
-- import Simplex.Messaging.Server.MsgStore.Types
|
||||
@@ -57,6 +61,8 @@ import System.FilePath (takeDirectory, takeFileName)
|
||||
|
||||
data StoreLogRecord
|
||||
= CreateQueue RecipientId QueueRec
|
||||
| CreateLink RecipientId LinkId QueueLinkData
|
||||
| DeleteLink RecipientId
|
||||
| SecureQueue QueueId SndPublicAuthKey
|
||||
| AddNotifier QueueId NtfCreds
|
||||
| SuspendQueue QueueId
|
||||
@@ -69,6 +75,8 @@ data StoreLogRecord
|
||||
|
||||
data SLRTag
|
||||
= CreateQueue_
|
||||
| CreateLink_
|
||||
| DeleteLink_
|
||||
| SecureQueue_
|
||||
| AddNotifier_
|
||||
| SuspendQueue_
|
||||
@@ -79,21 +87,22 @@ data SLRTag
|
||||
| UpdateTime_
|
||||
|
||||
instance StrEncoding QueueRec where
|
||||
strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} =
|
||||
strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} =
|
||||
B.unwords
|
||||
[ "rk=" <> strEncode recipientKey,
|
||||
"rdh=" <> strEncode rcvDhSecret,
|
||||
"sid=" <> strEncode senderId,
|
||||
"sk=" <> strEncode senderKey
|
||||
]
|
||||
<> sndSecureStr
|
||||
<> maybe "" notifierStr notifier
|
||||
<> maybe "" updatedAtStr updatedAt
|
||||
<> maybe "" ((" queue_mode=" <>) . smpEncode) queueMode
|
||||
<> opt " link_id=" (fst <$> queueData)
|
||||
<> opt " queue_data=" (snd <$> queueData)
|
||||
<> opt " notifier=" notifier
|
||||
<> opt " updated_at=" updatedAt
|
||||
<> statusStr
|
||||
where
|
||||
sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
|
||||
notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
|
||||
updatedAtStr t = " updated_at=" <> strEncode t
|
||||
opt :: StrEncoding a => ByteString -> Maybe a -> ByteString
|
||||
opt param = maybe "" ((param <>) . strEncode)
|
||||
statusStr = case status of
|
||||
EntityActive -> ""
|
||||
_ -> " status=" <> strEncode status
|
||||
@@ -103,15 +112,23 @@ instance StrEncoding QueueRec where
|
||||
rcvDhSecret <- "rdh=" *> strP_
|
||||
senderId <- "sid=" *> strP_
|
||||
senderKey <- "sk=" *> strP
|
||||
sndSecure <- (" sndSecure=" *> strP) <|> pure False
|
||||
queueMode <-
|
||||
toQueueMode <$> (" sndSecure=" *> strP)
|
||||
<|> Just <$> (" queue_mode=" *> smpP)
|
||||
<|> pure Nothing -- unknown queue mode, we cannot imply that it is contact address
|
||||
queueData <- optional $ (,) <$> (" link_id" *> strP) <*> (" queue_data" *> strP)
|
||||
notifier <- optional $ " notifier=" *> strP
|
||||
updatedAt <- optional $ " updated_at=" *> strP
|
||||
status <- (" status=" *> strP) <|> pure EntityActive
|
||||
pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}
|
||||
pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}
|
||||
where
|
||||
toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
|
||||
instance StrEncoding SLRTag where
|
||||
strEncode = \case
|
||||
CreateQueue_ -> "CREATE"
|
||||
CreateLink_ -> "CREATE_LINK"
|
||||
DeleteLink_ -> "DELETE_LINK"
|
||||
SecureQueue_ -> "SECURE"
|
||||
AddNotifier_ -> "NOTIFIER"
|
||||
SuspendQueue_ -> "SUSPEND"
|
||||
@@ -124,6 +141,8 @@ instance StrEncoding SLRTag where
|
||||
strP =
|
||||
A.choice
|
||||
[ "CREATE" $> CreateQueue_,
|
||||
"CREATE_LINK" $> CreateLink_,
|
||||
"DELETE_LINK" $> DeleteLink_,
|
||||
"SECURE" $> SecureQueue_,
|
||||
"NOTIFIER" $> AddNotifier_,
|
||||
"SUSPEND" $> SuspendQueue_,
|
||||
@@ -137,6 +156,8 @@ instance StrEncoding SLRTag where
|
||||
instance StrEncoding StoreLogRecord where
|
||||
strEncode = \case
|
||||
CreateQueue rId q -> B.unwords [strEncode CreateQueue_, "rid=" <> strEncode rId, strEncode q]
|
||||
CreateLink rId lnkId d -> strEncode (CreateLink_, rId, lnkId, d)
|
||||
DeleteLink rId -> strEncode (DeleteLink_, rId)
|
||||
SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey)
|
||||
AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds)
|
||||
SuspendQueue rId -> strEncode (SuspendQueue_, rId)
|
||||
@@ -149,6 +170,8 @@ instance StrEncoding StoreLogRecord where
|
||||
strP =
|
||||
strP_ >>= \case
|
||||
CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP
|
||||
CreateLink_ -> CreateLink <$> strP_ <*> strP_ <*> strP
|
||||
DeleteLink_ -> DeleteLink <$> strP
|
||||
SecureQueue_ -> SecureQueue <$> strP_ <*> strP
|
||||
AddNotifier_ -> AddNotifier <$> strP_ <*> strP
|
||||
SuspendQueue_ -> SuspendQueue <$> strP
|
||||
@@ -189,6 +212,12 @@ writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do
|
||||
logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO ()
|
||||
logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q
|
||||
|
||||
logCreateLink :: StoreLog 'WriteMode -> RecipientId -> LinkId -> QueueLinkData -> IO ()
|
||||
logCreateLink s rId lnkId d = writeStoreLogRecord s $ CreateLink rId lnkId d
|
||||
|
||||
logDeleteLink :: StoreLog 'WriteMode -> RecipientId -> IO ()
|
||||
logDeleteLink s = writeStoreLogRecord s . DeleteLink
|
||||
|
||||
logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO ()
|
||||
logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Protocol (ErrorType, RecipientId, SParty (..))
|
||||
import Simplex.Messaging.Server.QueueStore (QueueRec)
|
||||
import Simplex.Messaging.Server.QueueStore.Types
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
@@ -42,6 +42,8 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
|
||||
procLogRecord :: StoreLogRecord -> IO ()
|
||||
procLogRecord = \case
|
||||
CreateQueue rId qr -> addQueue_ st mkQ rId qr >>= qError rId "CreateQueue"
|
||||
CreateLink rId lnkId d -> withQueue rId "CreateLink" $ \q -> addQueueLinkData st q lnkId d
|
||||
DeleteLink rId -> withQueue rId "DeleteLink" $ \q -> deleteQueueLinkData st q
|
||||
SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
|
||||
AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
|
||||
SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
|
||||
|
||||
@@ -52,6 +52,7 @@ module Simplex.Messaging.Transport
|
||||
deletedEventSMPVersion,
|
||||
encryptedBlockSMPVersion,
|
||||
blockedEntitySMPVersion,
|
||||
shortLinksSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -147,6 +148,7 @@ smpBlockSize = 16384
|
||||
-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024)
|
||||
-- 12 - BLOCKED error for blocked queues (1/11/2025)
|
||||
-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
|
||||
-- 15 - short links, include creating NTF credentials in NEW command
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -183,6 +185,9 @@ blockedEntitySMPVersion = VersionSMP 12
|
||||
proxyServerHandshakeSMPVersion :: VersionSMP
|
||||
proxyServerHandshakeSMPVersion = VersionSMP 14
|
||||
|
||||
shortLinksSMPVersion :: VersionSMP
|
||||
shortLinksSMPVersion = VersionSMP 15
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 6
|
||||
|
||||
@@ -190,13 +195,13 @@ minServerSMPRelayVersion :: VersionSMP
|
||||
minServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 14
|
||||
currentClientSMPRelayVersion = VersionSMP 15
|
||||
|
||||
legacyServerSMPRelayVersion :: VersionSMP
|
||||
legacyServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 14
|
||||
currentServerSMPRelayVersion = VersionSMP 15
|
||||
|
||||
-- Max SMP protocol version to be used in e2e encrypted
|
||||
-- connection between client and server, as defined by SMP proxy.
|
||||
@@ -204,7 +209,7 @@ currentServerSMPRelayVersion = VersionSMP 14
|
||||
-- to prevent client version fingerprinting by the
|
||||
-- destination relays when clients upgrade at different times.
|
||||
proxiedSMPRelayVersion :: VersionSMP
|
||||
proxiedSMPRelayVersion = VersionSMP 14
|
||||
proxiedSMPRelayVersion = VersionSMP 15
|
||||
|
||||
-- minimal supported protocol version is 6
|
||||
-- TODO remove code that supports sending commands without batching
|
||||
|
||||
Reference in New Issue
Block a user