mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-07-09 12:21:47 +00:00
core: service framework, types and plan, badges plan
This commit is contained in:
Evgeny @ SimpleX Chat
@@ -0,0 +1,200 @@
|
||||
# SimpleX Chat Service Framework
|
||||
|
||||
Services are bot contacts hidden from the user. The app sends commands and receives responses programmatically. Messages are stored and visible in dev tools for auditing.
|
||||
|
||||
## Services
|
||||
|
||||
- Badge - supporter badge credential issuance
|
||||
- Directory - group/channel discovery (existing bot, to be migrated)
|
||||
- Name resolution - resolve `#channel.simplex` / `@contact.simplex` to connection links
|
||||
- Later: telemetry, LLM, translation, notification server migration
|
||||
|
||||
## How it works
|
||||
|
||||
### Synchronous RPC via TMVar
|
||||
|
||||
The relay test code (Commands.hs:1584-1601, Subscriber.hs:423-446) already does this:
|
||||
|
||||
1. Handler sends command as text message via `sendDirectContactMessage` (Internal.hs:1913), gets back `SndMessage {sharedMsgId}` and the connection's `AgentConnId`
|
||||
2. Creates empty `TMVar`, stores in `chatServiceCalls :: TMap (AgentConnId, SharedMsgId) (TMVar Text)` (new field on `ChatController`, same pattern as `chatRelayTests`)
|
||||
3. Blocks on `timeout 30s $ atomically $ takeTMVar`
|
||||
4. Subscriber receives reply with `quotedSharedMsgId` referencing the command, looks up `chatServiceCalls` by `(agentConnId, quotedSharedMsgId)`, fills TMVar via `putTMVar`
|
||||
5. Handler unblocks, parses response, returns `CRServiceResponse`
|
||||
|
||||
Keyed by `(AgentConnId, SharedMsgId)` - globally unique, supports concurrent commands to the same service.
|
||||
|
||||
For idempotent services (directory, names): if user retries the same command while a previous attempt is pending, key by `(serviceType, commandHash)` so a response to attempt 1 can satisfy attempt 2's TMVar. The answer to the same query is the same regardless of which attempt triggered it. If response arrives after timeout, it's dropped.
|
||||
|
||||
### Command/response flow through the app
|
||||
|
||||
Kotlin/Swift UI calls `sendCmd(CC.APICallService(...))` (same FFI path as all commands, Core.kt:27). The string `/_service directory /search ...` goes to Haskell via `chatSendCmdRetry`. Each FFI call runs on its own thread (`Dispatchers.IO` on Kotlin, async task on Swift). Haskell blocks that thread on the TMVar until the service replies (up to 30s). Other API calls run concurrently on other threads - no global blocking. Response JSON comes back synchronously. Kotlin/Swift deserializes `CR.CRServiceResponse`.
|
||||
|
||||
Send errors: `sendDirectContactMessage` can throw synchronous errors (contact not ready, connection disabled). Async errors - `MERR` (delivery failure, line 478), `ERR` (line 484), connection failures - arrive via Subscriber and should fill the TMVar with an error so the handler fails fast. `DOWN` events should NOT fill with error - the connection may recover within the timeout.
|
||||
|
||||
### 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:
|
||||
|
||||
- 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
|
||||
- On app restart, check for pending requests and re-send commands
|
||||
- Server must be idempotent: same receipt re-sent returns same credential, not an error
|
||||
- Stripe flow: `/stripe_link` gets immediate reply with URL, credential arrives as delayed reply to same command after payment
|
||||
|
||||
## Types
|
||||
|
||||
### Haskell
|
||||
|
||||
Per-service types are plain ADTs in their own modules:
|
||||
|
||||
```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
|
||||
|
||||
data BadgeResponse
|
||||
= BRCredential ByteString UTCTime Int -- signature expiry level
|
||||
| BRStripeLink Text -- checkout URL
|
||||
| BRError Text
|
||||
|
||||
-- Simplex.Chat.Service.Directory
|
||||
data DirectoryCommand = DCSearch Text
|
||||
|
||||
data DirectoryResponse = DRResult [GroupInfo]
|
||||
|
||||
-- Simplex.Chat.Service.Names
|
||||
data NamesCommand = NCResolve SimplexNameInfo
|
||||
|
||||
data NamesResponse
|
||||
= NRResolved AConnectionLink
|
||||
| NRNotFound
|
||||
| NRError Text
|
||||
```
|
||||
|
||||
Top-level GADT wraps per-service types with the type tag:
|
||||
|
||||
```haskell
|
||||
data ServiceCommand (s :: ServiceType) where
|
||||
SCBadge :: BadgeCommand -> ServiceCommand 'STBadge
|
||||
SCDirectory :: DirectoryCommand -> ServiceCommand 'STDirectory
|
||||
SCNames :: NamesCommand -> ServiceCommand 'STNames
|
||||
|
||||
data ServiceResponse (s :: ServiceType) where
|
||||
SRBadge :: BadgeResponse -> ServiceResponse 'STBadge
|
||||
SRDirectory :: DirectoryResponse -> ServiceResponse 'STDirectory
|
||||
SRNames :: NamesResponse -> ServiceResponse 'STNames
|
||||
|
||||
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)
|
||||
| APICallService UserId AServiceCommand
|
||||
|
||||
-- ChatResponse (Controller.hs ~line 764)
|
||||
| CRServiceResponse User AServiceResponse
|
||||
```
|
||||
|
||||
### Kotlin
|
||||
|
||||
```kotlin
|
||||
// sealed class CC (SimpleXAPI.kt:3643)
|
||||
class APICallService(val userId: Long, val serviceType: ServiceType, val command: ServiceCmd): CC()
|
||||
|
||||
// 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 <base64_ms> <base64_receipt>`
|
||||
|
||||
Parser in Commands.hs extracts service type, dispatches to per-service parser:
|
||||
|
||||
```haskell
|
||||
"/_service " *> do
|
||||
serviceType_ <* A.space >>= \case
|
||||
SSTBadge -> ASC SSTBadge <$> badgeCommandP
|
||||
SSTDirectory -> ASC SSTDirectory <$> directoryCommandP
|
||||
SSTNames -> ASC SSTNames <$> namesCommandP
|
||||
```
|
||||
|
||||
where `serviceType_` parses `"badge"` / `"directory"` / `"names"` into the singleton.
|
||||
|
||||
### Wire format (messages between app and service bot)
|
||||
|
||||
Commands sent as text: `/<command> [args...]`
|
||||
|
||||
Responses as YAML discriminated union (top-level key is the tag):
|
||||
|
||||
```yaml
|
||||
credential:
|
||||
signature: ABase64=
|
||||
expiry: 2026-07-31T23:59:59Z
|
||||
level: 1
|
||||
```
|
||||
|
||||
```yaml
|
||||
stripe_link:
|
||||
url: https://checkout.stripe.com/c/pay/...
|
||||
```
|
||||
|
||||
```yaml
|
||||
error:
|
||||
type: receipt_already_used
|
||||
message: This receipt has already been redeemed
|
||||
```
|
||||
|
||||
Correlation: service responds with reply-to referencing the command message.
|
||||
|
||||
## Service contacts
|
||||
|
||||
- Service declares `peerType = CPTBot` in its profile (existing field)
|
||||
- Local `connService :: Bool` flag on `Contact` record (Types.hs). Set when connecting to a known service address. Filters from chat list. Not in the protocol.
|
||||
- Messages stored like regular chat items - audit trail in dev tools
|
||||
|
||||
## Connection
|
||||
|
||||
The `APICallService` handler manages connection itself, same as the relay test (Commands.hs:1581-1593) which connects and waits for a response all within one handler. If the service isn't connected, the handler connects via the agent, waits for the connection to be established (TMVar filled by Subscriber on `ContactConnected`), then sends the command and waits for the reply. All within one blocking FFI call.
|
||||
|
||||
1. UI calls `/_service badge /issue ...`
|
||||
2. Haskell handler checks if service contact exists and is connected
|
||||
3. If not connected: connects, waits for connection, then sends command
|
||||
4. If connected: sends command directly
|
||||
5. Blocks on TMVar for reply, returns `CRServiceResponse`
|
||||
6. Connection stays open for future calls
|
||||
|
||||
Service chat is configured with 1-week message retention (existing `chatSettings.ttl` property). Messages auto-delete after a week.
|
||||
|
||||
Services can send multiple replies to the same command (same `quotedSharedMsgId`). First reply fills TMVar (synchronous return to caller). Subsequent replies are matched by the Subscriber via pending requests in DB. Example: `/stripe_link` gets an immediate reply with the checkout URL, then a delayed reply with the credential after payment.
|
||||
|
||||
Unsolicited messages from services (no `quotedSharedMsgId`) are stored as chat items. Future: specific service event types could be surfaced via a `CR` variant.
|
||||
|
||||
Service addresses: badge is hardcoded (not configurable), directory and names are user-configurable (user can point to different providers). Stored in app preferences alongside other server settings.
|
||||
|
||||
## Phases
|
||||
|
||||
1. Framework: types, `APICallService`/`CRServiceResponse`, TMVar plumbing, `connService` flag, chat list filtering
|
||||
2. Badge service (first on the framework)
|
||||
3. Directory migration
|
||||
4. Name resolution
|
||||
5. User-configurable addresses in settings UI
|
||||
@@ -0,0 +1,150 @@
|
||||
# Supporter Badges
|
||||
|
||||
Privacy-preserving supporter badges using BBS+ signatures. Users purchase a subscription, receive a BBS+ credential from our server, and generate unlinkable per-context proofs that recipients verify locally.
|
||||
|
||||
## Crypto Scheme
|
||||
|
||||
**BBS+ signatures** via `libbbs` (Fraunhofer-AISEC, Apache-2.0, built on `blst`).
|
||||
IETF draft: draft-irtf-cfrg-bbs-signatures.
|
||||
|
||||
- Server holds long-lived BBS+ keypair (srvSK, srvPK). srvPK hardcoded in app.
|
||||
- 3 signed messages: `[ms, expiry, level]`
|
||||
- `ms` (32 bytes): random master secret, generated by client
|
||||
- `expiry`: end of next month (same for all subscribers in a period - large anonymity set)
|
||||
- `level`: subscription tier (1 or 2 for MVP, special value for lifetime/investor badges)
|
||||
- `ms` is undisclosed (index 0), `expiry` and `level` disclosed (indexes 1, 2)
|
||||
- Proof size: 304 bytes (272 base + 32 per undisclosed message)
|
||||
|
||||
No blind signing needed. Server sees `ms` during signing but BBS+ ZK property means it cannot link any received proof to any `ms`. Server also doesn't see client IP (SMP proxy).
|
||||
|
||||
## Purchase Flow
|
||||
|
||||
1. Client generates random 32-byte `ms`
|
||||
2. Client purchases subscription via platform (iOS/Android/Stripe)
|
||||
3. Client sends `(ms, receipt)` to badge server via SMP proxy
|
||||
4. Server verifies receipt, computes `expiry = end of next month`
|
||||
5. Server calls `bbs_sign(sk, pk, sig, "", 3, [ms, expiry, level])`
|
||||
6. Server stores `hash(receipt_id)` to prevent double-issuance, discards everything else
|
||||
7. Returns `(signature, expiry, level)` to client
|
||||
8. Client stores `(ms, signature, expiry, level)` in Keychain/Keystore, bound to chosen profile
|
||||
|
||||
## Payment Platforms
|
||||
|
||||
| Platform | Verification | Notes |
|
||||
|----------|-------------|-------|
|
||||
| iOS | StoreKit 2 auto-renewing subscription, offline JWS verification (Apple Root CA G3) | No Apple server contact |
|
||||
| Android (Play) | Google Play Billing, server verifies via Google Play Developer API | Server-to-server call needed |
|
||||
| F-Droid / Desktop | Stripe Checkout in browser, session polling | Card details never touch our app |
|
||||
|
||||
## Badge Service
|
||||
|
||||
A hidden service the app communicates with over SMP - not a user-visible bot. The app has a hardcoded SMP address for the service. On purchase, the app sends the receipt + `ms` as a protocol message, receives the credential back. The UI shows purchase progress/success/error directly - the user never sees a chat conversation.
|
||||
|
||||
**Flows:**
|
||||
- **iOS/Android:** User taps "Support SimpleX" in settings, purchases via StoreKit/Play Billing. App automatically sends receipt + `ms` to badge service, receives credential, stores it. User sees success in the UI.
|
||||
- **F-Droid/Desktop:** App gets a Stripe payment link from the service, opens in browser. After payment (Stripe webhook notifies service), app receives credential.
|
||||
- **Investor badges:** User enters redemption code in settings UI, app sends code to service, receives lifetime credential.
|
||||
|
||||
**Service state:**
|
||||
- BBS+ keypair (srvSK, srvPK) in a file
|
||||
- SQLite: `issued_receipts (receipt_hash BLOB PRIMARY KEY, platform TEXT, issued_at TEXT)`
|
||||
- Receipt verification: Apple JWS offline, Google Play API, Stripe webhooks
|
||||
- Nothing about users
|
||||
|
||||
## Protocol Integration
|
||||
|
||||
### Profile type
|
||||
|
||||
Add optional `badge` field to `Profile`:
|
||||
|
||||
```haskell
|
||||
data SupporterBadge = SupporterBadge
|
||||
{ proof :: ByteString -- BBS+ proof (304 bytes)
|
||||
, presentationHeader :: ByteString -- random nonce (32 bytes)
|
||||
, badgeExpiry :: UTCTime -- disclosed: end of month
|
||||
, badgeLevel :: Int -- disclosed: subscription level
|
||||
}
|
||||
```
|
||||
|
||||
Backward compatible: older clients ignore unknown JSON fields (`omitNothingFields`).
|
||||
|
||||
### Proof generation (sending)
|
||||
|
||||
Function `attachBadgeProof` wraps profile before sending:
|
||||
1. Check user has valid credential in DB
|
||||
2. Check connection is NOT incognito - if incognito, no badge
|
||||
3. Generate fresh random `presentation_header` (32 bytes)
|
||||
4. Call `bbs_proof_gen(pk, sig, "", presentationHeader, disclosed=[1,2], [ms, expiry, level])`
|
||||
5. Return profile with `badge` field populated
|
||||
|
||||
Injection points: every `XInfo`, `XContact`, `XGrpMemInfo`, `XGrpLinkMem` send path.
|
||||
|
||||
### Proof verification (receiving)
|
||||
|
||||
On receiving profile with `badge`:
|
||||
1. `bbs_proof_verify(srvPK, proof, "", presentationHeader, disclosed=[1,2], [expiry, level])`
|
||||
2. Check `expiry >= now`
|
||||
3. Store `badge_status` on contact/member in DB
|
||||
|
||||
### Groups vs contacts
|
||||
|
||||
- **Contacts:** Fresh proof per contact (different `presentationHeader` = unlinkable)
|
||||
- **Groups:** One proof per group (members already know you're the same person). Different groups get different proofs.
|
||||
|
||||
## Credential Storage
|
||||
|
||||
- `badge_credentials` table: `(user_id PK, master_secret, signature, expiry, level, platform, created_at, updated_at)`
|
||||
- `ms` stored encrypted (Keychain on iOS, Keystore on Android, encrypted file on desktop)
|
||||
- Bound to one profile: one purchase = one profile. Multiple profiles need multiple purchases.
|
||||
- Badge status on contacts/members: `badge_status` column on `contacts` and `group_members` tables
|
||||
|
||||
## Renewal
|
||||
|
||||
- Auto-renewing subscriptions on iOS/Android
|
||||
- StoreKit `Transaction.updates` / Play Billing callback detects renewal
|
||||
- Client sends new receipt with same `ms` to badge server
|
||||
- Server issues new signature with new expiry
|
||||
- New proofs generated naturally on next profile send
|
||||
- If subscription lapses: badge expires, recipients see it expired, client stops attaching badges
|
||||
|
||||
## Levels
|
||||
|
||||
- Level 1: basic supporter
|
||||
- Level 2: premium supporter (higher contribution)
|
||||
- Level 99 (or similar): lifetime/investor badge (expiry = 2099-12-31, issued via redemption code)
|
||||
- Different levels show different icons in UI
|
||||
|
||||
## Privacy Properties
|
||||
|
||||
1. Server sees `ms` + receipt but cannot link proofs to issuances (BBS+ ZK)
|
||||
2. Server doesn't see client IP (SMP proxy)
|
||||
3. Different contacts see unlinkable proofs (different presentation_header)
|
||||
4. Different groups see unlinkable proofs
|
||||
5. Expiry is coarse-grained (end of month) - not a per-user timestamp
|
||||
6. Incognito profiles never show badges
|
||||
7. Receipt hash is the only server-side state - no user identity
|
||||
|
||||
## libbbs Integration
|
||||
|
||||
- Vendor libbbs + blst C sources into simplexmq
|
||||
- Haskell FFI bindings following SNTRUP761 pattern (`Simplex.Messaging.Crypto.BBS.Bindings`)
|
||||
- 5 FFI functions: `bbs_keygen_full`, `bbs_sign`, `bbs_proof_gen`, `bbs_proof_verify`, `bbs_sha256_ciphersuite`
|
||||
- Use blst portable C fallback for MVP (avoids per-arch assembly)
|
||||
|
||||
## Implementation Phases
|
||||
|
||||
1. **Crypto:** libbbs FFI bindings + tests
|
||||
2. **Types & protocol:** Profile changes, proof gen/verify wiring, DB migration
|
||||
3. **Badge server:** receipt verification, issuance endpoint
|
||||
4. **iOS:** StoreKit 2, Keychain storage, UI
|
||||
5. **Android:** Play Billing + Stripe fallback, UI
|
||||
6. **Desktop:** Stripe, UI
|
||||
|
||||
## Key Files
|
||||
|
||||
- `simplexmq/src/Simplex/Messaging/Crypto/BBS/Bindings.hs` - FFI (new)
|
||||
- `simplex-chat/src/Simplex/Chat/Types.hs` - Profile + SupporterBadge types
|
||||
- `simplex-chat/src/Simplex/Chat/Library/Internal.hs` - proof injection into profile sending
|
||||
- `simplex-chat/src/Simplex/Chat/Library/Subscriber.hs` - proof verification on receive
|
||||
- `simplex-chat/src/Simplex/Chat/Controller.hs` - API commands for badge credential
|
||||
- `simplex-chat/src/Simplex/Chat/Store/Badge.hs` - credential storage (new)
|
||||
@@ -61,6 +61,7 @@ library
|
||||
Simplex.Chat.Options.DB
|
||||
Simplex.Chat.ProfileGenerator
|
||||
Simplex.Chat.Protocol
|
||||
Simplex.Chat.Service
|
||||
Simplex.Chat.Remote
|
||||
Simplex.Chat.Remote.AppVersion
|
||||
Simplex.Chat.Remote.Multicast
|
||||
|
||||
@@ -60,6 +60,7 @@ import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Service
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Stats (PresentedServersSummary)
|
||||
import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
@@ -609,6 +610,7 @@ data ChatCommand
|
||||
| GetAgentWorkers
|
||||
| GetAgentWorkersDetails
|
||||
| GetAgentQueuesInfo
|
||||
| APICallService UserId AServiceCommand
|
||||
| -- The parser will return this command for strings that start from "//".
|
||||
-- This command should be processed in preCmdHook
|
||||
CustomChatCommand ByteString
|
||||
@@ -839,6 +841,7 @@ data ChatResponse
|
||||
| CRAgentSubsDetails {agentSubs :: SubscriptionsInfo}
|
||||
| CRAgentQueuesInfo {agentQueuesInfo :: AgentQueuesInfo}
|
||||
| CRAppSettings {appSettings :: AppSettings}
|
||||
| CRServiceResponse {user :: User, serviceResponse :: AServiceResponse}
|
||||
| CRCustomChatResponse {user_ :: Maybe User, response :: Text}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@@ -3441,6 +3441,7 @@ processChatCommand vr nm = \case
|
||||
-- CustomChatCommand is unsupported, it can be processed in preCmdHook
|
||||
-- in a modified CLI app or core - the hook should return Either (Either ChatError ChatResponse) ChatCommand,
|
||||
-- where Left means command result, and Right – some other command to be processed by this function.
|
||||
APICallService _userId _cmd -> withUser $ \_ -> throwCmdError "not yet implemented"
|
||||
CustomChatCommand _cmd -> withUser $ \_ -> throwCmdError "not supported"
|
||||
where
|
||||
ok_ = pure $ CRCmdOk Nothing
|
||||
|
||||
@@ -0,0 +1,159 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Chat.Service where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
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)
|
||||
|
||||
data ServiceType = STBadge | STDirectory | STNames
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data SServiceType (s :: ServiceType) where
|
||||
SSTBadge :: SServiceType 'STBadge
|
||||
SSTDirectory :: SServiceType 'STDirectory
|
||||
SSTNames :: SServiceType 'STNames
|
||||
|
||||
deriving instance Eq (SServiceType s)
|
||||
|
||||
deriving instance Show (SServiceType s)
|
||||
|
||||
instance TestEquality SServiceType where
|
||||
testEquality SSTBadge SSTBadge = Just Refl
|
||||
testEquality SSTDirectory SSTDirectory = Just Refl
|
||||
testEquality SSTNames SSTNames = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
class ServiceTypeI (s :: ServiceType) where sServiceType :: SServiceType s
|
||||
|
||||
instance ServiceTypeI 'STBadge where sServiceType = SSTBadge
|
||||
|
||||
instance ServiceTypeI 'STDirectory where sServiceType = SSTDirectory
|
||||
|
||||
instance ServiceTypeI 'STNames where sServiceType = SSTNames
|
||||
|
||||
-- Badge
|
||||
|
||||
data BadgeCommand
|
||||
= BCIssue Text Text
|
||||
| BCRedeem Text
|
||||
| BCStripeLink Text
|
||||
deriving (Show)
|
||||
|
||||
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
|
||||
| NRNotFound
|
||||
| NRError Text
|
||||
deriving (Show)
|
||||
|
||||
-- Service command/response GADTs
|
||||
|
||||
data ServiceCommand (s :: ServiceType) where
|
||||
SCBadge :: BadgeCommand -> ServiceCommand 'STBadge
|
||||
SCDirectory :: DirectoryCommand -> ServiceCommand 'STDirectory
|
||||
SCNames :: NamesCommand -> ServiceCommand 'STNames
|
||||
|
||||
deriving instance Show (ServiceCommand s)
|
||||
|
||||
data ServiceResponse (s :: ServiceType) where
|
||||
SRBadge :: BadgeResponse -> ServiceResponse 'STBadge
|
||||
SRDirectory :: DirectoryResponse -> ServiceResponse 'STDirectory
|
||||
SRNames :: NamesResponse -> ServiceResponse 'STNames
|
||||
|
||||
deriving instance Show (ServiceResponse s)
|
||||
|
||||
-- Existential wrappers
|
||||
|
||||
data AServiceCommand = forall s. ServiceTypeI s => ASC (SServiceType s) (ServiceCommand s)
|
||||
|
||||
deriving instance Show AServiceCommand
|
||||
|
||||
data AServiceResponse = forall s. ServiceTypeI s => ASR (SServiceType s) (ServiceResponse s)
|
||||
|
||||
deriving instance Show AServiceResponse
|
||||
|
||||
$(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 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"
|
||||
|
||||
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"
|
||||
@@ -334,6 +334,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
plain . LB.unpack $ J.encode agentQueuesInfo
|
||||
]
|
||||
CRAppSettings as -> ["app settings: " <> viewJSON as]
|
||||
CRServiceResponse user resp -> ttyUser user [plain $ "service response: " <> tshow resp]
|
||||
CRCustomChatResponse u r -> ttyUser' u $ map plain $ T.lines r
|
||||
where
|
||||
ttyUser :: User -> [StyledString] -> [StyledString]
|
||||
|
||||
Reference in New Issue
Block a user