generate badge key and sign badge

src/Simplex/Chat/Badges/CLI.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# 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`.
+module Simplex.Chat.Badges.CLI (runBadgeCommand) where
+
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+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.Encoding.String (strDecode, strEncode, textDecode)
+import System.Exit (die)
+
+data BadgeCommand
+  = Keygen
+  | Sign BBSSecretKey BBSPublicKey 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
+  where
+    badgeInfo = info (helper <*> hsubparser badgeCmd) fullDesc
+    badgeCmd = command "badge" (info (helper <*> badgeCommandP) (progDesc "SimpleX supporter badge tooling"))
+
+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"))
+  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, ...)")
+        <*> 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)
+    badgeTypeR = maybe (Left "invalid badge type") Right . textDecode . T.pack
+    expireR = \case
+      "lifetime" -> Right Nothing
+      s -> maybe (Left "use 'lifetime' or YYYY-MM-DD") (Right . Just) $ parseTimeM True defaultTimeLocale "%Y-%m-%d" s
+
+keygen :: IO ()
+keygen =
+  bbsKeyGen >>= \case
+    Left e -> die $ "keygen failed: " <> e
+    Right (sk, pk) -> do
+      B.putStrLn $ "secret " <> strEncode sk
+      B.putStrLn $ "public " <> strEncode pk
+
+sign :: BBSSecretKey -> BBSPublicKey -> BadgeType -> Maybe UTCTime -> IO ()
+sign secretKey publicKey badgeType badgeExpiry = do
+  drg <- C.newRandom
+  masterKey <- generateMasterKey drg
+  let req = VerifiedBadgeRequest BadgeRequest {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`
+    Right cred -> LB.putStrLn $ J.encode cred

src/Simplex/Chat/Controller.hs

@@ -81,6 +81,7 @@ import Simplex.Messaging.Agent.Store.DB (SQLError)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyMode (..), SMPWebPortServers (..), SocksMode (..))
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Chat.Badges (Badge, BadgeCrypto (..))
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -577,6 +578,7 @@ data ChatCommand
   | SetBotCommands [ChatBotCommand]
   | UpdateProfile ContactName (Maybe Text) -- UserId (not used in UI)
   | UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI)
+  | AddBadge (Badge 'BCCredential) -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
   | ShowProfileImage
   | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
   | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)

src/Simplex/Chat/Library/Commands.hs

@@ -3294,6 +3294,7 @@ processChatCommand cxt nm = \case
           fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId
           pure $ CRFileTransferStatus user fileStatus
   ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
+  AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
   SetBotCommands commands -> withUser $ \user@User {profile} -> do
     let LocalProfile {preferences} = profile
         prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -5262,6 +5263,7 @@ chatCommandP =
       "/show profile image" $> ShowProfileImage,
       ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNameDescr),
       ("/profile" <|> "/p") $> ShowProfile,
+      "/badge add " *> (AddBadge <$> jsonP),
       "/set bot commands " *> (SetBotCommands <$> botCommandsP),
       "/delete bot commands" $> SetBotCommands [],
       "/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayNameP <*> _strP <*> optional memberRole),