diff --git a/src/Simplex/Chat/Mobile/Badges.hs b/src/Simplex/Chat/Mobile/Badges.hs new file mode 100644 index 0000000000..b509401ffa --- /dev/null +++ b/src/Simplex/Chat/Mobile/Badges.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Simplex.Chat.Mobile.Badges + ( cChatBadgeKeygen, + cChatBadgeIssue, + BadgeResult (..), + BadgeIssueReq (..), + BBSKeyPair (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import qualified Data.ByteString as B +import Data.Text (Text) +import qualified Data.Text as T +import Foreign.C (CString) +import Simplex.Chat.Badges +import Simplex.Chat.Mobile.Shared (CJSONString, newCStringFromLazyBS) +import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen) +import Simplex.Messaging.Parsers (defaultJSON) + +data BBSKeyPair = BBSKeyPair + { secretKey :: BBSSecretKey, + publicKey :: BBSPublicKey + } + +data BadgeIssueReq = BadgeIssueReq + { keyPair :: BBSKeyPair, + request :: BadgeRequest + } + +data BadgeResult r + = BadgeResult {result :: r} + | BadgeError {error :: Text} + +$(JQ.deriveJSON defaultJSON ''BBSKeyPair) + +$(JQ.deriveJSON defaultJSON ''BadgeIssueReq) + +$(pure []) + +instance ToJSON r => ToJSON (BadgeResult r) where + toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult) + toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult) + +instance FromJSON r => FromJSON (BadgeResult r) where + parseJSON = $(JQ.mkParseJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult) + +cChatBadgeKeygen :: IO CJSONString +cChatBadgeKeygen = + bbsKeyGen >>= \case + Right (sk, pk) -> encodeResult $ BadgeResult (BBSKeyPair sk pk) + Left e -> encodeResult @BBSKeyPair $ BadgeError (T.pack e) + +cChatBadgeIssue :: CString -> IO CJSONString +cChatBadgeIssue cReq = do + bs <- B.packCString cReq + encodeResult @BadgeCredential =<< case J.eitherDecodeStrict' bs of + Left e -> pure $ BadgeError (T.pack e) + Right BadgeIssueReq {keyPair = BBSKeyPair {secretKey, publicKey}, request} -> + either (BadgeError . T.pack) BadgeResult <$> issueBadge secretKey publicKey (VerifiedBadgeRequest request) + +encodeResult :: ToJSON r => BadgeResult r -> IO CJSONString +encodeResult = newCStringFromLazyBS . J.encode