core: simplex-badge-service scaffolding (#7353)

* core: simplex-badge-service scaffolding

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* clean-up

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

src/Simplex/Chat/Badges/Service.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Chat.Badges.Service
@@ -28,6 +30,7 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import Data.Int (Int64)
 import Data.Text (Text)
@@ -36,6 +39,7 @@ import Data.Word (Word8, Word16, Word32)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Store
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Version (VersionScope)
 import Simplex.Messaging.Version.Internal (Version (..))
 
@@ -241,4 +245,52 @@ data BadgeServiceErrorCode
   | BSEReceiptInvalid
   | BSEReceiptUsed
   | BSEInternal
+  | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
   deriving (Eq, Show)
+
+instance TextEncoding BadgeServiceErrorCode where
+  textEncode = \case
+    BSEBadRequest -> "bad_request"
+    BSEUnsupportedVersion -> "unsupported_version"
+    BSEUnknownPurchaseKey -> "unknown_purchase_key"
+    BSEUnknownOfferId -> "unknown_offer_id"
+    BSEOfferDisabled -> "offer_disabled"
+    BSEOfferMismatch -> "offer_mismatch"
+    BSEProductUnavailable -> "product_unavailable"
+    BSEPaymentNotEntitled -> "payment_not_entitled"
+    BSEPaymentPending -> "payment_pending"
+    BSEProviderUnavailable -> "provider_unavailable"
+    BSERateLimited -> "rate_limited"
+    BSECodeInvalid -> "code_invalid"
+    BSECodeUsed -> "code_used"
+    BSECodeExpired -> "code_expired"
+    BSEReceiptInvalid -> "receipt_invalid"
+    BSEReceiptUsed -> "receipt_used"
+    BSEInternal -> "internal"
+    BSEUnknown t -> t
+  textDecode s = Just $ case s of
+    "bad_request" -> BSEBadRequest
+    "unsupported_version" -> BSEUnsupportedVersion
+    "unknown_purchase_key" -> BSEUnknownPurchaseKey
+    "unknown_offer_id" -> BSEUnknownOfferId
+    "offer_disabled" -> BSEOfferDisabled
+    "offer_mismatch" -> BSEOfferMismatch
+    "product_unavailable" -> BSEProductUnavailable
+    "payment_not_entitled" -> BSEPaymentNotEntitled
+    "payment_pending" -> BSEPaymentPending
+    "provider_unavailable" -> BSEProviderUnavailable
+    "rate_limited" -> BSERateLimited
+    "code_invalid" -> BSECodeInvalid
+    "code_used" -> BSECodeUsed
+    "code_expired" -> BSECodeExpired
+    "receipt_invalid" -> BSEReceiptInvalid
+    "receipt_used" -> BSEReceiptUsed
+    "internal" -> BSEInternal
+    t -> BSEUnknown t
+
+instance ToJSON BadgeServiceErrorCode where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON BadgeServiceErrorCode where
+  parseJSON = textParseJSON "BadgeServiceErrorCode"

src/Simplex/Chat/Bot.hs

@@ -47,16 +47,17 @@ chatBotRepl welcome answer _user cc = do
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress = initializeBotAddress' True
+initializeBotAddress = initializeBotAddress' True Nothing True
 
-initializeBotAddress' :: Bool -> ChatController -> IO ()
-initializeBotAddress' logAddress cc = do
+-- pqRatchet_ selects the address type when creating: Just True (IKUsePQ) is required for service RPC, Nothing is the legacy non-DR contact address.
+initializeBotAddress' :: Bool -> Maybe Bool -> Bool -> ChatController -> IO ()
+initializeBotAddress' logAddress pqRatchet_ doAutoAccept cc = do
   sendChatCmd cc ShowMyAddress >>= \case
     Right (CRUserContactLink _ UserContactLink {connLinkContact}) -> showBotAddress connLinkContact
     Left (ChatErrorStore SEUserContactLinkNotFound) -> do
       when logAddress $ putStrLn "No bot address, creating..."
       -- TODO [short links] create short link by default
-      sendChatCmd cc (CreateMyAddress Nothing) >>= \case
+      sendChatCmd cc (CreateMyAddress pqRatchet_) >>= \case
         Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
@@ -65,7 +66,8 @@ initializeBotAddress' logAddress cc = do
       when logAddress $ do
         putStrLn $ "Bot's contact address is: " <> B.unpack (maybe (strEncode uri) strEncode shortUri)
         when (isJust shortUri) $ putStrLn $ "Full contact address for old clients: " <> B.unpack (strEncode uri)
-      let settings = AddressSettings {businessAddress = False, autoAccept = Just AutoAccept {acceptIncognito = False}, autoReply = Nothing}
+      let aa = if doAutoAccept then Just AutoAccept {acceptIncognito = False} else Nothing
+          settings = AddressSettings {businessAddress = False, autoAccept = aa, autoReply = Nothing}
       void $ sendChatCmd cc $ SetAddressSettings Nothing settings
 
 sendMessage :: ChatController -> Contact -> Text -> IO ()