badges ffi

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

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

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)

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

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)

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