dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-06-06 13:22:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: types and encodings to use from the app (#1504)

Browse Source 
* agent: types and encodings to use from the app

* use action forks
This commit is contained in:
Evgeny
2025-04-03 16:31:22 +01:00
committed by GitHub
parent 2c5530c9f0
commit 7ec0ae3bb5
7 changed files with 92 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Messaging/Agent.hs
+11 -9
View File
@@ -365,7 +365,7 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
{-# INLINE deleteConnectionsAsync #-}
-- | Create SMP agent connection (NEW command)
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, CreatedConnLink c)
createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs
{-# INLINE createConnection #-}
@@ -400,10 +400,12 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
-- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall.
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs
{-# INLINE prepareConnectionToJoin #-}
-- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId
prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs
{-# INLINE prepareConnectionToAccept #-}
-- | Join SMP agent connection (JOIN command).
joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
@@ -822,7 +824,7 @@ switchConnectionAsync' c corrId connId =
pure . connectionStats $ DuplexConnection cData rqs' sqs
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, CreatedConnLink c)
newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
srv <- getSMPServer c userId
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
@@ -909,7 +911,7 @@ changeConnectionUser' c oldUserId connId newUserId = do
where
updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
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 :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink 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"
@@ -923,7 +925,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
Nothing -> do
let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing
(_, qUri) <- createRcvQueue Nothing qd e2eKeys
(,Nothing) <$> createConnReq qUri
(`CCLink` Nothing) <$> createConnReq qUri
where
createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
createRcvQueue nonce_ qd e2eKeys = do
@@ -971,21 +973,21 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
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 :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (CreatedConnLink 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)
in pure $ CCLink 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)
in pure $ CCLink cReq' Nothing
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
@@ -1111,7 +1113,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod
joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
lift (compatibleContactUri cReqUri) >>= \case
Just (qInfo, vrsn) -> do
(cReq, _) <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv
CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv
void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
pure False
Nothing -> throwE $ AGENT A_VERSION
@@ -1421,7 +1423,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
triedHosts <- newTVarIO S.empty
tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
(cReq, _) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
notify $ INV (ACR cMode cReq)
JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
triedHosts <- newTVarIO S.empty
src/Simplex/Messaging/Agent/Protocol.hs
+57 -3
View File
@@ -112,7 +112,11 @@ module Simplex.Messaging.Agent.Protocol
ServiceScheme,
FixedLinkData (..),
UserLinkData (..),
ConnectionLink (..),
AConnectionLink (..),
ConnShortLink (..),
AConnShortLink (..),
CreatedConnLink (..),
ContactConnType (..),
LinkKey (..),
sameConnReqContact,
@@ -175,7 +179,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime)
import Data.Type.Equality
import Data.Typeable ()
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
import Simplex.FileTransfer.Description
@@ -1129,6 +1133,13 @@ instance ToJSON AConnectionRequestUri where
toJSON = strToJSON
toEncoding = strToJEncoding
instance ConnectionModeI m => FromJSON (ConnShortLink m) where
parseJSON = strParseJSON "ConnShortLink"
instance ConnectionModeI m => ToJSON (ConnShortLink m) where
toJSON = strToJSON
toEncoding = strToJEncoding
-- debug :: Show a => String -> a -> a
-- debug name value = unsafePerformIO (putStrLn $ name <> ": " <> show value) `seq` value
-- {-# INLINE debug #-}
@@ -1345,6 +1356,8 @@ data ConnShortLink (m :: ConnectionMode) where
CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation
CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact
deriving instance Eq (ConnShortLink m)
deriving instance Show (ConnShortLink m)
newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
@@ -1353,15 +1366,49 @@ newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
data ContactConnType = CCTContact | CCTGroup deriving (Show)
instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode
instance (Typeable c, ConnectionModeI c) => FromField (ConnectionLink c) where fromField = blobFieldDecoder strDecode
instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField . Binary . strEncode
instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
data ContactConnType = CCTContact | CCTGroup deriving (Eq, Show)
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
-- TODO [short link] parser, parsing tests
data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m)
deriving (Eq, Show)
data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connShortLink :: Maybe (ConnShortLink m)}
deriving (Eq, Show)
data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m)
deriving instance Show AConnectionLink
instance ConnectionModeI m => StrEncoding (ConnectionLink m) where
strEncode = \case
CLFull cr -> strEncode cr
CLShort sl -> strEncode sl
strP = (\(ACL _ cl) -> checkConnMode cl) <$?> strP
{-# INLINE strP #-}
instance StrEncoding AConnectionLink where
strEncode (ACL _ cl) = strEncode cl
{-# INLINE strEncode #-}
strP =
(\(ACR m cr) -> ACL m (CLFull cr)) <$> strP
<|> (\(ACSL m sl) -> ACL m (CLShort sl)) <$> strP
instance ConnectionModeI m => ToJSON (ConnectionLink m) where
toEncoding = strToJEncoding
toJSON = strToJSON
instance ConnectionModeI m => FromJSON (ConnectionLink m) where
parseJSON = strParseJSON "ConnectionLink"
instance ConnectionModeI m => StrEncoding (ConnShortLink m) where
strEncode = \case
CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i"
@@ -1695,3 +1742,10 @@ $(J.deriveJSON (sumTypeJSON id) ''AgentErrorType)
$(J.deriveJSON (enumJSON $ dropPrefix "QD") ''QueueDirection)
$(J.deriveJSON (enumJSON $ dropPrefix "SP") ''SwitchPhase)
instance ConnectionModeI m => FromJSON (CreatedConnLink m) where
parseJSON = $(J.mkParseJSON defaultJSON ''CreatedConnLink)
instance ConnectionModeI m => ToJSON (CreatedConnLink m) where
toEncoding = $(J.mkToEncoding defaultJSON ''CreatedConnLink)
toJSON = $(J.mkToJSON defaultJSON ''CreatedConnLink)