fix commands, ui

src/Simplex/Chat/Badges.hs

@@ -46,13 +46,10 @@ module Simplex.Chat.Badges
     rowToBadge,
   ) where
 
-import Control.Applicative ((<|>))
 import Control.Concurrent.STM
 import Crypto.Random (ChaChaDRG)
-import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
-import qualified Data.Aeson as J
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as JQ
-import Data.Aeson.Types (Parser)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.Text (Text)
@@ -138,28 +135,27 @@ deriving instance Eq (Badge 'BCCredential)
 
 deriving instance Eq (Badge 'BCProof)
 
--- Local badge: a stored badge (own credential or peer proof) plus its display status.
--- Existential - the inner Badge constructor is the discriminator.
-data LocalBadge = forall b. LocalBadge (Badge b) BadgeStatus
-
-sameBadgeCrypto :: Badge x -> Badge y -> Bool
-sameBadgeCrypto (BadgeCredential mk1 sg1 i1) (BadgeCredential mk2 sg2 i2) = mk1 == mk2 && sg1 == sg2 && i1 == i2
-sameBadgeCrypto (BadgeProof ph1 p1 i1) (BadgeProof ph2 p2 i2) = ph1 == ph2 && p1 == p2 && i1 == i2
-sameBadgeCrypto _ _ = False
-
-instance Show LocalBadge where
-  show (LocalBadge b st) = "LocalBadge (" <> show b <> ") " <> show st
-
-instance Eq LocalBadge where
-  LocalBadge b1 s1 == LocalBadge b2 s2 = s1 == s2 && sameBadgeCrypto b1 b2
+-- Local badge: a stored badge plus its display status.
+--   OwnBadge   - the user's own credential (loaded from the DB).
+--   PeerBadge  - a verified peer proof (from the DB, or received over the wire).
+--   ShownBadge - decoded from a crypto-free profile JSON for display only: no crypto, so it cannot be sent.
+data LocalBadge
+  = OwnBadge (Badge 'BCCredential) BadgeStatus
+  | PeerBadge (Badge 'BCProof) BadgeStatus
+  | ShownBadge BadgeInfo BadgeStatus
+  deriving (Eq, Show)
 
 localBadgeInfo :: LocalBadge -> BadgeInfo
-localBadgeInfo (LocalBadge b _) = case b of
-  BadgeCredential _ _ i -> i
-  BadgeProof _ _ i -> i
+localBadgeInfo = \case
+  OwnBadge (BadgeCredential _ _ i) _ -> i
+  PeerBadge (BadgeProof _ _ i) _ -> i
+  ShownBadge i _ -> i
 
 localBadgeStatus :: LocalBadge -> BadgeStatus
-localBadgeStatus (LocalBadge _ st) = st
+localBadgeStatus = \case
+  OwnBadge _ st -> st
+  PeerBadge _ st -> st
+  ShownBadge _ st -> st
 
 localBadgeVerified :: Maybe LocalBadge -> Maybe Bool
 localBadgeVerified = fmap $ \lb -> localBadgeStatus lb /= BSFailed
@@ -295,16 +291,18 @@ type BadgeRow = (Maybe ByteString, Maybe ByteString, Maybe UTCTime, Maybe Text,
 
 -- receive/store sites have a wire proof + a computed verified flag
 badgeToRow :: Maybe (Badge 'BCProof) -> Bool -> BadgeRow
-badgeToRow badge verified = localBadgeToRow $ (\b -> LocalBadge b (if verified then BSActive else BSFailed)) <$> badge
+badgeToRow badge verified = localBadgeToRow $ (\b -> PeerBadge b (if verified then BSActive else BSFailed)) <$> badge
 
 localBadgeToRow :: Maybe LocalBadge -> BadgeRow
-localBadgeToRow (Just (LocalBadge b st)) = case b of
-  BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) BadgeInfo {badgeType, badgeExpiry, badgeExtra} ->
-    (Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), Just (BI verified), Just badgeExtra, Just mk, Just sg)
-  BadgeProof (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra} ->
-    (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), Just (BI verified), Just badgeExtra, Nothing, Nothing)
+localBadgeToRow (Just lb) = case lb of
+  OwnBadge (BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) st ->
+    (Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), Just (BI (active st)), Just badgeExtra, Just mk, Just sg)
+  PeerBadge (BadgeProof (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) st ->
+    (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), Just (BI (active st)), Just badgeExtra, Nothing, Nothing)
+  ShownBadge BadgeInfo {badgeType, badgeExpiry, badgeExtra} st ->
+    (Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), Just (BI (active st)), Just badgeExtra, Nothing, Nothing)
   where
-    verified = st /= BSFailed
+    active st = st /= BSFailed
 localBadgeToRow Nothing = (Nothing, Nothing, Nothing, Nothing, Just (BI False), Nothing, Nothing, Nothing)
 
 rowToBadge :: UTCTime -> BadgeRow -> Maybe LocalBadge
@@ -315,9 +313,9 @@ rowToBadge now (p_, ph_, badgeExpiry, type_, verified_, extra_, mk_, sg_) = do
       verified = maybe False unBI verified_
       st = mkBadgeStatus now verified info
   case (mk_, sg_, p_, ph_) of
-    (Just mk, Just sg, _, _) -> Just $ LocalBadge (BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) info) st
-    (_, _, Just p, Just ph) -> Just $ LocalBadge (BadgeProof (BBSPresHeader ph) (BBSProof p) info) st
-    _ -> Nothing
+    (Just mk, Just sg, _, _) -> Just $ OwnBadge (BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) info) st
+    (_, _, Just p, Just ph) -> Just $ PeerBadge (BadgeProof (BBSPresHeader ph) (BBSProof p) info) st
+    _ -> Just $ ShownBadge info st
 
 -- JSON
 
@@ -357,13 +355,18 @@ instance FromJSON (Badge 'BCCredential) where
       JBadgeCredential mk sg i -> pure (BadgeCredential mk sg i)
       _ -> fail "expected badge credential"
 
--- LocalBadge round-trips (the inner Badge tags which crypto it is).
+-- LocalBadge is sent to the UI/clients WITHOUT crypto - only disclosed info + status. The credential/proof
+-- bytes stay core-side. FromJSON reconstructs a display-only badge (empty proof) for read-only consumers
+-- (remote host, UI echoes); the authoritative badge is loaded from the DB (rowToBadge), never from this JSON.
+data JSONBadge = JSONBadge {badge :: BadgeInfo, status :: BadgeStatus}
+
+$(JQ.deriveJSON defaultJSON ''JSONBadge)
+
 instance ToJSON LocalBadge where
-  toJSON (LocalBadge b st) = J.object ["badge" .= b, "status" .= st]
+  toJSON lb = toJSON $ JSONBadge (localBadgeInfo lb) (localBadgeStatus lb)
+  toEncoding lb = toEncoding $ JSONBadge (localBadgeInfo lb) (localBadgeStatus lb)
 
 instance FromJSON LocalBadge where
-  parseJSON = J.withObject "LocalBadge" $ \o -> do
-    st <- o .: "status"
-    bv <- o .: "badge"
-    (flip LocalBadge st <$> (parseJSON bv :: Parser (Badge 'BCProof)))
-      <|> (flip LocalBadge st <$> (parseJSON bv :: Parser (Badge 'BCCredential)))
+  parseJSON v = do
+    JSONBadge info st <- parseJSON v
+    pure $ ShownBadge info st

src/Simplex/Chat/Badges/CLI.hs

@@ -3,8 +3,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Offline operator tooling for supporter badges, invoked as `simplex-chat badge ...`.
--- `keygen` prints a base64url keypair (the public key is hardcoded into the app config);
--- `sign` mints a credential as one-line JSON to paste into the app via `/badge add`.
+--   keygen     - the issuer keypair (the "secret" signs; the "public" is hardcoded into the app config).
+--   master-key - the user's master secret (their unlinkability secret; generated client-side in the real flow).
+--   sign       - bind a user master secret to a badge with the issuer secret, printed as one-line JSON for `/badge add`.
 module Simplex.Chat.Badges.CLI (runBadgeCommand) where
 
 import qualified Data.Aeson as J
@@ -16,19 +17,26 @@ import Data.Time.Format (defaultTimeLocale, parseTimeM)
 import Options.Applicative
 import Simplex.Chat.Badges
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen)
 import Simplex.Messaging.Encoding.String (strDecode, strEncode, textDecode)
 import System.Exit (die)
 
+-- the issuer keypair is secret (32 bytes) <> public (96 bytes).
+bbsSecretLen, bbsPublicLen :: Int
+bbsSecretLen = 32
+bbsPublicLen = 96
+
 data BadgeCommand
   = Keygen
-  | Sign BBSSecretKey BBSPublicKey BadgeType (Maybe UTCTime)
+  | MasterKey
+  | Sign BBSSecretKey BBSPublicKey BadgeMasterKey BadgeType (Maybe UTCTime)
 
 runBadgeCommand :: [String] -> IO ()
 runBadgeCommand args =
   handleParseResult (execParserPure defaultPrefs badgeInfo args) >>= \case
     Keygen -> keygen
-    Sign sk pk badgeType badgeExpiry -> sign sk pk badgeType badgeExpiry
+    MasterKey -> genMasterKey
+    Sign sk pk ms badgeType badgeExpiry -> sign sk pk ms badgeType badgeExpiry
   where
     badgeInfo = info (helper <*> hsubparser badgeCmd) fullDesc
     badgeCmd = command "badge" (info (helper <*> badgeCommandP) (progDesc "SimpleX supporter badge tooling"))
@@ -36,16 +44,21 @@ runBadgeCommand args =
 badgeCommandP :: Parser BadgeCommand
 badgeCommandP =
   hsubparser $
-    command "keygen" (info (pure Keygen) (progDesc "generate a BBS issuer keypair (base64url)"))
-      <> command "sign" (info signP (progDesc "sign a badge credential, printed as one-line JSON"))
+    command "keygen" (info (pure Keygen) (progDesc "generate an issuer keypair (issuer secret + public, base64url)"))
+      <> command "master-key" (info (pure MasterKey) (progDesc "generate a user master secret (base64url)"))
+      <> command "sign" (info signP (progDesc "sign a badge for a user master secret, printed as one-line JSON"))
   where
     signP =
-      Sign
-        <$> keyOpt "secret" "SK" "issuer secret key (base64url)"
-        <*> keyOpt "key" "PK" "issuer public key (base64url)"
-        <*> option (eitherReader badgeTypeR) (long "type" <> metavar "TYPE" <> help "badge type (supporter, business, ...)")
+      (\(sk, pk) -> Sign sk pk)
+        <$> option (eitherReader issuerKeyR) (long "secret" <> metavar "ISSUER_KEY" <> help "issuer keypair from keygen (base64url)")
+        <*> option (eitherReader (strDecode . B.pack)) (long "master" <> metavar "MASTER" <> help "user master secret from master-key (base64url)")
+        <*> option (eitherReader badgeTypeR) (long "type" <> metavar "TYPE" <> help "badge type (supporter, legend, investor)")
         <*> option (eitherReader expireR) (long "expire" <> metavar "lifetime|YYYY-MM-DD" <> help "expiry date, or 'lifetime'")
-    keyOpt l m h = option (eitherReader $ strDecode . B.pack) (long l <> metavar m <> help h)
+    issuerKeyR s = do
+      kp <- strDecode (B.pack s)
+      if B.length kp == bbsSecretLen + bbsPublicLen
+        then let (sk, pk) = B.splitAt bbsSecretLen kp in Right (BBSSecretKey sk, BBSPublicKey pk)
+        else Left "bad issuer key - use the 'secret' value from keygen"
     badgeTypeR = maybe (Left "invalid badge type") Right . textDecode . T.pack
     expireR = \case
       "lifetime" -> Right Nothing
@@ -55,16 +68,20 @@ keygen :: IO ()
 keygen =
   bbsKeyGen >>= \case
     Left e -> die $ "keygen failed: " <> e
-    Right (sk, pk) -> do
-      B.putStrLn $ "secret " <> strEncode sk
+    Right (BBSSecretKey sk, BBSPublicKey pk) -> do
+      B.putStrLn $ "secret " <> strEncode (sk <> pk)
       B.putStrLn $ "public " <> strEncode pk
 
-sign :: BBSSecretKey -> BBSPublicKey -> BadgeType -> Maybe UTCTime -> IO ()
-sign secretKey publicKey badgeType badgeExpiry = do
+genMasterKey :: IO ()
+genMasterKey = do
   drg <- C.newRandom
-  masterKey <- generateMasterKey drg
-  let req = VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""}}
+  mk <- generateMasterKey drg
+  B.putStrLn $ strEncode mk
+
+sign :: BBSSecretKey -> BBSPublicKey -> BadgeMasterKey -> BadgeType -> Maybe UTCTime -> IO ()
+sign secretKey publicKey masterKey' badgeType badgeExpiry = do
+  let req = VerifiedBadgeRequest BadgeRequest {masterKey = masterKey', badgeInfo = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""}}
   issueBadge secretKey publicKey req >>= \case
     Left e -> die $ "sign failed: " <> e
-    -- single-line JSON, pasted into the app via `/badge add`
+    -- single-line JSON (master secret + signature + info), pasted into the app via `/badge add`
     Right cred -> LB.putStrLn $ J.encode cred

src/Simplex/Chat/Library/Commands.hs

@@ -4650,7 +4650,7 @@ addUserBadge user cred = do
   key <- asks $ badgePublicKey . config
   verified <- liftIO $ verifyCredential key cred
   unless verified $ throwCmdError "badge credential does not verify against configured key"
-  user' <- withFastStore' $ \db -> setUserBadge db user (Just (LocalBadge cred BSActive))
+  user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred BSActive))
   asks currentUser >>= atomically . (`writeTVar` Just user')
   cxt <- asks $ mkStoreCxt . config
   contacts <- withFastStore' $ \db -> getUserContacts db cxt user'

src/Simplex/Chat/Library/Internal.hs

@@ -1900,7 +1900,7 @@ sendDirectContactMessages' user ct events = do
 -- only own credentials present (peers carry proofs, which are not re-presented). callers must not present on incognito sends.
 presentUserBadge :: User -> Profile -> CM Profile
 presentUserBadge User {profile = LocalProfile {localBadge}} p = case localBadge of
-  Just (LocalBadge cred@BadgeCredential {} _) -> do
+  Just (OwnBadge cred _) -> do
     key <- asks $ badgePublicKey . config
     liftIO (badgeProof key cred PHTest) >>= \case
       Right proof -> pure p {badge = Just proof}

src/Simplex/Chat/Types.hs

@@ -782,16 +782,18 @@ toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> Bool -> Local
 toLocalProfile profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge} localAlias now verified =
   LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge, localAlias}
   where
-    localBadge = (\b@(BadgeProof _ _ info) -> LocalBadge b (mkBadgeStatus now verified info)) <$> badge
+    localBadge = (\b@(BadgeProof _ _ info) -> PeerBadge b (mkBadgeStatus now verified info)) <$> badge
 
 fromLocalProfile :: LocalProfile -> Profile
 fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge} =
   Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = localBadge >>= wireBadge}
   where
+    -- only a verified peer proof rides the wire; the own credential is presented fresh, and a display-only badge never sends
     wireBadge :: LocalBadge -> Maybe (Badge 'BCProof)
-    wireBadge (LocalBadge b _) = case b of
-      BadgeProof {} -> Just b
-      BadgeCredential {} -> Nothing
+    wireBadge = \case
+      PeerBadge b _ -> Just b
+      OwnBadge _ _ -> Nothing
+      ShownBadge _ _ -> Nothing
 
 profileBadgeVerified :: BBSPublicKey -> LocalProfile -> Profile -> IO Bool
 profileBadgeVerified key LocalProfile {localBadge} Profile {badge = newBadge} =