refactor

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

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'

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