From a8762e576f44b50c2cf68bbdb4501fb0a8c284ff Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 31 May 2026 08:05:25 +0000 Subject: [PATCH] update types --- plans/2026-05-30-service-framework.md | 102 +++++++++------------ src/Simplex/Chat/Service.hs | 126 +++++++++++++++----------- 2 files changed, 116 insertions(+), 112 deletions(-) diff --git a/plans/2026-05-30-service-framework.md b/plans/2026-05-30-service-framework.md index 23ad992041..d57f105b03 100644 --- a/plans/2026-05-30-service-framework.md +++ b/plans/2026-05-30-service-framework.md @@ -33,7 +33,7 @@ Send errors: `sendDirectContactMessage` can throw synchronous errors (contact no ### Badge service: custom APIs with persistence -Badge does NOT use `APICallService`. It has its own commands (`APIIssueBadge`, `APIRenewBadge`, `APIRedeemBadge`, `APIBadgeStripeLink`) that use the same underlying plumbing (send message to service contact, receive reply via Subscriber) but add persistence: +Badge does NOT use `APICallService`. It has its own commands (`APIIssueBadge`, `APIRedeemBadge`, `APIBadgeStripeLink`) that use the same underlying plumbing (send message to service contact, receive reply via Subscriber) but add persistence: - Before sending, persist `(ms, receipt, status=pending)` in DB - If response arrives after timeout or restart, Subscriber matches it to pending request, stores credential, notifies UI via event @@ -45,36 +45,32 @@ Badge does NOT use `APICallService`. It has its own commands (`APIIssueBadge`, ` ### Haskell -Per-service types are plain ADTs in their own modules: +Per-service command and response types are plain ADTs: ```haskell --- Simplex.Chat.Service.Badge data BadgeCommand - = BCIssue ByteString ByteString -- ms receipt (Apple/Google) - | BCRenew ByteString ByteString -- ms receipt - | BCRedeem Text -- redemption code - | BCStripeLink ByteString -- ms -> returns checkout URL + = BCIssue Text Text -- ms receipt (Apple/Google/Stripe) + | BCRedeem Text -- redemption code + | BCStripeLink Text -- ms, returns checkout URL data BadgeResponse - = BRCredential ByteString UTCTime Int -- signature expiry level - | BRStripeLink Text -- checkout URL + = BRCredential Text UTCTime Int -- signature expiry level + | BRStripeLink Text -- checkout URL | BRError Text --- Simplex.Chat.Service.Directory data DirectoryCommand = DCSearch Text -data DirectoryResponse = DRResult [GroupInfo] +data DirectoryResponse = DRResult [Text] --- Simplex.Chat.Service.Names -data NamesCommand = NCResolve SimplexNameInfo +data NamesCommand = NCResolve Text data NamesResponse - = NRResolved AConnectionLink + = NRResolved Text | NRNotFound | NRError Text ``` -Top-level GADT wraps per-service types with the type tag: +GADT wraps per-service types with the type tag: ```haskell data ServiceCommand (s :: ServiceType) where @@ -89,62 +85,42 @@ data ServiceResponse (s :: ServiceType) where data AServiceCommand = forall s. ServiceTypeI s => ASC (SServiceType s) (ServiceCommand s) data AServiceResponse = forall s. ServiceTypeI s => ASR (SServiceType s) (ServiceResponse s) +``` --- ChatCommand (Controller.hs ~line 480) +Chat API: + +```haskell +-- ChatCommand | APICallService UserId AServiceCommand --- ChatResponse (Controller.hs ~line 764) +-- ChatResponse | CRServiceResponse User AServiceResponse ``` -### Kotlin +### Serialization -```kotlin -// sealed class CC (SimpleXAPI.kt:3643) -class APICallService(val userId: Long, val serviceType: ServiceType, val command: ServiceCmd): CC() +Two JSON representations for per-service response types: -// ServiceType enum -enum class ServiceType { BADGE, DIRECTORY, NAMES } - -// ServiceCmd sealed per service type -sealed class ServiceCmd { - sealed class Badge : ServiceCmd() { - class Issue(val ms: String, val receipt: String) : Badge() - class Renew(val ms: String, val receipt: String) : Badge() - class Redeem(val code: String) : Badge() - class StripeLink(val ms: String) : Badge() - } - sealed class Names : ServiceCmd() { - class Resolve(val nameInfo: SimplexNameInfo) : Names() - } -} - -// sealed class CR (SimpleXAPI.kt:6347) -@Serializable @SerialName("serviceResponse") -class CRServiceResponse(val user: UserLike, val serviceType: ServiceType, val response: ServiceResp): CR() -``` - -### Command string format - -`/_service badge /issue ` - -Parser in Commands.hs extracts service type, dispatches to per-service parser: +**Platform-specific** (chat API, `CRServiceResponse` → Kotlin/Swift): uses `sumTypeJSON` which is `TaggedObject` on Kotlin (`{"type": "credential", ...}`) and `ObjectWithSingleField` + `_owsf` tag on iOS. Derived via TH: ```haskell -"/_service " *> do - serviceType_ <* A.space >>= \case - SSTBadge -> ASC SSTBadge <$> badgeCommandP - SSTDirectory -> ASC SSTDirectory <$> directoryCommandP - SSTNames -> ASC SSTNames <$> namesCommandP +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BR") ''BadgeResponse) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DR") ''DirectoryResponse) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "NR") ''NamesResponse) ``` -where `serviceType_` parses `"badge"` / `"directory"` / `"names"` into the singleton. +**Platform-independent** (wire YAML, messages between app and service bot): uses `singleFieldJSON` (`ObjectWithSingleField`, no `_owsf` tag). Single-key discriminated union. Via `ServiceJSON` newtype: -### Wire format (messages between app and service bot) +```haskell +newtype ServiceJSON a = ServiceJSON {serviceJSON :: a} -Commands sent as text: `/ [args...]` +-- TH helper generates ToJSON/FromJSON for ServiceJSON a using singleFieldJSON +$(deriveServiceJSON (dropPrefix "BR") ''BadgeResponse) +$(deriveServiceJSON (dropPrefix "DR") ''DirectoryResponse) +$(deriveServiceJSON (dropPrefix "NR") ''NamesResponse) +``` -Responses as YAML discriminated union (top-level key is the tag): +Wire YAML examples: ```yaml credential: @@ -164,7 +140,19 @@ error: message: This receipt has already been redeemed ``` -Correlation: service responds with reply-to referencing the command message. +`AServiceResponse` has manual `ToJSON`/`FromJSON` instances for the chat API (wrapping the service type tag + platform-specific response JSON). + +Commands are parsed from strings (attoparsec), not JSON. No JSON instances for command types. + +### Command string format + +`/_service badge /issue ` + +Parser dispatches on service type, then to per-service command parser. + +### Correlation + +Service responds with reply-to referencing the command message (`quotedSharedMsgId`). ## Service contacts diff --git a/src/Simplex/Chat/Service.hs b/src/Simplex/Chat/Service.hs index a435787dab..86d7818105 100644 --- a/src/Simplex/Chat/Service.hs +++ b/src/Simplex/Chat/Service.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -13,11 +13,13 @@ module Simplex.Chat.Service where import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.Types as JT import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Type.Equality -import Simplex.Messaging.Agent.Protocol (AConnectionLink) -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON) +import Simplex.Messaging.Parsers (dropPrefix, enumJSON, singleFieldJSON, sumTypeJSON) + +-- Service type data ServiceType = STBadge | STDirectory | STNames deriving (Eq, Ord, Show) @@ -45,7 +47,21 @@ instance ServiceTypeI 'STDirectory where sServiceType = SSTDirectory instance ServiceTypeI 'STNames where sServiceType = SSTNames --- Badge +toServiceType :: SServiceType s -> ServiceType +toServiceType = \case + SSTBadge -> STBadge + SSTDirectory -> STDirectory + SSTNames -> STNames + +aServiceType :: ServiceType -> AServiceType +aServiceType = \case + STBadge -> AST SSTBadge + STDirectory -> AST SSTDirectory + STNames -> AST SSTNames + +data AServiceType = forall s. ServiceTypeI s => AST (SServiceType s) + +-- Per-service command types data BadgeCommand = BCIssue Text Text @@ -53,27 +69,25 @@ data BadgeCommand | BCStripeLink Text deriving (Show) +data DirectoryCommand = DCSearch Text + deriving (Show) + +data NamesCommand = NCResolve Text + deriving (Show) + +-- Per-service response types + data BadgeResponse = BRCredential Text UTCTime Int | BRStripeLink Text | BRError Text deriving (Show) --- Directory - -data DirectoryCommand = DCSearch Text - deriving (Show) - data DirectoryResponse = DRResult [Text] deriving (Show) --- Names - -data NamesCommand = NCResolve Text - deriving (Show) - data NamesResponse - = NRResolved AConnectionLink + = NRResolved Text | NRNotFound | NRError Text deriving (Show) @@ -104,56 +118,58 @@ data AServiceResponse = forall s. ServiceTypeI s => ASR (SServiceType s) (Servic deriving instance Show AServiceResponse +-- Platform JSON for per-service response types (for chat API -> Kotlin/Swift) + $(JQ.deriveJSON (enumJSON $ dropPrefix "ST") ''ServiceType) -instance ToJSON (SServiceType s) where - toJSON = toJSON . serviceType - where - serviceType :: SServiceType s -> ServiceType - serviceType SSTBadge = STBadge - serviceType SSTDirectory = STDirectory - serviceType SSTNames = STNames - -$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BC") ''BadgeCommand) - $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BR") ''BadgeResponse) -$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DC") ''DirectoryCommand) - $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DR") ''DirectoryResponse) -$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "NC") ''NamesCommand) - $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "NR") ''NamesResponse) -instance ToJSON AServiceCommand where - toJSON (ASC sst cmd) = J.object ["serviceType" J..= sst, "command" J..= cmdJSON sst cmd] - where - cmdJSON :: SServiceType s -> ServiceCommand s -> J.Value - cmdJSON SSTBadge (SCBadge c) = toJSON c - cmdJSON SSTDirectory (SCDirectory c) = toJSON c - cmdJSON SSTNames (SCNames c) = toJSON c +instance ToJSON (SServiceType s) where + toJSON = J.toJSON . toServiceType + toEncoding = J.toEncoding . toServiceType instance ToJSON AServiceResponse where - toJSON (ASR sst resp) = J.object ["serviceType" J..= sst, "response" J..= respJSON sst resp] - where - respJSON :: SServiceType s -> ServiceResponse s -> J.Value - respJSON SSTBadge (SRBadge r) = toJSON r - respJSON SSTDirectory (SRDirectory r) = toJSON r - respJSON SSTNames (SRNames r) = toJSON r - -instance FromJSON AServiceCommand where - parseJSON = J.withObject "AServiceCommand" $ \o -> do - sType <- o J..: "serviceType" - case (sType :: ServiceType) of - STBadge -> ASC SSTBadge . SCBadge <$> o J..: "command" - STDirectory -> ASC SSTDirectory . SCDirectory <$> o J..: "command" - STNames -> ASC SSTNames . SCNames <$> o J..: "command" + toJSON (ASR sst resp) = J.object ["type" J..= sst, "response" J..= respJSON sst resp] + toEncoding (ASR sst resp) = J.pairs ("type" J..= sst <> "response" J..= respJSON sst resp) instance FromJSON AServiceResponse where parseJSON = J.withObject "AServiceResponse" $ \o -> do - sType <- o J..: "serviceType" - case (sType :: ServiceType) of - STBadge -> ASR SSTBadge . SRBadge <$> o J..: "response" - STDirectory -> ASR SSTDirectory . SRDirectory <$> o J..: "response" - STNames -> ASR SSTNames . SRNames <$> o J..: "response" + sType <- o J..: "type" + case aServiceType sType of + AST SSTBadge -> ASR SSTBadge . SRBadge <$> o J..: "response" + AST SSTDirectory -> ASR SSTDirectory . SRDirectory <$> o J..: "response" + AST SSTNames -> ASR SSTNames . SRNames <$> o J..: "response" + +respJSON :: SServiceType s -> ServiceResponse s -> J.Value +respJSON SSTBadge (SRBadge r) = toJSON r +respJSON SSTDirectory (SRDirectory r) = toJSON r +respJSON SSTNames (SRNames r) = toJSON r + +-- Wire YAML for service bot messages (platform-independent, singleFieldJSON) + +newtype ServiceJSON a = ServiceJSON {serviceJSON :: a} + +instance ToJSON (ServiceJSON BadgeResponse) where + toJSON (ServiceJSON r) = $(JQ.mkToJSON (singleFieldJSON $ dropPrefix "BR") ''BadgeResponse) r + toEncoding (ServiceJSON r) = $(JQ.mkToEncoding (singleFieldJSON $ dropPrefix "BR") ''BadgeResponse) r + +instance FromJSON (ServiceJSON BadgeResponse) where + parseJSON v = ServiceJSON <$> $(JQ.mkParseJSON (singleFieldJSON $ dropPrefix "BR") ''BadgeResponse) v + +instance ToJSON (ServiceJSON DirectoryResponse) where + toJSON (ServiceJSON r) = $(JQ.mkToJSON (singleFieldJSON $ dropPrefix "DR") ''DirectoryResponse) r + toEncoding (ServiceJSON r) = $(JQ.mkToEncoding (singleFieldJSON $ dropPrefix "DR") ''DirectoryResponse) r + +instance FromJSON (ServiceJSON DirectoryResponse) where + parseJSON v = ServiceJSON <$> $(JQ.mkParseJSON (singleFieldJSON $ dropPrefix "DR") ''DirectoryResponse) v + +instance ToJSON (ServiceJSON NamesResponse) where + toJSON (ServiceJSON r) = $(JQ.mkToJSON (singleFieldJSON $ dropPrefix "NR") ''NamesResponse) r + toEncoding (ServiceJSON r) = $(JQ.mkToEncoding (singleFieldJSON $ dropPrefix "NR") ''NamesResponse) r + +instance FromJSON (ServiceJSON NamesResponse) where + parseJSON v = ServiceJSON <$> $(JQ.mkParseJSON (singleFieldJSON $ dropPrefix "NR") ''NamesResponse) v