From ce5fc0a558583fd1adf7eb2648aaaa0887d0b89d Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sat, 6 Jun 2026 11:50:10 +0000 Subject: [PATCH] badges ffi --- cabal.project | 2 +- simplex-chat.cabal | 1 + src/Simplex/Chat/Badges.hs | 31 ++++++++++++++++++++----------- src/Simplex/Chat/Mobile.hs | 5 +++++ tests/BadgeTests.hs | 16 ++++++++-------- tests/MobileTests.hs | 24 ++++++++++++++++++++++++ 6 files changed, 59 insertions(+), 20 deletions(-) diff --git a/cabal.project b/cabal.project index 8c5cfffb02..068301d688 100644 --- a/cabal.project +++ b/cabal.project @@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 39bd7205e202061d96d145e63bca21c69e99e278 + tag: fffa088113ab840088393892bbaef9aa8eb0e851 source-repository-package type: git diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 7346fb0246..af3260c47e 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -52,6 +52,7 @@ library Simplex.Chat.Messages.CIContent Simplex.Chat.Messages.CIContent.Events Simplex.Chat.Mobile + Simplex.Chat.Mobile.Badges Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared Simplex.Chat.Mobile.WebRTC diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index 6be7d9d8b4..957c9f8eb8 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -112,7 +114,14 @@ data BadgePurchase -- Master key newtype BadgeMasterKey = BadgeMasterKey ByteString - deriving (Eq, Show) + deriving newtype (Eq, Show, StrEncoding) + +instance ToJSON BadgeMasterKey where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromJSON BadgeMasterKey where + parseJSON = strParseJSON "BadgeMasterKey" generateMasterKey :: TVar ChaChaDRG -> IO BadgeMasterKey generateMasterKey drg = BadgeMasterKey <$> atomically (C.randomBytes 32 drg) @@ -122,14 +131,11 @@ generateMasterKey drg = BadgeMasterKey <$> atomically (C.randomBytes 32 drg) data BadgeRequest = BadgeRequest { masterKey :: BadgeMasterKey, badgeType :: BadgeType, - payment :: BadgePurchase + expiry :: Maybe UTCTime } deriving (Show) -data VerifiedBadgeRequest = VerifiedBadgeRequest - { masterKey :: BadgeMasterKey, - badgeType :: BadgeType - } +newtype VerifiedBadgeRequest = VerifiedBadgeRequest BadgeRequest deriving (Show) data BadgeCredential = BadgeCredential @@ -172,14 +178,13 @@ badgeDisclosedMessages expiry bt = [encodeExpiry expiry, encodeUtf8 (textEncode -- Payment verification (stub - always passes) -verifyPayment :: BadgeRequest -> IO (Maybe VerifiedBadgeRequest) -verifyPayment BadgeRequest {masterKey, badgeType} = - pure $ Just VerifiedBadgeRequest {masterKey, badgeType} +verifyPayment :: BadgePurchase -> BadgeRequest -> IO (Maybe VerifiedBadgeRequest) +verifyPayment _payment req = pure $ Just (VerifiedBadgeRequest req) -- Server-side: issue a badge credential -issueBadge :: BBSSecretKey -> BBSPublicKey -> Maybe UTCTime -> VerifiedBadgeRequest -> IO (Either String BadgeCredential) -issueBadge sk pk expiry VerifiedBadgeRequest {masterKey, badgeType} = +issueBadge :: BBSSecretKey -> BBSPublicKey -> VerifiedBadgeRequest -> IO (Either String BadgeCredential) +issueBadge sk pk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeType, expiry}) = fmap mkCred <$> bbsSign sk pk bbsBadgeHeader (badgeMessages masterKey expiry badgeType) where mkCred sig = BadgeCredential {masterKey, signature = sig, badgeExpiry = expiry, badgeType} @@ -243,3 +248,7 @@ $(JQ.deriveJSON (enumJSON $ dropPrefix "BS") ''BadgeStatus) $(JQ.deriveJSON defaultJSON ''SupporterBadge) $(JQ.deriveJSON defaultJSON ''LocalBadge) + +$(JQ.deriveJSON defaultJSON ''BadgeRequest) + +$(JQ.deriveJSON defaultJSON ''BadgeCredential) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 281fc6b03b..d932194934 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -38,6 +38,7 @@ import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Library.Commands import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList, parseUri, sanitizeUri) +import Simplex.Chat.Mobile.Badges import Simplex.Chat.Mobile.File import Simplex.Chat.Mobile.Shared import Simplex.Chat.Mobile.WebRTC @@ -136,6 +137,10 @@ foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString foreign export ccall "chat_json_length" cChatJsonLength :: CString -> IO CInt +foreign export ccall "chat_badge_keygen" cChatBadgeKeygen :: IO CJSONString + +foreign export ccall "chat_badge_issue" cChatBadgeIssue :: CString -> IO CJSONString + foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index ee175ef689..899961148d 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -23,12 +23,12 @@ badgeTests = do testFullWorkflow :: IO () testFullWorkflow = do - (sk, pk) <- bbsKeyGen + Right (sk, pk) <- bbsKeyGen drg <- C.newRandom mk <- generateMasterKey drg - let req = BadgeRequest {masterKey = mk, badgeType = BTSupporter, payment = BPRedeemCode "TEST"} - Just vreq <- verifyPayment req - Right cred <- issueBadge sk pk (Just futureTime) vreq + let req = BadgeRequest {masterKey = mk, badgeType = BTSupporter, expiry = Just futureTime} + Just vreq <- verifyPayment (BPRedeemCode "TEST") req + Right cred <- issueBadge sk pk vreq let BadgeCredential {masterKey = mk'} = cred mk' `shouldBe` mk verifyBadgeSignature pk cred >>= (`shouldBe` True) @@ -51,7 +51,7 @@ testTamperedExpiry = do testWrongKey :: IO () testWrongKey = do (_, badge) <- issueBadgeProof BTSupporter (Just futureTime) - (_, pk2) <- bbsKeyGen + Right (_, pk2) <- bbsKeyGen verifyBadge pk2 badge >>= (`shouldBe` False) testExpiryCheck :: IO () @@ -85,10 +85,10 @@ pastTime = posixSecondsToUTCTime 1577836800 -- 2020-01-01 issueBadgeProof :: BadgeType -> Maybe UTCTime -> IO (BBSPublicKey, SupporterBadge) issueBadgeProof bt expiry = do - (sk, pk) <- bbsKeyGen + Right (sk, pk) <- bbsKeyGen drg <- C.newRandom mk <- generateMasterKey drg - let vreq = VerifiedBadgeRequest {masterKey = mk, badgeType = bt} - Right cred <- issueBadge sk pk expiry vreq + let vreq = VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeType = bt, expiry} + Right cred <- issueBadge sk pk vreq Right badge <- generateBadgeProof pk cred (BBSPresHeader "test-nonce") pure (pk, badge) diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index d57411a598..46fc17c3c8 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -32,8 +32,10 @@ import Foreign.Storable (peek) import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) import JSONFixtures import Simplex.Chat +import Simplex.Chat.Badges (BadgeRequest (..), BadgeType (..), generateMasterKey, verifyBadgeSignature) import Simplex.Chat.Controller (ChatController (..), ChatDatabase (..)) import Simplex.Chat.Mobile hiding (error) +import Simplex.Chat.Mobile.Badges hiding (error) import Simplex.Chat.Mobile.File import Simplex.Chat.Mobile.Shared import Simplex.Chat.Mobile.WebRTC @@ -81,6 +83,8 @@ mobileTests = do describe "Parsers" $ do it "should parse server address" testChatParseServer it "should parse and sanitize URI" testChatParseUri + describe "Badges" $ do + it "should generate key and issue badge via C API, verify credential" testBadgeKeygenIssueCApi noActiveUser :: LB.ByteString noActiveUser = @@ -308,6 +312,26 @@ testChatParseUri :: TestParams -> IO () testChatParseUri _ = do pure () +-- Generate a server keypair and issue a badge credential via the C FFI, +-- constructing the request from the typed records, then verify the issued +-- credential's BBS signature on the Haskell side. +testBadgeKeygenIssueCApi :: TestParams -> IO () +testBadgeKeygenIssueCApi _ = do + g <- C.newRandom + keyPair <- ffiResult =<< (peekCString =<< cChatBadgeKeygen) + let BBSKeyPair {publicKey} = keyPair + mk <- generateMasterKey g + let req = BadgeIssueReq {keyPair, request = BadgeRequest {masterKey = mk, badgeType = BTSupporter, expiry = Nothing}} + cred <- ffiResult =<< (peekCString =<< cChatBadgeIssue =<< newCString (LB.unpack (J.encode req))) + verifyBadgeSignature publicKey cred `shouldReturn` True + +-- Decode an FFI `BadgeResult` envelope, returning the result or failing on error. +ffiResult :: FromJSON r => String -> IO r +ffiResult s = case J.eitherDecode (LB.pack s) of + Right (BadgeResult r) -> pure r + Right (BadgeError e) -> error $ "badge FFI error: " <> show e + Left e -> error $ "badge FFI decode failed: " <> e <> " in " <> s + jDecode :: FromJSON a => String -> IO (Maybe a) jDecode = pure . J.decode . LB.pack