@reventlessdev/reventless-spec 3.0.0-alpha.133 → 3.0.0-alpha.135

package/src/semantic/FileRef.res

@@ -14,7 +14,6 @@ the pair exists and what the grammar refuses.
     })
 ```
 */
-
 /** Transparent `string`; see `Email.t`. */
 type t = string
 
@@ -25,4 +24,5 @@ let fromString = (raw: string): result<t, string> => Media_Ref.check(~what="file
 
 /** The sury schema for a file-reference field.
     Use with `@s.matches(Reventless.FileRef.schema)`. */
-let schema: S.t<t> = S.string->Semantic.refined(~id=Semantic.Id.fileRef, ~check=fromString)
+let schema: S.t<t> =
+  S.string->Semantic.refined(~id=Semantic.Id.fileRef, ~check=fromString)

package/src/semantic/GeoPoint.res

@@ -64,7 +64,6 @@ type has, and it is the one most existing coordinate fields are on. It costs a
 log something only if it *collapses* two flattened scalar fields back into one,
 which rewrites that shape.
 */
-
 /**
 Validate a latitude, saying why when it is out of range.
 
@@ -76,8 +75,9 @@ let validateLat = (raw: float): result<float, string> =>
     Error(`a latitude must be a finite number of degrees, got ${Float.toString(raw)}`)
   } else if raw < -90.0 || raw > 90.0 {
     Error(
-      `a latitude runs from -90 to 90 degrees, got ${Float.toString(raw)}. ` ++
-      `A value beyond ±90 is usually a longitude in the latitude's place.`,
+      `a latitude runs from -90 to 90 degrees, got ${Float.toString(
+          raw,
+        )}. ` ++ `A value beyond ±90 is usually a longitude in the latitude's place.`,
     )
   } else {
     Ok(raw)
@@ -99,25 +99,20 @@ let validateLng = (raw: float): result<float, string> =>
     11-alpha miscompiles a refinement wrapping a *record* schema. Refining the
     field is both the honest placement and the one that works. */
 let latSchema: S.t<float> =
-  S.float->S.refine(
-    raw =>
-      switch validateLat(raw) {
-      | Ok(_) => true
-      | Error(_) => false
-      },
-    ~error="expected a latitude in -90…90",
-  )
+  S.float->S.refine(raw =>
+    switch validateLat(raw) {
+    | Ok(_) => true
+    | Error(_) => false
+    }
+  , ~error="expected a latitude in -90…90")
 
 /** The longitude's own schema, for the same reason. */
-let lngSchema: S.t<float> =
-  S.float->S.refine(
-    raw =>
-      switch validateLng(raw) {
-      | Ok(_) => true
-      | Error(_) => false
-      },
-    ~error="expected a longitude in -180…180",
-  )
+let lngSchema: S.t<float> = S.float->S.refine(raw =>
+  switch validateLng(raw) {
+  | Ok(_) => true
+  | Error(_) => false
+  }
+, ~error="expected a longitude in -180…180")
 
 @schema
 type t = {
@@ -131,7 +126,8 @@ type t = {
 
     Shadows the schema sury-ppx derived from the type above: the derived one is
     the shape, and this adds the marker the shape cannot carry. */
-let schema: S.t<t> = schema->Semantic.mark(~id=Semantic.Id.geoPoint)
+let schema: S.t<t> =
+  schema->Semantic.mark(~id=Semantic.Id.geoPoint)
 
 /** Build a validated point. Both coordinates are checked, and the message names
     which one is wrong — the common mistake is a swapped pair, where the

package/src/semantic/Geocoding.res

@@ -5,7 +5,6 @@ The transport is provider-specific and lives with its provider. What is here is
 provider-neutral: the shape of an answer, the two ways a lookup fails, and the
 confidence rule — decided once, so no transport invents its own.
 */
-
 /** One candidate a geocoder returned. */
 type candidate = {
   /** The provider's canonical rendering of the address it matched. */
@@ -19,10 +18,10 @@ type candidate = {
 /** Why a lookup produced no usable point. Two constructors because the retry
     decision turns on the distinction: an outage must not become a verdict. */
 type failure =
-  | /** The provider could not be reached, or refused the call. Retry. */
-  Unavailable(string)
-  | /** The provider answered, and had nothing for this text. Do not retry. */
-  NoMatch
+  /** The provider could not be reached, or refused the call. Retry. */
+  | Unavailable(string)
+  /** The provider answered, and had nothing for this text. Do not retry. */
+  | NoMatch
 
 /**
 The port a caller reaches a geocoder through, so swapping the implementation is a
@@ -51,11 +50,11 @@ let defaultAmbiguityMargin = 0.01
 type assessment =
   | Confident(candidate)
   | NoCandidates
-  | /** Unscored is not a low score, and must not read as a high one. */
-  Unscored(candidate)
+  /** Unscored is not a low score, and must not read as a high one. */
+  | Unscored(candidate)
   | LowRelevance({top: candidate, score: float, floor: float})
-  | /** Several matches about equally well. */
-  Ambiguous({top: candidate, runnerUp: candidate, margin: float})
+  /** Several matches about equally well. */
+  | Ambiguous({top: candidate, runnerUp: candidate, margin: float})
 
 /** The confidence rule, stated once. Everything else here derives from it. */
 let assess = (

package/src/semantic/Geolocation.res

@@ -5,14 +5,13 @@ Three arms rather than `option<GeoPoint.t>`, whose `None` means both "has not ru
 and "ran and failed". Emitted as a GraphQL union (see `Reventless.TaggedUnion`).
 Replacing a point/status/note trio with it is wire-breaking.
 */
-
 @schema
 type t =
-  | /** `requestedFor` is the address asked about, so a stale answer is detectable. */
-  Pending({requestedFor: string})
+  /** `requestedFor` is the address asked about, so a stale answer is detectable. */
+  | Pending({requestedFor: string})
   | Located({point: GeoPoint.t})
-  | /** Answered, with nothing storable unattended. A verdict for a human. */
-  Unresolvable({reason: string})
+  /** Answered, with nothing storable unattended. A verdict for a human. */
+  | Unresolvable({reason: string})
 
 /** Adds the two markers the shape cannot carry: the semantic, and the union name
     the SDL and the `__typename` stamp share. */
@@ -59,8 +58,7 @@ let ofSearch = (
     | Unscored(top) =>
       Some(
         Unresolvable({
-          reason: `the geocoder returned "${top.label}" for "${requestedFor}" without scoring it, ` ++
-          `and an unscored answer cannot be accepted unattended`,
+          reason: `the geocoder returned "${top.label}" for "${requestedFor}" without scoring it, ` ++ `and an unscored answer cannot be accepted unattended`,
         }),
       )
     | LowRelevance({top, score, floor}) =>
@@ -73,8 +71,7 @@ let ofSearch = (
     | Ambiguous({top, runnerUp}) =>
       Some(
         Unresolvable({
-          reason: `"${requestedFor}" matched "${top.label}" and "${runnerUp.label}" ` ++
-          `about equally well`,
+          reason: `"${requestedFor}" matched "${top.label}" and "${runnerUp.label}" ` ++ `about equally well`,
         }),
       )
     }

package/src/semantic/IdentityProvider.res

@@ -0,0 +1,127 @@
+/**
+Making, grouping and unmaking principals, so the provider behind them is a
+supplier rather than a call site.
+
+The *administrative* half of identity only. Authentication — token issuance, JWT
+verification, session handling — is `Auth_Adapter.Provider`'s, and stays there:
+the two are read at different times over one provider, exactly as this and
+`CapabilityNeed.t` are.
+
+🚨 **Nothing here is a domain event's business.** `principal` is the provider's
+own handle and must never reach an event log: a log full of one provider's ids
+cannot be migrated to another, which would make the replaceability this
+capability exists for a fiction. What the log holds is the domain's own opaque
+user id; the mapping between the two lives in this capability's store.
+*/
+/** The provider's own handle for a principal. Opaque on purpose — a caller that
+    can read structure out of it is a caller coupled to the provider. */
+type principal = {providerId: string}
+
+/** How a new principal proves it is them. A variant rather than a bare password
+    so a provider offering only federated or passwordless enrolment can refuse
+    the arm it does not implement instead of being handed a secret it will
+    discard. */
+type credential =
+  | Password(string)
+  /** Enrol with no secret held here: the principal sets one through the
+        provider's own flow, or signs in federated. */
+  | NoCredential
+
+/**
+Why an operation did not happen.
+
+Three arms rather than two, and the split is the one geocoding taught: **a
+provider outage is not a verdict.** `Unavailable` must be retried, because a
+caller reaching `createPrincipal` has already recorded that the address was
+proven and the person is entitled to an account. `Refused` is permanent and must
+surface. Collapsing them either loses accounts to a transient blip or retries
+forever against a password policy.
+*/
+type failure =
+  /** The contact is already a principal. A modelled answer, not an exception —
+        which is what a silent idempotent sign-up throws away. */
+  | Conflict
+  /** The provider is down or unreachable. The domain fact stands; retry. */
+  | Unavailable(string)
+  /** Permanently rejected — policy, password rules, a refused attribute. */
+  | Refused(string)
+
+/**
+One thing a provider can be asked to do.
+
+Published rather than fixed, because providers genuinely differ: one bound
+read-only to a corporate directory can create nothing, and one with no group
+model cannot be asked about groups. A caller reads this and degrades, instead of
+discovering the gap as a `Refused` on a live registration.
+
+**`setActiveRole` is deliberately absent.** Narrowing a caller's claims to the
+role they chose happens when a token is *minted* — on Cognito, in a
+pre-token-generation trigger. That is token issuance, which this capability's
+non-goal hands to the auth seam. Admitting it here would grow the surface along
+an axis that has nothing to do with whether the principal store is replaceable,
+which is the one thing this type exists to protect.
+*/
+type operation =
+  | CreatePrincipal
+  | AddToGroup
+  | RemoveFromGroup
+  | DeletePrincipal
+
+let operationToString = (operation: operation): string =>
+  switch operation {
+  | CreatePrincipal => "CreatePrincipal"
+  | AddToGroup => "AddToGroup"
+  | RemoveFromGroup => "RemoveFromGroup"
+  | DeletePrincipal => "DeletePrincipal"
+  }
+
+/**
+The port a caller reaches an identity provider through.
+
+`operations` is the provisioned set this deployment's provider actually
+supports, published rather than inferred. Build one through `make`, so a
+provider cannot claim an operation and omit the function that performs it.
+*/
+type t = {
+  createPrincipal: (
+    ~contact: Messaging.recipient,
+    ~credential: credential,
+    ~groups: array<string>,
+  ) => promise<result<principal, failure>>,
+  addToGroup: (~principal: principal, ~group: string) => promise<result<unit, failure>>,
+  removeFromGroup: (~principal: principal, ~group: string) => promise<result<unit, failure>>,
+  deletePrincipal: (~principal: principal) => promise<result<unit, failure>>,
+  operations: array<operation>,
+}
+
+let make = (~createPrincipal, ~addToGroup, ~removeFromGroup, ~deletePrincipal, ~operations): t => {
+  createPrincipal,
+  addToGroup,
+  removeFromGroup,
+  deletePrincipal,
+  operations,
+}
+
+let supports = (provider: t, ~operation: operation): bool =>
+  provider.operations->Array.includes(operation)
+
+/**
+A provider that performs nothing, answering `Unavailable` on every operation
+with an empty `operations`.
+
+The two say different true things and both are needed. The empty list is what a
+caller reads before offering a flow that cannot complete. The refusal stays
+`Unavailable` rather than `Refused` because a caller that got this far is looking
+at a deployment gap, not at a verdict on the person — and `Refused` would strand
+someone who has already proven their address.
+*/
+let unavailable = (~reason: string): t =>
+  make(
+    ~createPrincipal=async (~contact as _, ~credential as _, ~groups as _) => Error(
+      Unavailable(reason),
+    ),
+    ~addToGroup=async (~principal as _, ~group as _) => Error(Unavailable(reason)),
+    ~removeFromGroup=async (~principal as _, ~group as _) => Error(Unavailable(reason)),
+    ~deletePrincipal=async (~principal as _) => Error(Unavailable(reason)),
+    ~operations=[],
+  )

package/src/semantic/IdentityProvider.res.mjs

@@ -0,0 +1,65 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+
+function operationToString(operation) {
+  switch (operation) {
+    case "CreatePrincipal" :
+      return "CreatePrincipal";
+    case "AddToGroup" :
+      return "AddToGroup";
+    case "RemoveFromGroup" :
+      return "RemoveFromGroup";
+    case "DeletePrincipal" :
+      return "DeletePrincipal";
+  }
+}
+
+function make(createPrincipal, addToGroup, removeFromGroup, deletePrincipal, operations) {
+  return {
+    createPrincipal: createPrincipal,
+    addToGroup: addToGroup,
+    removeFromGroup: removeFromGroup,
+    deletePrincipal: deletePrincipal,
+    operations: operations
+  };
+}
+
+function supports(provider, operation) {
+  return provider.operations.includes(operation);
+}
+
+function unavailable(reason) {
+  return make(async (param, param$1, param$2) => ({
+    TAG: "Error",
+    _0: {
+      TAG: "Unavailable",
+      _0: reason
+    }
+  }), async (param, param$1) => ({
+    TAG: "Error",
+    _0: {
+      TAG: "Unavailable",
+      _0: reason
+    }
+  }), async (param, param$1) => ({
+    TAG: "Error",
+    _0: {
+      TAG: "Unavailable",
+      _0: reason
+    }
+  }), async param => ({
+    TAG: "Error",
+    _0: {
+      TAG: "Unavailable",
+      _0: reason
+    }
+  }), []);
+}
+
+export {
+  operationToString,
+  make,
+  supports,
+  unavailable,
+}
+/* No side effect */

package/src/semantic/ImageRef.res

@@ -30,7 +30,6 @@ a field that declares no store.
     })
 ```
 */
-
 /** Transparent `string`; see `Email.t`. */
 type t = string
 
@@ -48,4 +47,5 @@ let fromString = (raw: string): result<t, string> => Media_Ref.check(~what="imag
 
 /** The sury schema for an image-reference field.
     Use with `@s.matches(Reventless.ImageRef.schema)`. */
-let schema: S.t<t> = S.string->Semantic.refined(~id=Semantic.Id.imageRef, ~check=fromString)
+let schema: S.t<t> =
+  S.string->Semantic.refined(~id=Semantic.Id.imageRef, ~check=fromString)

package/src/semantic/MemberRef.res

@@ -55,7 +55,6 @@ declares one there today: a view that carried a scalar *and* the set it was
 drawn from needed a marker saying the two were one thing, and a view whose
 primary is simply the first member has no second field to reconcile.
 */
-
 /** Transparent `string`, as every ref-shaped semantic here is: the marker
     refines an existing field rather than replacing it, so nothing stored
     changes when a field adopts it. */

package/src/semantic/Messaging.res

@@ -11,23 +11,75 @@ A `(channel, address)` pair can be built wrong: `Sms` beside an email address
 compiles and fails at the provider. `recipient` fuses them, so the wrong pair
 does not exist, and the channel is read back off the value that carries it.
 */
+/**
+A delivery route. The selector a recipient chooses per notification kind.
 
-/** A delivery route. The selector a recipient chooses per notification kind, and
-    the granularity a platform provisions at. */
+Three arms, and push stays one of them even though it is provisioned three ways.
+Splitting it would offer a person a choice between notification services, which is
+not a choice anyone has: an app knows its own token, and nobody prefers APNs. The
+service-level discrimination lives on the address and on what a provider
+publishes — see `pushService`.
+*/
 type channel =
   | Email
   | Sms
   | Push
 
+/**
+How a push service names one install.
+
+A variant rather than a string because the shapes differ: two services issue an
+opaque token, and Web Push issues a subscription whose encryption keys are part of
+the address. This applies the rule the file opens with one level down — the wrong
+(service, address) pair stops being constructible for the same reason the wrong
+(channel, address) pair already is.
+*/
+type pushAddress =
+  | Apns({deviceToken: string})
+  | Fcm({registrationToken: string})
+  /** The endpoint is where it goes; the keys are how it is sealed. Requiring them
+        here keeps an unsendable subscription unconstructible. */
+  | WebPush({endpoint: string, p256dh: string, auth: string})
+
+/**
+Which service issued an address — the granularity push is provisioned at.
+
+Email needs no such type: one sender provisioning reaches every mailbox, because
+SMTP routes off the address. Push has no routing layer, so which service can reach
+a device is fixed by which credential the deployment holds, and there is nothing
+in the address to route on.
+*/
+type pushService =
+  /** Apple Push Notification service. Provisioned with a signing key, the team id
+        that issued it and the app's bundle id. */
+  | ApnsService
+  /** Firebase Cloud Messaging, Google's. Provisioned with one service-account
+        credential. */
+  | FcmService
+  /** Standardised rather than vendor-run: the endpoint the browser hands out is
+        itself the service, so one VAPID keypair provisions all of them. */
+  | WebPushService
+
 /** An addressed recipient: the channel and the address it needs, inseparable.
-    Each address is the branded scalar for its channel, so an unparseable one is
-    refused where it is built rather than by the provider. */
+    Email and SMS carry the branded scalar for their channel, so an unparseable one
+    is refused where it is built rather than by the provider; push carries the
+    variant its services issue, and the same property holds by construction. */
 type recipient =
   | ToEmail(Email.t)
   | ToSms(Phone.t)
-  | /** The token the device registered with the push service. Opaque and
-        provider-shaped — unlike an address, nobody else has a grammar for it. */
-  ToPush({deviceToken: string})
+  /** How one install is reached. Not a bare string: the two token services and
+        Web Push do not share a shape, and Web Push is not opaque. */
+  | ToPush(pushAddress)
+
+/** The service that issued a push address. What a provider's published list is
+    checked against, so a token is never handed to the service that cannot use
+    it. */
+let serviceOf = (address: pushAddress): pushService =>
+  switch address {
+  | Apns(_) => ApnsService
+  | Fcm(_) => FcmService
+  | WebPush(_) => WebPushService
+  }
 
 /** The channel a recipient is addressed on. */
 let channelOf = (recipient: recipient): channel =>
@@ -45,6 +97,15 @@ let channelToString = (channel: channel): string =>
   | Push => "Push"
   }
 
+/** The service's name as its own documentation spells it, because that is the
+    word a support conversation about a missing notification is conducted with. */
+let pushServiceToString = (service: pushService): string =>
+  switch service {
+  | ApnsService => "APNs"
+  | FcmService => "FCM"
+  | WebPushService => "Web Push"
+  }
+
 /**
 The `From:` header a deployment's email sender presents as: the bare address, or
 a display name in front of it.
@@ -87,20 +148,28 @@ type receipt = {ref: string}
 /**
 Why a send produced no receipt.
 
-Three constructors because the retry decision turns on the distinction, and
-getting it wrong is expensive in both directions: retrying a refused address
-burns the budget on an outcome that will not change, and abandoning a transient
-outage writes off a message that would have gone.
+The retry decision turns on the distinction, and getting it wrong is expensive in
+both directions: retrying a refused address burns the budget on an outcome that
+will not change, and abandoning a transient outage writes off a message that would
+have gone.
+
+Push needs its own refusal because it is provisioned per service. Once a
+deployment can provision *some* push, `UnsupportedChannel(Push)` would have to
+mean both "no push at all" and "not that service", and the two read the same to
+someone debugging a half-provisioned deployment.
 */
 type failure =
-  | /** The provider could not be reached, or refused the call. Retry. */
-  Unavailable(string)
-  | /** This deployment provisions nothing for this channel. Do not retry — no
+  /** The provider could not be reached, or refused the call. Retry. */
+  | Unavailable(string)
+  /** This deployment provisions nothing for this channel. Do not retry — no
         number of attempts provisions one. */
-  UnsupportedChannel(channel)
-  | /** The provider answered and will not take this message: an address it
+  | UnsupportedChannel(channel)
+  /** This deployment provisions push, but not the service that issued this
+        address. Do not retry — the device is reachable only through its own. */
+  | UnsupportedPushService(pushService)
+  /** The provider answered and will not take this message: an address it
         rejects, a recipient it suppresses. Do not retry. */
-  Refused(string)
+  | Refused(string)
 
 /** The retry rule, stated once. Everything that sweeps a failed send derives
     from it rather than re-reading the constructors. */
@@ -108,6 +177,7 @@ let retriable = (failure: failure): bool =>
   switch failure {
   | Unavailable(_) => true
   | UnsupportedChannel(_)
+  | UnsupportedPushService(_)
   | Refused(_) => false
   }
 
@@ -118,6 +188,8 @@ let failureReason = (failure: failure): string =>
   | Unavailable(reason) => reason
   | UnsupportedChannel(channel) =>
     `this deployment provisions no ${channel->channelToString} channel`
+  | UnsupportedPushService(service) =>
+    `this deployment provisions push, but not ${service->pushServiceToString}`
   | Refused(reason) => reason
   }
 
@@ -138,14 +210,62 @@ because discovering a channel by failing on it costs a real message.
 
 Empty means no channel at all — the shape `none` takes, and the one a deploy-time
 gate exists to catch before it ships.
+
+`pushServices` is the second answer, at the granularity push is actually
+provisioned at. Both are published because the two granularities differ: a
+preference centre reads `channels` because a person picks a channel, and `supports`
+reads `pushServices` because a token is only reachable through its own service.
+Build one through `makeProvider`, which derives the first from the second.
 */
 type provider = {
   channels: array<channel>,
+  pushServices: array<pushService>,
   send: send,
 }
 
-/** Whether this provider can attempt a recipient's channel at all. The check a
-    caller makes before spending a send, and the same rule the provider applies
-    internally, so the two cannot disagree. */
+/**
+Build a provider whose two published answers cannot disagree.
+
+`channels` is derived rather than given: `Push` appears exactly when a push service
+is behind it, so no transport can publish a channel with nothing to reach it on.
+The alternative is that invariant stated in a comment beside two independently
+written fields, which is where invariants go to die.
+
+`emailAndSms` carries the channels the channel itself settles reachability for. A
+`Push` passed there is dropped — `pushServices` is the only thing that provisions
+push — and the switch doing the dropping is exhaustive, so a fourth channel arrives
+here as a compile error rather than as a silent omission.
+*/
+let makeProvider = (
+  ~emailAndSms: array<channel>,
+  ~pushServices: array<pushService>,
+  ~send: send,
+): provider => {
+  channels: emailAndSms
+  ->Array.filter(channel =>
+    switch channel {
+    | Email
+    | Sms => true
+    | Push => false
+    }
+  )
+  ->Array.concat(pushServices->Array.length == 0 ? [] : [Push]),
+  pushServices,
+  send,
+}
+
+/**
+Whether this provider can attempt this recipient at all. The check a caller makes
+before spending a send, and the same rule the provider applies internally, so the
+two cannot disagree.
+
+Push is checked against the issuing service, not against the channel. Answering off
+`channels` would return `true` for an APNs token on a deployment that provisioned
+FCM only — and inferring a channel by failing on it is exactly what publishing the
+list exists to avoid, since a failed send costs a real message.
+*/
 let supports = (provider: provider, ~recipient: recipient): bool =>
-  provider.channels->Array.includes(recipient->channelOf)
+  switch recipient {
+  | ToPush(address) => provider.pushServices->Array.includes(address->serviceOf)
+  | recipient => provider.channels->Array.includes(recipient->channelOf)
+  }