From f39498e4f6c761a2ffb87fe22bd1ea574bfe8ae3 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 9 Jun 2026 20:37:21 +0000 Subject: [PATCH] badge sign in CLI --- src/Simplex/Chat/View.hs | 74 +++++++++++++++++++++++++++++++------ tests/ChatTests/Profiles.hs | 22 +++++------ 2 files changed, 72 insertions(+), 24 deletions(-) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e8c823db88..e0023e68ed 100644 --- a/src/Simplex/Chat/View.hs +++ b/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 @@ -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' "" <> " 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 []" <> " to change it" ] ++ viewCommands @@ -1752,9 +1753,20 @@ 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" + BSFailed -> "verification failed" + 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 @@ -2785,9 +2797,48 @@ 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 + BTBusiness -> Nothing + +-- (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 +2867,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] ") diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 62b0383d81..d3277aff0c 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -17,16 +17,13 @@ import Control.Monad import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B -import Data.Maybe (listToMaybe) import qualified Data.Text as T -import Simplex.Chat.Badges (BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeStatus (..), BadgeType (..), generateMasterKey, issueBadge, localBadgeStatus, verifyPayment) -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt, withFastStore') -import Simplex.Chat.Library.Internal (chatStoreCxt) +import Simplex.Chat.Badges (BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Protocol (currentChatVersion) -import Simplex.Chat.Store.Direct (getUserContacts) import Simplex.Chat.Store.Shared (createContact) -import Simplex.Chat.Types (ConnStatus (..), Contact (Contact, localDisplayName, profile), LocalProfile (LocalProfile, localBadge), Profile (..), GroupRejectionReason (..)) +import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (bbsKeyGen) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) @@ -203,10 +200,13 @@ testUserBadgeBroadcast ps = do -- the same single-line JSON `simplex-chat badge sign` prints, pasted into the app alice ##> ("/badge add " <> T.unpack (encodeJSON cred)) alice <## "ok" - -- the badge XInfo is delivered in order before this message, so by the time bob shows it the badge is stored + -- own badge is shown (add succeeded) + alice ##> "/p" + alice <## "user profile: alice (Alice, * supporter)" + alice <## "use /p [] to change it" + -- the badge XInfo is delivered in order before this message, so the contact has stored it alice #> "@bob hi" - bob <# "alice> hi" - contactBadgeStatus bob "alice" `shouldReturn` Just BSActive + bob <# "alice *> hi" issueSupporterBadge sk pk = do drg <- C.newRandom mk <- generateMasterKey drg @@ -214,10 +214,6 @@ testUserBadgeBroadcast ps = do Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info} Right cred <- issueBadge sk pk vreq pure cred - contactBadgeStatus cc name = runCCUser cc $ \user -> do - cxt <- chatStoreCxt - cts <- withFastStore' $ \db -> getUserContacts db cxt user - pure $ listToMaybe [localBadgeStatus lb | Contact {localDisplayName, profile = LocalProfile {localBadge = Just lb}} <- cts, localDisplayName == name] testUpdateProfileImage :: HasCallStack => TestParams -> IO () testUpdateProfileImage =