core: supporter badges using anonymous BBS credentials (#7040)

* core: supporter badges using anonymous BBS credentials

* badges in profiles

* badge in profiles

* process badges

* update simplexmq

* update simplexmq

* change types

* fix migration

* migration

* update simplexmq

* fix bot API, schema

* fix postgresql build

* refactor

* postgresql schema

* correctly set badges in all cases

* badges ffi

* plan, bot types

* FFI

* FFI: export badge symbols

* add extra field

* refactor badge types to GADT

* configurable badge key

* add badge to profile, test

* ui: badge images

* generate badge key and sign badge

* badge sign in CLI

* fix commands, ui

* rename badges

* Binary

* image size, migration

* update badge images, add public key

* send badges in more cases

* update UI, tests

* bot types, schema

* postgres schema

* tone down badges

* revert formula

* refactor badges

* smaller badges

* badge position

* better badge position

* simpler

* position

* move position

* update simplexmq

* show badge after name

* badge layout

* fix badge

* debug badge height

* shift badge

* fix badge in member name

* bigger badge

* badge layout

* differentiate badge colors

* more avatars for the user's profiles

* refactor

* remove color filter

* alerts

* multiple keys, old expired

* use new BBS api

* update badge keys, bot api

* presentation header

* simplify

* parser

* update iOS images

* update public keys

* query plans

* update simplexmq

* refactor badge types

* simplexmq

* bot api types

* update simplexmq - commoncrypto flag

* update simplexmq

* pass commoncrypto flag to simplexmq in nix iOS build

* ios ui

* update core library, fixes

* badge layout

* badge size

* badge gap

* remove extensions

* simplify

* share badge in more events, reverify badge if verification failed

* larger files with badges

* allow sending larger files

* simpler

* update simplexmq

* better decoder for badge keys

* update simplexmq

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
Co-authored-by: shum <github.shum@liber.li>

src/Simplex/Chat/View.hs

@@ -43,6 +43,7 @@ import Simplex.Chat.Controller
 import Simplex.Chat.Help
 import Simplex.Chat.Library.Commands (maxImageSize)
 import Simplex.Chat.Markdown
+import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Operators
@@ -111,7 +112,7 @@ chatErrorToView isCmd ChatConfig {logLevel, testView} = viewChatError isCmd logL
 
 chatResponseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
 chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveItems ts tz outputRH = \case
-  CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes
+  CRActiveUser User {profile = p@LocalProfile {localBadge}, uiThemes} -> viewUserProfile localBadge (fromLocalProfile p) <> viewUITheme uiThemes
   CRUsersList users -> viewUsersList users
   CRChatStarted -> ["chat started"]
   CRChatRunning -> ["chat is running"]
@@ -193,7 +194,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
   CRSentGroupInvitation u g c _ -> ttyUser u $ viewSentGroupInvitation g c
   CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
   CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci
-  CRUserProfile u p -> ttyUser u $ viewUserProfile p
+  CRUserProfile u@User {profile = LocalProfile {localBadge}} p -> ttyUser u $ viewUserProfile localBadge p
   CRUserProfileNoChange u -> ttyUser u ["user profile did not change"]
   CRUserPrivacy u u' -> ttyUserPrefix hu outputRH u $ viewUserPrivacy u u'
   CRVersionInfo info _ _ -> viewVersionInfo logLevel info
@@ -452,7 +453,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
   CEvtRcvFileProgressXFTP {} -> []
   CEvtContactUpdated {user = u, fromContact = c, toContact = c'} -> ttyUser u $ viewContactUpdated c c' <> viewContactPrefsUpdated u c c'
   CEvtGroupMemberUpdated {} -> []
-  CEvtReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} _chat -> ttyUser u $ viewReceivedContactRequest c profile
+  CEvtReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} _chat -> ttyUser u $ viewReceivedContactRequest c (fromLocalProfile profile)
   CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
   CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
   CEvtRcvStandaloneFileComplete u _ ft -> ttyUser u $ receivingFileStandalone "completed" ft
@@ -618,8 +619,8 @@ viewUsersList us =
    in if null ss then ["no users"] else ss
   where
     ldn (UserInfo User {localDisplayName = n} _) = T.toLower n
-    userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType}, activeUser, showNtfs, viewPwdHash} count)
-      | activeUser || isNothing viewPwdHash = Just $ ttyFullName n fullName shortDescr <> infoStr <> bot
+    userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType, localBadge}, activeUser, showNtfs, viewPwdHash} count)
+      | activeUser || isNothing viewPwdHash = Just $ ttyFullNameBadge n fullName shortDescr localBadge <> infoStr <> bot
       | otherwise = Nothing
       where
         infoStr = if null info then "" else " (" <> mconcat (intersperse ", " info) <> ")"
@@ -1507,9 +1508,9 @@ viewContactAndMemberAssociated ct g m ct' =
     "use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
   ]
 
-viewUserProfile :: Profile -> [StyledString]
-viewUserProfile Profile {displayName, fullName, shortDescr, peerType, preferences} =
-  [ "user profile: " <> ttyFullName displayName fullName shortDescr <> bot,
+viewUserProfile :: Maybe LocalBadge -> Profile -> [StyledString]
+viewUserProfile localBadge Profile {displayName, fullName, shortDescr, peerType, preferences} =
+  [ "user profile: " <> ttyFullNameBadge displayName fullName shortDescr localBadge <> bot,
     "use " <> highlight' "/p <name> [<bio>]" <> " to change it"
   ]
     ++ viewCommands
@@ -1752,9 +1753,22 @@ smpProxyModeStr :: SMPProxyMode -> SMPProxyFallback -> String
 smpProxyModeStr SPMNever _ = "private message routing disabled."
 smpProxyModeStr mode fallback = T.unpack $ safeDecodeUtf8 $ "private message routing mode: " <> strEncode mode <> ", fallback: " <> strEncode fallback
 
+viewContactBadge :: Maybe LocalBadge -> [StyledString]
+viewContactBadge = maybe [] $ \lb ->
+  let BadgeInfo {badgeType, badgeExpiry} = localBadgeInfo lb
+      st = case localBadgeStatus lb of
+        BSActive -> "active"
+        BSExpired -> "expired"
+        BSExpiredOld -> "expired (old)"
+        BSFailed -> "verification failed"
+        BSUnknownKey -> "unknown key"
+      expiry = maybe "no expiry" (("expires " <>) . T.pack . formatTime defaultTimeLocale "%Y-%m-%d") badgeExpiry
+   in [plain (textEncode badgeType <> " badge - " <> st), plain expiry]
+
 viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
-viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, uiThemes, customData} stats incognitoProfile =
+viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge}, activeConn, uiThemes, customData} stats incognitoProfile =
   ["contact ID: " <> sShow contactId]
+    <> viewContactBadge localBadge
     <> maybe [] viewConnectionStats stats
     <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact' l)]) contactLink
     <> maybe
@@ -1787,10 +1801,11 @@ viewCustomData :: Maybe CustomData -> [StyledString]
 viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> viewJSON (J.Object v)])
 
 viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
-viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink}, activeConn} stats =
+viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink, localBadge}, activeConn} stats =
   [ "group ID: " <> sShow groupId,
     "member ID: " <> sShow groupMemberId
   ]
+    <> viewContactBadge localBadge
     <> maybe ["member not connected"] viewConnectionStats stats
     <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact' l)]) contactLink
     <> ["alias: " <> plain localAlias | localAlias /= ""]
@@ -2785,9 +2800,47 @@ ttyContact = styled (colored Green) . viewName
 ttyContact' :: Contact -> StyledString
 ttyContact' Contact {localDisplayName = c} = ttyContact c
 
+-- Supporter badge: a colored star marks an active badge (only the star is colored).
+-- supporter cyan, legend blue, investor yellow, unknown cyan; business has no star.
+badgeStarColor :: BadgeType -> Maybe Color
+badgeStarColor = \case
+  BTSupporter -> Just Cyan
+  BTLegend -> Just Blue
+  BTInvestor -> Just Yellow
+  BTUnknown _ -> Just Cyan
+
+-- (star color, type word) for an active, colorable badge
+activeBadge :: Maybe LocalBadge -> Maybe (Color, Text)
+activeBadge lb_ = do
+  lb <- lb_
+  case localBadgeStatus lb of
+    BSActive -> let BadgeInfo {badgeType} = localBadgeInfo lb in (\col -> (col, textEncode badgeType)) <$> badgeStarColor badgeType
+    _ -> Nothing
+
+badgeStar :: Color -> StyledString
+badgeStar col = styled (colored col) ("*" :: Text)
+
+-- " *" (space + colored star) for sender prefixes, "" if no active badge
+badgeStarSep :: Maybe LocalBadge -> StyledString
+badgeStarSep lb_ = maybe "" (\(c, _) -> " " <> badgeStar c) (activeBadge lb_)
+
+-- name + badge for full-name contexts: "alice (Alice, * supporter)" / "alice (* supporter)" / "alice (Alice)" / "alice"
+ttyFullNameBadge :: ContactName -> Text -> Maybe Text -> Maybe LocalBadge -> StyledString
+ttyFullNameBadge c fullName shortDescr lb_ = ttyContact c <> optFullNameBadge c fullName shortDescr lb_
+
+optFullNameBadge :: ContactName -> Text -> Maybe Text -> Maybe LocalBadge -> StyledString
+optFullNameBadge c fullName shortDescr lb_ = case activeBadge lb_ of
+  Nothing -> optFullName c fullName shortDescr
+  Just (color, typeWord) -> " (" <> nameInner <> badgeStar color <> plain (" " <> typeWord) <> ")"
+  where
+    nameInner = maybe "" (\t -> plain (t <> ", ")) innerName
+    innerName
+      | T.null fullName || c == fullName = shortDescr
+      | otherwise = Just fullName
+
 ttyFullContact :: Contact -> StyledString
-ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName, shortDescr}} =
-  ttyFullName localDisplayName fullName shortDescr
+ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName, shortDescr, localBadge}} =
+  ttyFullNameBadge localDisplayName fullName shortDescr localBadge
 
 ttyMember :: GroupMember -> StyledString
 ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName
@@ -2816,7 +2869,8 @@ ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (vie
 ttyQuotedMember Nothing = ">"
 
 ttyFromContact :: Contact -> StyledString
-ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ")
+ttyFromContact ct@Contact {localDisplayName = c, profile = LocalProfile {localBadge}} =
+  ctIncognito ct <> ttyFrom (viewName c) <> badgeStarSep localBadge <> ttyFrom "> "
 
 ttyFromContactEdited :: Contact -> StyledString
 ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> [edited] ")