From 7988a8ff002be3f57dfa4010207e1bad32522c83 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 15 Jul 2026 13:05:06 +0100 Subject: [PATCH] refactor --- src/Simplex/Chat/Library/Internal.hs | 44 ++++++++------------------ src/Simplex/Chat/Library/Subscriber.hs | 6 ++-- tests/ChatTests/Profiles.hs | 6 ++-- 3 files changed, 19 insertions(+), 37 deletions(-) diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 5625035666..1cbc6b35a7 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -1265,41 +1265,23 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a redactedMemberProfile :: GroupInfo -> GroupMember -> Profile -> Profile redactedMemberProfile g m Profile {displayName, fullName, shortDescr, description, image, contactLink = lnk, peerType, badge, contactDomain} = - Profile {displayName, fullName, shortDescr = redactLinkedText dropWholeOnLink allowSimplexLinks =<< shortDescr, description = redactGroupDescription g m =<< description, image, contactLink, preferences = Nothing, peerType, badge, contactDomain = redactedDomain} + Profile {displayName, fullName, shortDescr = removeSimplexLink True =<< shortDescr, description = removeSimplexLink False =<< description, image, contactLink, preferences = Nothing, peerType, badge, contactDomain = redactedDomain} where contactLink = if allowSimplexLinks then lnk else Nothing redactedDomain = if allowDirect then (\d -> d {proof = Nothing} :: SimplexDomainClaim) <$> contactDomain else Nothing allowDirect = groupFeatureMemberAllowed SGFDirectMessages m g - allowSimplexLinks = memberLinksAllowed g m - -redactMemberProfileDescription :: GroupInfo -> GroupMember -> Profile -> Profile -redactMemberProfileDescription g m p@Profile {description} = - p {description = redactGroupDescription g m =<< description} - -redactGroupDescription :: GroupInfo -> GroupMember -> Text -> Maybe Text -redactGroupDescription g m = redactLinkedText stripLinkSpans (memberLinksAllowed g m) - -memberLinksAllowed :: GroupInfo -> GroupMember -> Bool -memberLinksAllowed g m = groupFeatureMemberAllowed SGFSimplexLinks m g && groupFeatureMemberAllowed SGFDirectMessages m g - -redactLinkedText :: (Text -> [FormattedText] -> Maybe Text) -> Bool -> Text -> Maybe Text -redactLinkedText fromSpans allowSimplexLinks s - | allowSimplexLinks = Just s - | hasObfuscatedSimplexLink s = Nothing - | otherwise = maybe (Just s) (fromSpans s) $ parseMaybeMarkdownList s - -dropWholeOnLink :: Text -> [FormattedText] -> Maybe Text -dropWholeOnLink s fts - | any ftIsSimplexLink fts = Nothing - | otherwise = Just s - -stripLinkSpans :: Text -> [FormattedText] -> Maybe Text -stripLinkSpans _ fts - | T.null (T.strip kept) = Nothing - | otherwise = Just kept - where - kept = T.concat [t | FormattedText f t <- fts, not (maybe False linkOrMention f)] - linkOrMention f = isLink f || case f of Mention {} -> True; _ -> False + allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g && allowDirect + removeSimplexLink dropOnLink s + | allowSimplexLinks = Just s + | hasObfuscatedSimplexLink s = Nothing + | otherwise = case parseMaybeMarkdownList s of + Nothing -> Just s + Just fts + | not (any ftIsSimplexLink fts) -> Just s + | dropOnLink || T.null (T.strip kept) -> Nothing + | otherwise -> Just kept + where + kept = T.concat $ map (\(FormattedText _ t) -> t) $ filter (not . ftIsSimplexLink) fts -- Roles carried by the roster; owners are on the link, not the roster. isRosterRole :: GroupMemberRole -> Bool diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 9a5ea9b7bf..5b6b85acd1 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -2832,7 +2832,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = when contentChanged $ updateBusinessChatProfile gInfo case memberContactId of Nothing -> do - m' <- withStore $ \db -> updateMemberProfile db cxt user m pr' + m' <- withStore $ \db -> updateMemberProfile db cxt user m p'' unless (muteEventInChannel gInfo m') $ do when contentChanged $ forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' @@ -2857,8 +2857,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = | otherwise = pure m where - pr' = redactMemberProfileDescription gInfo m p' - contentChanged = not (sameProfileContent (redactedMemberProfile gInfo m (fromLocalProfile p)) (redactedMemberProfile gInfo m p')) + p'' = redactedMemberProfile gInfo m p' + contentChanged = not (sameProfileContent (redactedMemberProfile gInfo m (fromLocalProfile p)) p'') updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of Just bc | isMainBusinessMember bc m -> do g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 29c7f5ec8c..4468756498 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -214,7 +214,7 @@ testProfileDescriptionShown = alice ##> "/i @bob" alice <## "contact ID: 2" alice <## "description:" - alice <## "check https://simplex.chat out" + alice <## "check [this link](https://smp4.simplex.im/a#lXUjJW5vHYQzoLYgmi8GbxkGP41_kjefFvBrdwg-0Ok) out" alice <##. "receiving messages via" alice <##. "sending messages via" alice <## "you've shared main profile with this contact" @@ -222,7 +222,7 @@ testProfileDescriptionShown = alice <## "quantum resistant end-to-end encryption" alice <##. "peer chat protocol version range" where - bobWithDescr = bobProfile {description = Just "check https://simplex.chat out"} + bobWithDescr = bobProfile {description = Just "check [this link](https://smp4.simplex.im/a#lXUjJW5vHYQzoLYgmi8GbxkGP41_kjefFvBrdwg-0Ok) out"} -- for a member without a direct contact, the description is redacted per the group's link/name policy testMemberDescriptionRedacted :: HasCallStack => TestParams -> IO () @@ -266,7 +266,7 @@ testMemberDescriptionRedacted = bob <## "connection not verified, use /code command to see security code" bob <##. "peer chat protocol version range" where - cathWithDescr = cathProfile {description = Just "check https://simplex.chat out"} + cathWithDescr = cathProfile {description = Just "check [this link](https://smp4.simplex.im/a#lXUjJW5vHYQzoLYgmi8GbxkGP41_kjefFvBrdwg-0Ok) out"} -- the test issuer key under index 1 in the test config testBadgeKeys :: BBSPublicKey -> M.Map Int BBSPublicKey