diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index 41321edc68..f0501fef4f 100644 --- a/apps/simplex-chat/Main.hs +++ b/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) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index af3260c47e..3a1a8ff24b 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat/Badges/CLI.hs b/src/Simplex/Chat/Badges/CLI.hs new file mode 100644 index 0000000000..e46db34a2b --- /dev/null +++ b/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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 4a740cb838..57d796ac38 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index a2593c0db5..e5341ae695 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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), diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 75c1ac0628..91e32db9b4 100644 --- a/tests/BadgeTests.hs +++ b/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 diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 83e5629c1b..62b0383d81 100644 --- a/tests/ChatTests/Profiles.hs +++ b/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"