From 38a360ce938a75408b772b6ac4ee83738d28c754 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 28 Jun 2026 08:20:44 +0000 Subject: [PATCH] refactor to another type --- .../src/Directory/Service.hs | 8 +- bots/src/API/Docs/Types.hs | 6 +- src/Simplex/Chat/Controller.hs | 4 +- src/Simplex/Chat/Library/Commands.hs | 155 ++++++++++-------- src/Simplex/Chat/Store/Direct.hs | 9 +- src/Simplex/Chat/Store/Groups.hs | 9 +- src/Simplex/Chat/Types.hs | 57 ++++++- 7 files changed, 159 insertions(+), 89 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 53dedf1a91..3591bd0399 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -65,7 +65,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), AgentErrorType (..), ConnectTarget (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), AgentErrorType (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ErrorType (..)) @@ -552,7 +552,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName <> ".\nIt is hidden from the directory until approved." notifyAdminUsers $ "The " <> gt <> " " <> groupRef <> " is updated" <> byMember <> "." sendToApprove g' gr' n' - sendChatCmd cc (APIConnectPlan userId (Just (CTLink link)) True Nothing) >>= \case + sendChatCmd cc (APIConnectPlan userId (Just (aConnectTargetLink link)) True Nothing) >>= \case Right (CRConnectionPlan _ _ (CPGroupLink (GLPKnown {groupInfo = g'}))) -> case dbOwnerMemberId gr of Just ownerGMId -> @@ -797,7 +797,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName forM_ pg_ $ \pg@PublicGroupProfile {groupLink} -> when (groupRegStatus == GRSActive || pendingApproval groupRegStatus) $ do let link = ACL SCMContact $ CLShort groupLink - sendChatCmd cc (APIConnectPlan userId (Just (CTLink link)) True Nothing) >>= \case + sendChatCmd cc (APIConnectPlan userId (Just (aConnectTargetLink link)) True Nothing) >>= \case Right (CRConnectionPlan _ _ (CPGroupLink (GLPKnown {groupInfo = g', groupUpdated = BoolDef updated, linkOwners = ListDef owners}))) -> checkValidOwner dbOwnerMemberId owners $ do when updated $ reapprove pg gr groupRegStatus g' @@ -933,7 +933,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let link = ACL SCMContact $ CLShort connLink mId = MemberId oIdBytes gt' = groupTypeStr gt - sendChatCmd cc (APIConnectPlan userId (Just (CTLink link)) True (Just ownerSig)) >>= \case + sendChatCmd cc (APIConnectPlan userId (Just (aConnectTargetLink link)) True (Just ownerSig)) >>= \case Right (CRConnectionPlan _ (ACCL SCMContact ccLink) plan) -> handleGroupLinkPlan ct ccLink mId ownerSig gt' plan _ -> sendMessage cc ct "Error: could not connect. Please report it to directory admins." diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index 56d8330450..c975859013 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -42,7 +42,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme import Simplex.FileTransfer.Transport import Simplex.FileTransfer.Types hiding (RcvFileStatus) -- the type with the same name is used in simplex-chat. -import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Protocol hiding (ConnectTarget (..)) import Simplex.Messaging.Client import Simplex.Messaging.Crypto.File import Simplex.Messaging.Parsers (dropPrefix, fstToLower) @@ -251,7 +251,7 @@ chatTypesDocsData = (sti @ConnectionErrorType, STUnion, "", [], "", ""), (sti @ConnectionMode, (STEnum' $ take 3 . consLower "CM"), "", [], "", ""), (sti @ConnectionPlan, STUnion, "CP", [], "", ""), - (sti @ConnectTarget, STUnion, "CT", [], "", "Connect target: SimpleX link (`CTLink`) or SimpleX name (`CTName`). Wire form is the bare string returned by `strEncode` — `simplex:/...` for links, `#name.simplex` / `@name.simplex` for names."), + ((sti @ContactNameOrLink) {typeName = "AConnectTarget"}, STUnion, "CT", [], "", "Connect target: SimpleX link (`CTLink`) or SimpleX name (`CTName`). Wire form is the bare string returned by `strEncode` — `simplex:/...` for links, `#name.simplex` / `@name.simplex` for names."), (sti @ConnStatus, STUnion, "Conn", [], "", ""), (sti @ConnType, (STEnum' $ consSep "Conn" '_'), "", [], "", ""), (sti @Contact, STRecord, "", [], "", ""), @@ -475,7 +475,7 @@ deriving instance Generic ConnectionEntity deriving instance Generic ConnectionErrorType deriving instance Generic ConnectionMode deriving instance Generic ConnectionPlan -deriving instance Generic ConnectTarget +deriving instance Generic ContactNameOrLink deriving instance Generic ConnStatus deriving instance Generic ConnType deriving instance Generic Contact diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 752ed2f76a..0ee4973f4d 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -528,7 +528,7 @@ data ChatCommand | AddContact IncognitoEnabled | APISetConnectionIncognito Int64 IncognitoEnabled | APIChangeConnectionUser Int64 UserId -- new user id to switch connection to - | APIConnectPlan {userId :: UserId, connectTarget :: Maybe ConnectTarget, resolveKnown :: Bool, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe ConnectTarget is used to report parsing failure as special error + | APIConnectPlan {userId :: UserId, connectTarget :: Maybe AConnectTarget, resolveKnown :: Bool, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe AConnectTarget is used to report parsing failure as special error | APIPrepareContact UserId ACreatedConnLink ContactShortLinkData | APIPrepareGroup UserId CreatedLinkContact DirectLink GroupShortLinkData | APIChangePreparedContactUser ContactId UserId @@ -536,7 +536,7 @@ data ChatCommand | APIConnectPreparedContact {contactId :: ContactId, incognito :: IncognitoEnabled, msgContent_ :: Maybe MsgContent} | APIConnectPreparedGroup {groupId :: GroupId, incognito :: IncognitoEnabled, ownerContact :: Maybe GroupOwnerContact, msgContent_ :: Maybe MsgContent} | APIConnect {userId :: UserId, incognito :: IncognitoEnabled, preparedLink_ :: Maybe ACreatedConnLink} -- Maybe is used to report link parsing failure as special error - | Connect {incognito :: IncognitoEnabled, connTarget_ :: Maybe ConnectTarget} + | Connect {incognito :: IncognitoEnabled, connTarget_ :: Maybe AConnectTarget} | APIVerifyContactName {contactId :: ContactId} | APIVerifyPublicGroupName {groupId :: GroupId} | APIConnectContactViaAddress UserId IncognitoEnabled ContactId diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d3da5148ed..c1dc7bdf80 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -95,7 +95,7 @@ import Simplex.Chat.Web (webPreviewWorker) import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) -import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Protocol hiding (ConnectTarget (..)) import Simplex.Messaging.Agent.Store.Entity import Simplex.Messaging.Agent.Store.Interface (execSQL) import Simplex.Messaging.Agent.Store.Shared (upMigration) @@ -2288,7 +2288,8 @@ processChatCommand cxt nm = \case APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq Connect incognito (Just ct) -> withUser $ \user -> do (ccLink, plan) <- connectPlan user ct False Nothing `catchAllErrors` \e -> case ct of - CTLink (ACL m (CLFull cReq)) -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing)) + ACTarget m (CTFullContact cReq) -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing)) + ACTarget m (CTInv (CLFull cReq)) -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing)) _ -> throwError e connectWithPlan user incognito ccLink plan Connect _ Nothing -> throwChatError CEInvalidConnReq @@ -4163,28 +4164,8 @@ processChatCommand cxt nm = \case pure (gId, chatSettings) _ -> throwCmdError "not supported" processChatCommand cxt nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings - connectPlan :: User -> ConnectTarget -> Bool -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan) - connectPlan user target resolveKnown sig_ = - withFastStore (\db -> getContactToConnect db cxt user target') >>= \case - Just (cReq, ct) | not (contactDeleted ct) -> pure (knownLink cReq, CPContactAddress (CAPKnown ct)) - _ -> - withFastStore (\db -> getGroupToConnect db cxt user target') >>= \case - Just (cReq, g) | not (memberRemoved (membership g)) -> pure (knownLink cReq, CPGroupLink (GLPKnown g (BoolDef False) Nothing (ListDef []))) - _ -> case target' of - CTLink l -> connectPlanLink user l resolveKnown sig_ - CTName ni -> do - l <- resolveNameLink user ni - (ccLink, plan) <- connectPlanLink user l False Nothing - verifyName user ni ccLink plan - where - target' = case target of - CTLink (ACL SCMContact (CLShort sl)) -> CTLink (ACL SCMContact (CLShort (serverShortLink sl))) - _ -> target - knownLink cReq = ACCL SCMContact $ CCLink cReq $ case target' of - CTLink (ACL SCMContact (CLShort sl)) -> Just sl - _ -> Nothing - connectPlanLink :: User -> AConnectionLink -> Bool -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan) - connectPlanLink user (ACL SCMInvitation cLink) _ sig_ = case cLink of + connectPlan :: User -> AConnectTarget -> Bool -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan) + connectPlan user (ACTarget SCMInvitation (CTInv cLink)) _ sig_ = case cLink of CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing Nothing CLShort l -> do let l' = serverShortLink l @@ -4205,47 +4186,74 @@ processChatCommand cxt nm = \case invitationReqAndPlan cReq sLnk_ cld ov = do plan <- invitationRequestPlan user cReq cld ov `catchAllErrors` (pure . CPError) pure (ACCL SCMInvitation (CCLink cReq sLnk_), plan) - connectPlanLink user (ACL SCMContact cLink) resolveKnown sig_ = case cLink of - CLFull cReq -> do + connectPlan user (ACTarget SCMContact ct) resolveKnown sig_ = case ct of + CTFullContact cReq -> do plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError) pure (ACCL SCMContact $ CCLink cReq Nothing, plan) - CLShort l@(CSLContact _ ct _ _) -> - case ct of + CTShortContact nameOrLink -> + case ctType of CCTContact -> knownLinkPlans >>= \case Just r -> pure r Nothing -> do - (FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l' - withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user l') >>= \case - Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct')) + sl <- resolveSLink + (FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user sl + withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user sl) >>= \case + Just ct' | not (contactDeleted ct') -> verified (con sl cReq, CPContactAddress (CAPContactViaAddress ct')) _ -> do contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData) let ContactLinkData _ UserContactData {owners} = cData - ov = verifyLinkOwner rootKey owners l' sig_ + ov = verifyLinkOwner rootKey owners sl sig_ plan <- contactRequestPlan user cReq contactSLinkData_ ov - pure (con cReq, plan) + verified (con sl cReq, plan) where knownLinkPlans = withFastStore $ \db -> - liftIO (getUserContactLinkViaShortLink db user l') >>= \case - Just UserContactLink {connLinkContact = CCLink cReq _} -> pure $ Just (con cReq, CPContactAddress CAPOwnLink) - Nothing -> pure Nothing + ownLinkPlan db >>= \case + Just r -> pure (Just r) + Nothing -> + getContactToConnect db cxt user nameOrLink' >>= \case + Just (cReq, ct') -> pure $ if contactDeleted ct' then Nothing else Just (knownCon cReq, CPContactAddress (CAPKnown ct')) + Nothing -> (gPlan =<<) <$> getGroupToConnect db cxt user nameOrLink' + ownLinkPlan db = case nameOrLink' of + CTLink sl -> + liftIO (getUserContactLinkViaShortLink db user sl) >>= \case + Just UserContactLink {connLinkContact = CCLink cReq _} -> pure $ Just (knownCon cReq, CPContactAddress CAPOwnLink) + Nothing -> pure Nothing + CTName _ -> pure Nothing CCTGroup -> groupShortLinkPlan CCTChannel -> groupShortLinkPlan CCTRelay -> throwCmdError "chat relay links are not supported in this version" where - l' = serverShortLink l - con cReq = ACCL SCMContact $ CCLink cReq (Just l') + nameOrLink' = case nameOrLink of + CTLink sl -> CTLink (serverShortLink sl) + CTName _ -> nameOrLink + ctType = case nameOrLink of + CTLink (CSLContact _ t _ _) -> t + CTName SimplexNameInfo {nameType = NTContact} -> CCTContact + CTName SimplexNameInfo {nameType = NTPublicGroup} -> CCTChannel + resolveSLink = case nameOrLink' of + CTLink sl -> pure sl + CTName ni -> serverShortLink <$> resolveNameLink user ni + con sl cReq = ACCL SCMContact $ CCLink cReq (Just sl) + knownCon cReq = ACCL SCMContact $ CCLink cReq $ case nameOrLink' of + CTLink sl -> Just sl + CTName _ -> Nothing + gPlan (cReq, g) = if memberRemoved (membership g) then Nothing else Just (knownCon cReq, CPGroupLink (GLPKnown g (BoolDef False) Nothing (ListDef []))) + verified r = case nameOrLink of + CTName ni -> verifyConnectedName user ni (fst r) (snd r) + CTLink _ -> pure r groupShortLinkPlan = knownLinkPlans >>= \case Just (_, CPGroupLink (GLPKnown g _ _ _)) | resolveKnown -> resolveKnownGroup g Just r -> pure r Nothing -> do - (fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq' nm user l' + sl <- resolveSLink + (fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq' nm user sl groupSLinkData_ <- liftIO $ decodeLinkUserData cData if - | not direct && unsupportedGroupType groupSLinkData_ -> pure (con (linkConnReq fd), CPGroupLink (GLPUpdateRequired groupSLinkData_)) - | not direct && null relays -> pure (con (linkConnReq fd), CPGroupLink (GLPNoRelays groupSLinkData_)) + | not direct && unsupportedGroupType groupSLinkData_ -> verified (con sl (linkConnReq fd), CPGroupLink (GLPUpdateRequired groupSLinkData_)) + | not direct && null relays -> verified (con sl (linkConnReq fd), CPGroupLink (GLPNoRelays groupSLinkData_)) | otherwise -> do let FixedLinkData {linkConnReq = cReq, linkEntityId, rootKey} = fd linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId} @@ -4255,40 +4263,46 @@ processChatCommand cxt nm = \case (Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure () (Nothing, Nothing) -> pure () _ -> throwChatError CEInvalidConnReq - let ov = verifyLinkOwner rootKey owners l' sig_ + let ov = verifyLinkOwner rootKey owners sl sig_ plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov - pure (con cReq, plan) + verified (con sl cReq, plan) where unsupportedGroupType = \case Just GroupShortLinkData {groupProfile = GroupProfile {publicGroup = Just PublicGroupProfile {groupType}}} -> groupType /= GTChannel _ -> False knownLinkPlans = withFastStore $ \db -> - liftIO (getGroupInfoViaUserShortLink db cxt user l') >>= \case - Just (cReq, g) -> pure $ Just (con cReq, CPGroupLink (GLPOwnLink g)) - Nothing -> pure Nothing + ownGroupLinkPlan db >>= \case + Just r -> pure (Just r) + Nothing -> (gPlan =<<) <$> getGroupToConnect db cxt user nameOrLink' + ownGroupLinkPlan db = case nameOrLink' of + CTLink sl -> + liftIO (getGroupInfoViaUserShortLink db cxt user sl) >>= \case + Just (cReq, g) -> pure $ Just (knownCon cReq, CPGroupLink (GLPOwnLink g)) + Nothing -> pure Nothing + CTName _ -> pure Nothing resolveKnownGroup g = do - (fd@FixedLinkData {rootKey = rk}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq' nm user l' + sl <- resolveSLink + (fd@FixedLinkData {rootKey = rk}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq' nm user sl groupSLinkData_ <- liftIO $ decodeLinkUserData cData - let ov = verifyLinkOwner rk owners l' sig_ + let ov = verifyLinkOwner rk owners sl sig_ glOwners = map (\OwnerAuth {ownerId, ownerKey} -> GroupLinkOwner {memberId = MemberId ownerId, memberKey = ownerKey}) owners (g', updated) <- case groupSLinkData_ of Just sLinkData -> updateGroupFromLinkData user g sLinkData _ -> pure (g, False) - pure (con (linkConnReq fd), CPGroupLink (GLPKnown g' (BoolDef updated) ov (ListDef glOwners))) + pure (con sl (linkConnReq fd), CPGroupLink (GLPKnown g' (BoolDef updated) ov (ListDef glOwners))) -- resolve a name to its first contact/channel short link - resolveNameLink :: User -> SimplexNameInfo -> CM AConnectionLink + resolveNameLink :: User -> SimplexNameInfo -> CM (ConnShortLink 'CMContact) resolveNameLink user ni@SimplexNameInfo {nameType, nameDomain} = do NameRecord {nrSimplexContact, nrSimplexChannel} <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) nameDomain let (candidates, ctType) = case nameType of NTContact -> (nrSimplexContact, CCTContact) NTPublicGroup -> (nrSimplexChannel, CCTChannel) - sLnk <- maybe (throwChatError $ CESimplexName ni SNENoValidLink) pure $ firstNameLink ctType candidates - pure $ ACL SCMContact (CLShort sLnk) + maybe (throwChatError $ CESimplexName ni SNENoValidLink) pure $ firstNameLink ctType candidates -- a resolved name was planned like a pasted link; create the prepared contact/group from the link -- data, check its profile claims this name, and mark it verified - verifyName :: User -> SimplexNameInfo -> ACreatedConnLink -> ConnectionPlan -> CM (ACreatedConnLink, ConnectionPlan) - verifyName user ni ccLink plan = case plan of + verifyConnectedName :: User -> SimplexNameInfo -> ACreatedConnLink -> ConnectionPlan -> CM (ACreatedConnLink, ConnectionPlan) + verifyConnectedName user ni ccLink plan = case plan of CPContactAddress (CAPOk (Just ContactShortLinkData {profile}) _) -> do ct <- withStore $ \db -> createPreparedContact db cxt user profile ccLink Nothing verifiedContactPlan ct @@ -4855,31 +4869,34 @@ nameVerifyReason = \case NVOFailed r -> Just r NVOInconclusive r -> Just r +-- claim-check, verify the proof, persist the verdict; returns the human-readable failure reason for the UI +verifyEntityName :: User -> NetworkRequestMode -> Maybe SimplexNameInfo -> Maybe AConnShortLink -> Maybe NameClaimProof -> String -> (Bool -> CM ()) -> CM (Maybe Text) +verifyEntityName user nm claim_ connLink_ proof_ noNameErr persist = do + claim <- maybe (throwCmdError noNameErr) pure claim_ + outcome <- verifyName user nm claim connLink_ proof_ + forM_ (nameVerifyVerdict outcome) persist + pure $ nameVerifyReason outcome + apiVerifyContactName :: User -> NetworkRequestMode -> ContactId -> CM ChatResponse apiVerifyContactName user nm contactId = do cxt <- chatStoreCxt - ct <- withFastStore $ \db -> getContact db cxt user contactId - let Contact {profile = LocalProfile {contactDomain, contactDomainProof}, preparedContact} = ct - connLink_ = preparedContact >>= \PreparedContact {connLinkToConnect = ACCL m (CCLink _ sLnk_)} -> ACSL m <$> sLnk_ - claim <- maybe (throwCmdError "contact has no name to verify") pure contactDomain - outcome <- verifyName user nm claim connLink_ contactDomainProof - forM_ (nameVerifyVerdict outcome) $ \v -> withStore' $ \db -> setContactDomainVerified db user contactId v + Contact {profile = LocalProfile {contactDomain, contactDomainProof}, preparedContact} <- withFastStore $ \db -> getContact db cxt user contactId + let connLink_ = preparedContact >>= \PreparedContact {connLinkToConnect = ACCL m (CCLink _ sLnk_)} -> ACSL m <$> sLnk_ + reason <- verifyEntityName user nm contactDomain connLink_ contactDomainProof "contact has no name to verify" $ + \v -> withStore' $ \db -> setContactDomainVerified db user contactId v ct' <- withFastStore $ \db -> getContact db cxt user contactId - pure $ CRContactNameVerified user ct' (nameVerifyReason outcome) + pure $ CRContactNameVerified user ct' reason apiVerifyPublicGroupName :: User -> NetworkRequestMode -> GroupId -> CM ChatResponse apiVerifyPublicGroupName user nm groupId = do cxt <- chatStoreCxt - g <- withFastStore $ \db -> getGroupInfo db cxt user groupId - let GroupInfo {groupProfile = GroupProfile {publicGroup}, preparedGroup} = g - gName = unStrJSON <$> (publicGroup >>= publicGroupAccess >>= groupDomain) - gProof = publicGroup >>= publicGroupAccess >>= groupDomainProof + GroupInfo {groupProfile = GroupProfile {publicGroup}, preparedGroup} <- withFastStore $ \db -> getGroupInfo db cxt user groupId + let access = publicGroup >>= publicGroupAccess connLink_ = preparedGroup >>= \PreparedGroup {connLinkToConnect = CCLink _ sLnk_} -> ACSL SCMContact <$> sLnk_ - claim <- maybe (throwCmdError "group has no name to verify") pure gName - outcome <- verifyName user nm claim connLink_ gProof - forM_ (nameVerifyVerdict outcome) $ \v -> withStore' $ \db -> setGroupDomainVerified db user groupId v + reason <- verifyEntityName user nm (unStrJSON <$> (access >>= groupDomain)) connLink_ (access >>= groupDomainProof) "group has no name to verify" $ + \v -> withStore' $ \db -> setGroupDomainVerified db user groupId v g' <- withFastStore $ \db -> getGroupInfo db cxt user groupId - pure $ CRGroupNameVerified user g' (nameVerifyReason outcome) + pure $ CRGroupNameVerified user g' reason data ConnectViaContactResult = CVRConnectedContact Contact diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index ee4c477da1..72acb0da27 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -113,7 +113,7 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.UITheme -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), AConnectionRequestUri (..), ACreatedConnLink (..), ConnId, ConnShortLink, ConnectionLink (..), ConnectionModeI (..), ConnectionRequestUri, ConnectTarget (..), CreatedConnLink (..), SConnectionMode (..), SimplexNameInfo, UserId) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), AConnectionRequestUri (..), ACreatedConnLink (..), ConnId, ConnShortLink, ConnectionLink (..), ConnectionModeI (..), ConnectionRequestUri, CreatedConnLink (..), SConnectionMode (..), SimplexNameInfo, UserId) import Simplex.Messaging.Encoding.String (StrJSON (..)) import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow) import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) @@ -798,16 +798,15 @@ getContactByName db cxt user localDisplayName = do cId <- getContactIdByName db user localDisplayName getContact db cxt user cId --- a contact to connect to, found by the connect target: by its address short link, or by its verified name -getContactToConnect :: DB.Connection -> StoreCxt -> User -> ConnectTarget -> ExceptT StoreError IO (Maybe (ConnReqContact, Contact)) +-- a contact to connect to, found by the target: by its address short link, or by its verified name +getContactToConnect :: DB.Connection -> StoreCxt -> User -> ContactNameOrLink -> ExceptT StoreError IO (Maybe (ConnReqContact, Contact)) getContactToConnect db cxt user@User {userId} = \case - CTLink (ACL SCMContact (CLShort sl)) -> getContactViaShortLinkToConnect db cxt user sl + CTLink sl -> getContactViaShortLinkToConnect db cxt user sl CTName ni -> liftIO (maybeFirstRow id $ DB.query db byNameQuery (userId, ni)) >>= \case Just (ctId :: Int64, Just (ACR cMode cReq)) | Just Refl <- testEquality cMode SCMContact -> Just . (cReq,) <$> getContact db cxt user ctId _ -> pure Nothing - _ -> pure Nothing where byNameQuery = [sql| diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 9d44ae6b3f..d73ebcf870 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -233,7 +233,7 @@ import Simplex.Chat.Types.MemberRelations (IntroductionDirection (..), MemberRel import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConfirmationId, ConnId, ConnectionLink (..), ConnectTarget (..), CreatedConnLink (..), InvitationId, OwnerAuth (..), SConnectionMode (..), SimplexNameInfo, UserId) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConfirmationId, ConnId, ConnectionLink (..), CreatedConnLink (..), InvitationId, OwnerAuth (..), SConnectionMode (..), SimplexNameInfo, UserId) import Simplex.Messaging.Agent.Store.AgentStore (firstRow, fromOnlyBI, maybeFirstRow) import qualified Simplex.FileTransfer.Description as FD import Simplex.Messaging.Encoding (smpDecode, smpEncode) @@ -1074,15 +1074,14 @@ getGroupInfoByName db cxt user gName = do gId <- getGroupIdByName db user gName getGroupInfo db cxt user gId --- a group to connect to, found by the connect target: by its address short link, or by its verified name -getGroupToConnect :: DB.Connection -> StoreCxt -> User -> ConnectTarget -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo)) +-- a group to connect to, found by the target: by its address short link, or by its verified name +getGroupToConnect :: DB.Connection -> StoreCxt -> User -> ContactNameOrLink -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo)) getGroupToConnect db cxt user@User {userId} = \case - CTLink (ACL SCMContact (CLShort sl)) -> getGroupViaShortLinkToConnect db cxt user sl + CTLink sl -> getGroupViaShortLinkToConnect db cxt user sl CTName ni -> liftIO (maybeFirstRow id $ DB.query db byNameQuery (userId, ni)) >>= \case Just (gId :: Int64, Just cReq) -> Just . (cReq,) <$> getGroupInfo db cxt user gId _ -> pure Nothing - _ -> pure Nothing where byNameQuery = [sql| diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 8a7bcc324e..ac49ffb7a4 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -19,6 +19,7 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -34,6 +35,7 @@ import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Attoparsec.Combinator (lookAhead) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString, pack, unpack) import qualified Data.ByteString.Char8 as B @@ -46,6 +48,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Word (Word16) import Simplex.Chat.Badges (BadgeInfo (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, verifyBadge) @@ -56,7 +59,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme import Simplex.FileTransfer.Description (FileDigest) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) -import Simplex.Messaging.Agent.Protocol (ACorrId, ACreatedConnLink, AEventTag (..), AEvtTag (..), ConnId, ConnShortLink (..), ConnectionLink, ConnectionMode (..), ConnectionRequestUri, ContactConnType (..), CreatedConnLink (..), InvitationId, SAEntity (..), SimplexNameInfo, UserId) +import Simplex.Messaging.Agent.Protocol (ACorrId, ACreatedConnLink, AConnectionLink (..), AEventTag (..), AEvtTag (..), ConnId, ConnShortLink (..), ConnectionLink (..), ConnectionMode (..), ConnectionModeI, ConnectionRequestUri, ContactConnType (..), CreatedConnLink (..), InvitationId, SAEntity (..), SConnectionMode (..), SimplexNameInfo, UserId) import Simplex.Messaging.Agent.Store.DB (Binary (..), blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) @@ -1784,6 +1787,58 @@ type ConnReqInvitation = ConnectionRequestUri 'CMInvitation type ConnReqContact = ConnectionRequestUri 'CMContact +-- what the user is connecting to: a contact/group by full address link, by short address link or registered name, or a one-time invitation link +-- CTFullContact is its own case because full address links are legacy; keeping them separate makes dropping them later a localized change (remove the constructor, its connectPlan branch, and the parser alternative) +data ConnectTarget (m :: ConnectionMode) where + CTFullContact :: ConnectionRequestUri 'CMContact -> ConnectTarget 'CMContact + CTShortContact :: ContactNameOrLink -> ConnectTarget 'CMContact + CTInv :: ConnectionLink 'CMInvitation -> ConnectTarget 'CMInvitation + +-- a short contact address link or a registered name; resolving a name produces a short link, i.e. turns CTName into CTLink +data ContactNameOrLink = CTName SimplexNameInfo | CTLink (ConnShortLink 'CMContact) + deriving (Eq, Show) + +deriving instance Eq (ConnectTarget m) + +deriving instance Show (ConnectTarget m) + +data AConnectTarget = forall m. ConnectionModeI m => ACTarget (SConnectionMode m) (ConnectTarget m) + +instance Eq AConnectTarget where + ACTarget m t == ACTarget m' t' = case testEquality m m' of + Just Refl -> t == t' + _ -> False + +deriving instance Show AConnectTarget + +instance StrEncoding AConnectTarget where + strEncode (ACTarget _ t) = case t of + CTFullContact cr -> strEncode cr + CTShortContact (CTName n) -> strEncode n + CTShortContact (CTLink sl) -> strEncode sl + CTInv l -> strEncode l + strP = + (ACTarget SCMContact . CTShortContact . CTName <$> (lookAhead nameStart *> strP)) + <|> ((\(ACL m cl) -> aConnectTarget m cl) <$> strP) + where + nameStart = "@" <|> "#" <|> "simplex:/name" + +aConnectTarget :: SConnectionMode m -> ConnectionLink m -> AConnectTarget +aConnectTarget m cl = case (m, cl) of + (SCMContact, CLFull cr) -> ACTarget SCMContact (CTFullContact cr) + (SCMContact, CLShort sl) -> ACTarget SCMContact (CTShortContact (CTLink sl)) + (SCMInvitation, _) -> ACTarget SCMInvitation (CTInv cl) + +aConnectTargetLink :: AConnectionLink -> AConnectTarget +aConnectTargetLink (ACL m cl) = aConnectTarget m cl + +instance ToJSON AConnectTarget where + toEncoding = strToJEncoding + toJSON = strToJSON + +instance FromJSON AConnectTarget where + parseJSON = strParseJSON "AConnectTarget" + type CreatedLinkInvitation = CreatedConnLink 'CMInvitation type CreatedLinkContact = CreatedConnLink 'CMContact