generate badge key and sign badge

apps/simplex-chat/Main.hs

@@ -1,8 +1,14 @@
 module Main where
 
 import Server (simplexChatServer)
+import Simplex.Chat.Badges.CLI (runBadgeCommand)
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI)
+import System.Environment (getArgs)
 
 main :: IO ()
-main = simplexChatCLI terminalChatConfig (Just simplexChatServer)
+main = do
+  args <- getArgs
+  case args of
+    ("badge" : _) -> runBadgeCommand args
+    _ -> simplexChatCLI terminalChatConfig (Just simplexChatServer)

simplex-chat.cabal

@@ -39,6 +39,7 @@ library
       Simplex.Chat
       Simplex.Chat.AppSettings
       Simplex.Chat.Badges
+      Simplex.Chat.Badges.CLI
       Simplex.Chat.Call
       Simplex.Chat.Controller
       Simplex.Chat.Delivery

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),

tests/BadgeTests.hs

@@ -8,6 +8,7 @@ module BadgeTests (badgeTests) where
 
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import qualified Data.Aeson as J
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges
 import Simplex.Messaging.Crypto.BBS
@@ -22,6 +23,7 @@ badgeTests = do
   it "should compute badge status correctly" testExpiryCheck
   it "should treat lifetime badges as always active" testLifetimeBadge
   it "should accept unknown badge types" testUnknownBadgeType
+  it "credential serializes to a paste-able token and back" testCredentialSerialization
 
 proofOf :: Badge 'BCProof -> BBSProof
 proofOf (BadgeProof _ p _) = p
@@ -83,6 +85,23 @@ testUnknownBadgeType = do
   (pk, badge) <- issueBadgeProof (BTUnknown "future_type") (Just futureTime)
   verifyBadge pk badge >>= (`shouldBe` True)
 
+testCredentialSerialization :: IO ()
+testCredentialSerialization = do
+  Right (sk, pk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let mkCred expiry = do
+        Right cred <- issueBadge sk pk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}})
+        pure cred
+  dated <- mkCred (Just futureTime)
+  lifetime <- mkCred Nothing
+  J.eitherDecode (J.encode dated) `shouldBe` Right dated
+  J.eitherDecode (J.encode lifetime) `shouldBe` Right lifetime
+  -- a decoded credential still verifies against the issuing key
+  case J.eitherDecode (J.encode dated) of
+    Right cred -> verifyCredential pk cred >>= (`shouldBe` True)
+    Left e -> expectationFailure e
+
 -- Helpers
 
 futureTime :: UTCTime

tests/ChatTests/Profiles.hs

@@ -21,7 +21,6 @@ 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.Commands (addUserBadge)
 import Simplex.Chat.Library.Internal (chatStoreCxt)
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Protocol (currentChatVersion)
@@ -201,7 +200,9 @@ testUserBadgeBroadcast ps = do
     test sk pk alice bob = do
       connectUsers alice bob
       cred <- issueSupporterBadge sk pk
-      runCCUser alice (`addUserBadge` cred)
+      -- 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
       alice #> "@bob hi"
       bob <# "alice> hi"