@reventlessdev/reventless-spec 3.0.0-alpha.100

package/src/semantic/Semantic.res

@@ -0,0 +1,162 @@
+/**
+The one marker every typed semantic marks itself with.
+
+A semantic type says what a field's value *is* — a date-time, a reference to
+another entity, a ref into an object store — as a property of the field's
+**type**, not as a string stapled beside it. Every layer downstream then derives
+from that single declaration: validation, the wire contract, the UI widget it
+gets rendered with, and eventually the infrastructure provisioned for it.
+
+Typed markers predate this module, and each was bespoke: `DateTime` carried its
+own metadata id, `Reference` carried another, and the schema walk detected both
+by hardcoded special case. That made every new typed marker new detection code.
+One shared marker means the walk reads a semantic generically and a new semantic
+type is a new *value*, not a new branch.
+
+The payload is a real variant rather than free-form JSON. The semantic
+vocabulary is framework-owned — an application declares a field *is* a storage
+ref, it does not invent what a storage ref means — so the set is closed, and a
+closed set typed here is one the compiler checks at every producer and consumer.
+It also keeps `Reference.getTarget` a total typed function instead of a decode
+that can fail at runtime.
+*/
+
+/** Which entity a reference field points to. */
+type referenceTarget = {entity: string, plugin: option<string>}
+
+/** Which object store a storage-ref / offload field's value lives in. `plugin` is
+    absent when the store belongs to the declaring plugin, which is the common
+    case. `threshold` is the per-field inline-vs-offloaded byte cut an `@offload`
+    field may declare (`None` for `@storageRef`, which is always a ref, and for
+    `@offload` fields that leave it to the platform default). */
+type storeTarget = {plugin: option<string>, store: string, threshold: option<int>}
+
+/** Per-semantic detail, for the semantics that carry any. */
+type payload =
+  | Plain
+  | ReferenceTo(referenceTarget)
+  | StoredIn(storeTarget)
+
+/** A field's semantic: the vocabulary id, plus its detail. */
+type t = {id: string, payload: payload}
+
+/**
+The semantic ids the framework itself defines.
+
+These strings are the wire vocabulary — they are what `x-reventless-semantic`
+carries, and the same vocabulary the string annotation path already uses, so the
+type path and the annotation path converge on one wire format rather than two.
+*/
+module Id = {
+  let dateTime = "dateTime"
+  let reference = "reference"
+  let storageRef = "storageRef"
+  // A field whose large value the client stored in a content-addressed object
+  // store and carries by reference (inline below a size threshold). Sibling of
+  // `storageRef`: same `StoredIn` store declaration, but an inline-or-reference
+  // value rather than an always-a-ref path string.
+  let offload = "offload"
+
+  // The branded scalars. Each refines a `string` or a number without changing
+  // its shape, so a field gains one of these without anything stored changing.
+  let email = "email"
+  let phone = "phone"
+  let url = "url"
+  let percent = "percent"
+  let bytes = "bytes"
+  let duration = "duration"
+  let color = "color"
+
+  // The first composite that is not infrastructure. Unlike the seven above it
+  // this one changes a field's *shape* — a number becomes an object — so it is
+  // a wire-breaking declaration rather than a refinement of one.
+  let money = "money"
+
+  // The second composite. A pair of ISO-8601 instants as one value, replacing a
+  // span the UI used to guess from a `start*`/`end*` name pair. Like `money` it
+  // is an object on the wire; unlike it, adopting it as a *new* optional field
+  // is additive — an absent optional decodes to `None`.
+  let dateRange = "dateRange"
+
+  // The third composite, and the cheapest to adopt. A latitude/longitude pair as
+  // one value, replacing a point the UI used to guess from a `lat`/`lng` name
+  // pair. Most coordinate fields already store `{lat, lng}` as a hand-rolled
+  // record, so retyping one is shape-preserving: the wire is unchanged and
+  // nothing stored needs upcasting.
+  let geoPoint = "geoPoint"
+}
+
+let semanticId: S.Metadata.Id.t<t> = S.Metadata.Id.make(~namespace="reventless", ~name="semantic")
+
+/** Mark a schema as carrying a semantic. */
+let mark = (schema: S.t<'a>, ~id: string, ~payload: payload=Plain): S.t<'a> =>
+  schema->S.Metadata.set(~id=semanticId, {id, payload})
+
+/**
+A schema that validates with `check` and carries the semantic `id`.
+
+The branded scalars all have the same shape — one constructor function that
+defines the grammar, and a schema that must agree with it — and `StorageRef`
+established that the schema is *derived* from the constructor rather than
+hand-rolling a second check beside it. Deriving it here makes that structural:
+there is one place a grammar can be written, so there is nowhere for a second
+one to drift.
+*/
+let refined = (base: S.t<'a>, ~id: string, ~check: 'a => result<'a, string>): S.t<'a> =>
+  base
+  ->S.refine(s => value =>
+    switch check(value) {
+    | Ok(_) => ()
+    | Error(why) => s.fail(why)
+    }
+  )
+  ->mark(~id)
+
+/** A value as it should read back to the person who typed it. Rejection messages
+    reach forms through `validateInput`, so they quote the offending value. */
+let showString = (raw: string): string => raw->JSON.Encode.string->JSON.stringify
+
+/**
+The semantic a field's schema carries, if any.
+
+An **optional** field keeps its marker one level down. The ppx annotates the
+field's `string`, and sury-ppx then wraps that schema in a union with
+`Undefined`/`Null`; the wrapper is a new schema and carries no metadata of its
+own. So a walk that reads only the outer schema sees `imageUrl?: string` as
+carrying no semantic at all — the store goes undeclared, the reference goes
+uncollected, the branded scalar loses its brand. Every reader converges here, so
+following the wrapper once here is what keeps "optional" a statement about
+presence rather than a way to lose the field's type.
+
+The outer schema is read first, so a marker set on the wrapper itself still wins.
+Only a union with exactly one non-null variant is followed: that is the shape an
+optional field has, and a genuine multi-variant union has no single inner schema
+whose semantic could stand for the whole.
+*/
+let rec getFrom = (schema: S.t<unknown>): option<t> =>
+  switch S.Metadata.get(schema, ~id=semanticId) {
+  | Some(_) as found => found
+  | None =>
+    switch schema {
+    | Union({anyOf}) =>
+      switch anyOf->Array.filter(v =>
+        switch v {
+        | Null(_) | Undefined(_) => false
+        | _ => true
+        }
+      ) {
+      | [inner] => getFrom(inner)
+      | _ => None
+      }
+    | _ => None
+    }
+  }
+
+let get = (fieldSchema: S.t<'a>): option<t> => fieldSchema->S.castToUnknown->getFrom
+
+/** Whether a field's schema carries this specific semantic. */
+let has = (fieldSchema: S.t<'a>, ~id: string): bool =>
+  switch get(fieldSchema) {
+  | Some(s) => s.id === id
+  | None => false
+  }

package/src/semantic/Semantic.res.mjs

@@ -0,0 +1,95 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as S from "sury/src/S.res.mjs";
+
+let Id = {
+  dateTime: "dateTime",
+  reference: "reference",
+  storageRef: "storageRef",
+  offload: "offload",
+  email: "email",
+  phone: "phone",
+  url: "url",
+  percent: "percent",
+  bytes: "bytes",
+  duration: "duration",
+  color: "color",
+  money: "money",
+  dateRange: "dateRange",
+  geoPoint: "geoPoint"
+};
+
+let semanticId = S.Metadata.Id.make("reventless", "semantic");
+
+function mark(schema, id, payloadOpt) {
+  let payload = payloadOpt !== undefined ? payloadOpt : "Plain";
+  return S.Metadata.set(schema, semanticId, {
+    id: id,
+    payload: payload
+  });
+}
+
+function refined(base, id, check) {
+  return mark(S.refine(base, s => (value => {
+    let why = check(value);
+    if (why.TAG === "Ok") {
+      return;
+    } else {
+      return s.fail(why._0, undefined);
+    }
+  })), id, undefined);
+}
+
+function showString(raw) {
+  return JSON.stringify(raw);
+}
+
+function getFrom(_schema) {
+  while (true) {
+    let schema = _schema;
+    let found = S.Metadata.get(schema, semanticId);
+    if (found !== undefined) {
+      return found;
+    }
+    if (schema.type !== "union") {
+      return;
+    }
+    let match = schema.anyOf.filter(v => {
+      switch (v.type) {
+        case "null" :
+        case "undefined" :
+          return false;
+        default:
+          return true;
+      }
+    });
+    if (match.length !== 1) {
+      return;
+    }
+    _schema = match[0];
+    continue;
+  };
+}
+
+let get = getFrom;
+
+function has(fieldSchema, id) {
+  let s = getFrom(fieldSchema);
+  if (s !== undefined) {
+    return s.id === id;
+  } else {
+    return false;
+  }
+}
+
+export {
+  Id,
+  semanticId,
+  mark,
+  refined,
+  showString,
+  getFrom,
+  get,
+  has,
+}
+/* semanticId Not a pure module */

package/src/semantic/StorageRef.res

@@ -0,0 +1,164 @@
+/**
+A reference to an object living in one of the platform's object stores.
+
+The value is the ref string a store's presign service minted — an origin-relative
+path rooted at the store's served prefix, which the UI renders directly because
+the store is fronted read-only on the app's own origin.
+
+## Why this is a type and not a convention
+
+An event log is append-only, so whatever a command accepts into it is permanent.
+Before this type, an `imageUrl: string` field accepted *anything* — including an
+`https://` URL pointing at somebody else's server, or a multi-megabyte `data:`
+URI inlined into the event itself. Both deploy green, both are unfixable after
+the fact, and neither is what the field means. Declaring the field's type makes
+the wrong values unrepresentable at the boundary, before `decide` ever runs.
+
+The declaration also states a *requirement*: a field of this type says the
+deployment needs a store called `store` to exist. Nothing provisions that store
+yet, and that is a deliberate resting point — the validation hole is closed and
+the requirement is written down, which is strictly better than the status quo
+even if automatic provisioning never lands.
+
+## The grammar
+
+A ref is an absolute, origin-relative path of at least two non-empty segments:
+
+    /uploads/2f8c1e94-.../photo.jpg
+    /uploads/user-42/2f8c1e94-.../photo.jpg
+
+Rejected: anything with a scheme (`https://…`, `data:…`), protocol-relative
+`//host/path`, relative paths, empty segments, and `.`/`..` traversal.
+
+The framework mints refs in exactly this form — the presign service builds the
+object key as `{servedPrefix}/{identity}{uuid}/{fileName}` and returns `/{key}` —
+so the grammar is the framework's to define, not an application's.
+
+Note what is *not* checked: that the ref's prefix belongs to this specific store.
+Today every store shares one served prefix, so there is nothing store-specific to
+check against; the store identity is carried in the field's semantic payload,
+where provisioning and the UI read it. When stores gain per-store prefixes, this
+check tightens from a structural one to a per-store one without the type, the
+wire format, or any stored value changing.
+
+@example
+```rescript
+@schema type command =
+  | ChangeProductImage({
+      productId: @s.matches(DcbTag.string) string,
+      imageUrl: @storageRef("productImages") string,
+    })
+```
+*/
+
+/** The ref's representation. Transparent `string` on purpose: the marker refines
+    an existing `string` field rather than replacing it, so the field's runtime
+    representation — and therefore every stored event — is unchanged. A sealed
+    type here would defeat that, and would also be unattachable via `@s.matches`,
+    which requires the schema's type to match the field's. */
+type t = string
+
+external unsafe: string => t = "%identity"
+external toString: t => string = "%identity"
+
+let segmentIsSafe = (segment: string) =>
+  segment !== "" && segment !== "." && segment !== ".."
+
+/**
+Validate a raw string as a storage ref, saying why when it is not one.
+
+This is the single definition of the grammar. `forStore`'s sury schema is derived
+from it rather than hand-rolling a second check, so the constructor and the
+schema validation cannot drift apart.
+*/
+let fromString = (raw: string): result<t, string> =>
+  if !String.startsWith(raw, "/") {
+    Error(
+      `expected an origin-relative storage ref starting with "/", got ${raw->JSON.Encode.string->JSON.stringify}. External URLs and data: URIs are not storage refs.`,
+    )
+  } else if String.startsWith(raw, "//") {
+    Error(`protocol-relative refs are not storage refs: ${raw}`)
+  } else {
+    let segments = raw->String.slice(~start=1, ~end=String.length(raw))->String.split("/")
+    if segments->Array.length < 2 {
+      Error(`a storage ref needs a prefix and an object path, got ${raw}`)
+    } else if !(segments->Array.every(segmentIsSafe)) {
+      Error(`a storage ref may not contain empty or traversal segments, got ${raw}`)
+    } else {
+      Ok(raw)
+    }
+  }
+
+/**
+The sury schema for a field holding a ref into a named store.
+
+Prefer the `@storageRef("<store>")` ppx shorthand over writing this by hand.
+Qualify the store as `"<plugin>.<store>"` to point at another plugin's store.
+*/
+let forStore = (~plugin: option<string>=?, ~store: string): S.t<t> =>
+  S.string
+  ->S.refine(s => value =>
+    // The empty string is admitted as the "no object" sentinel. The fields this
+    // marks are non-optional today, and a producer with nothing to reference —
+    // a supplier feed carrying no image, say — already writes `""` to mean
+    // absence. Rejecting it here would break a legitimate existing value and
+    // force an event-schema change, which this marker exists to avoid: it
+    // refines an existing `string` field without altering what is stored.
+    //
+    // Note this is a strictly weaker guarantee than `fromString`, which stays
+    // exact. Making these fields properly optional would let the sentinel go.
+    if value !== "" {
+      switch fromString(value) {
+      | Ok(_) => ()
+      | Error(why) => s.fail(why)
+      }
+    }
+  )
+  ->Semantic.mark(~id=Semantic.Id.storageRef, ~payload=StoredIn({plugin, store, threshold: None}))
+
+/** The store a field's schema declares its refs live in, if any. */
+let getStore = (schema: S.t<'a>): option<Semantic.storeTarget> =>
+  switch Semantic.get(schema) {
+  | Some({payload: StoredIn(target)}) => Some(target)
+  | _ => None
+  }
+
+/** How many refs one field holds. */
+type arity =
+  | /** A `string` field: one ref. */ Single
+  | /** An `array<string>` field: zero or more refs. */ Multiple
+
+/**
+The store a *field* declares, looking through an array wrapper, with the arity
+that tells a reader how to get at the value.
+
+`getStore` asks about a schema; this asks about a field, and those differ for
+`@storageRef("s") urls: array<string>` — the ppx attaches the marker to the
+element type, because `@s.matches` requires the schema's type to match what it
+is attached to, so the array itself carries no marker and `getStore` on it
+answers `None`.
+
+Every reader of a *field* wants this one. Reading `getStore` directly is what
+made a multi-valued store declaration invisible: the store went unprovisioned,
+which is the same silence as not having written the annotation at all.
+*/
+let getFieldStore = (schema: S.t<'a>): option<(Semantic.storeTarget, arity)> =>
+  switch getStore(schema) {
+  | Some(target) => Some(target, Single)
+  | None =>
+    switch schema->(Obj.magic: S.t<'a> => S.t<unknown>) {
+    | Array({items, additionalItems}) =>
+      // sury keeps a homogeneous `S.array` element schema in `additionalItems`
+      // and a tuple's positional schemas in `items`; read both so the marker is
+      // found wherever the element sits.
+      switch items->Array.get(0) {
+      | Some({schema: itemSchema}) => getStore(itemSchema)
+      | None =>
+        switch additionalItems {
+        | Schema(itemSchema) => getStore(itemSchema)
+        | _ => None
+        }
+      }->Option.map(target => (target, Multiple))
+    | _ => None
+    }
+  }

package/src/semantic/StorageRef.res.mjs

@@ -0,0 +1,111 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as S from "sury/src/S.res.mjs";
+import * as Stdlib_Option from "@rescript/runtime/lib/es6/Stdlib_Option.js";
+import * as Semantic$Reventless from "./Semantic.res.mjs";
+
+function segmentIsSafe(segment) {
+  if (segment !== "" && segment !== ".") {
+    return segment !== "..";
+  } else {
+    return false;
+  }
+}
+
+function fromString(raw) {
+  if (!raw.startsWith("/")) {
+    return {
+      TAG: "Error",
+      _0: `expected an origin-relative storage ref starting with "/", got ` + JSON.stringify(raw) + `. External URLs and data: URIs are not storage refs.`
+    };
+  }
+  if (raw.startsWith("//")) {
+    return {
+      TAG: "Error",
+      _0: `protocol-relative refs are not storage refs: ` + raw
+    };
+  }
+  let segments = raw.slice(1, raw.length).split("/");
+  if (segments.length < 2) {
+    return {
+      TAG: "Error",
+      _0: `a storage ref needs a prefix and an object path, got ` + raw
+    };
+  } else if (segments.every(segmentIsSafe)) {
+    return {
+      TAG: "Ok",
+      _0: raw
+    };
+  } else {
+    return {
+      TAG: "Error",
+      _0: `a storage ref may not contain empty or traversal segments, got ` + raw
+    };
+  }
+}
+
+function forStore(plugin, store) {
+  return Semantic$Reventless.mark(S.refine(S.string, s => (value => {
+    if (value === "") {
+      return;
+    }
+    let why = fromString(value);
+    if (why.TAG === "Ok") {
+      return;
+    } else {
+      return s.fail(why._0, undefined);
+    }
+  })), Semantic$Reventless.Id.storageRef, {
+    TAG: "StoredIn",
+    _0: {
+      plugin: plugin,
+      store: store,
+      threshold: undefined
+    }
+  });
+}
+
+function getStore(schema) {
+  let match = Semantic$Reventless.get(schema);
+  if (match === undefined) {
+    return;
+  }
+  let target = match.payload;
+  if (typeof target !== "object" || target.TAG === "ReferenceTo") {
+    return;
+  } else {
+    return target._0;
+  }
+}
+
+function getFieldStore(schema) {
+  let target = getStore(schema);
+  if (target !== undefined) {
+    return [
+      target,
+      "Single"
+    ];
+  }
+  if (schema.type !== "array") {
+    return;
+  }
+  let additionalItems = schema.additionalItems;
+  let match = schema.items[0];
+  let tmp;
+  tmp = match !== undefined ? getStore(match.schema) : (
+      additionalItems === "strip" || additionalItems === "strict" ? undefined : getStore(additionalItems)
+    );
+  return Stdlib_Option.map(tmp, target => [
+    target,
+    "Multiple"
+  ]);
+}
+
+export {
+  segmentIsSafe,
+  fromString,
+  forStore,
+  getStore,
+  getFieldStore,
+}
+/* S Not a pure module */

package/src/semantic/Url.res

@@ -0,0 +1,66 @@
+/**
+Marks a `string` field as a web address.
+
+## The grammar: parseable, **and** `http`/`https`
+
+Sury's `S.url` is the parse — it is `new URL()`, so it settles host, port and
+escaping without this module having an opinion. But `new URL()` accepts every
+scheme, `javascript:alert(1)` included, and that is not an academic gap here: a
+field carrying this semantic renders as an anchor whose `href` is the stored
+value. An append-only log plus a scheme nobody checked is a stored XSS that
+cannot be deleted afterwards — the same shape of hole `StorageRef` exists to
+close, arriving through a different field.
+
+So the grammar is sury's parse plus a two-scheme allowlist. `mailto:` and `tel:`
+are deliberately outside it: those are `Email` and `Phone`, which validate what
+they actually hold and render correctly on their own.
+
+@example
+```rescript
+@schema type command =
+  | SetSupplierSite({
+      supplierId: @s.matches(DcbTag.string) string,
+      website: @s.matches(Reventless.Url.schema) string,
+    })
+```
+*/
+
+/** The address's representation. Transparent `string`; see `Email.t`. */
+type t = string
+
+external unsafe: string => t = "%identity"
+external toString: t => string = "%identity"
+
+// Sury's parse, held once — `fromString` runs it and adds the scheme check, and
+// `schema` derives from `fromString`. One grammar, in one place.
+let grammar: S.t<string> = S.string->S.url
+
+// Schemes are case-insensitive per RFC 3986, and `HTTPS://x` parses fine, so the
+// allowlist has to fold case or it rejects a valid address on a technicality.
+let hasWebScheme = (raw: string): bool => {
+  let lower = String.toLowerCase(raw)
+  String.startsWith(lower, "http://") || String.startsWith(lower, "https://")
+}
+
+/** Validate a raw string as an `http`/`https` URL, saying why when it is not one. */
+let fromString = (raw: string): result<t, string> =>
+  switch raw->S.parseOrThrow(grammar) {
+  | value =>
+    if hasWebScheme(value) {
+      Ok(value)
+    } else {
+      Error(
+        `a URL field takes an http:// or https:// address, got ${Semantic.showString(raw)}. ` ++
+        `Use Email or Phone for mailto:/tel:, and a storage ref for an uploaded object.`,
+      )
+    }
+  | exception _ =>
+    Error(
+      `expected an absolute URL, got ${Semantic.showString(
+          raw,
+        )}. A relative path is not a URL — include the scheme and host.`,
+    )
+  }
+
+/** The sury schema for a URL field. Use with `@s.matches(Reventless.Url.schema)`. */
+let schema: S.t<t> = S.string->Semantic.refined(~id=Semantic.Id.url, ~check=fromString)

package/src/semantic/Url.res.mjs

@@ -0,0 +1,48 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as S from "sury/src/S.res.mjs";
+import * as Semantic$Reventless from "./Semantic.res.mjs";
+
+let grammar = S.url(S.string, undefined);
+
+function hasWebScheme(raw) {
+  let lower = raw.toLowerCase();
+  if (lower.startsWith("http://")) {
+    return true;
+  } else {
+    return lower.startsWith("https://");
+  }
+}
+
+function fromString(raw) {
+  let value;
+  try {
+    value = S.parseOrThrow(raw, grammar);
+  } catch (exn) {
+    return {
+      TAG: "Error",
+      _0: `expected an absolute URL, got ` + Semantic$Reventless.showString(raw) + `. A relative path is not a URL — include the scheme and host.`
+    };
+  }
+  if (hasWebScheme(value)) {
+    return {
+      TAG: "Ok",
+      _0: value
+    };
+  } else {
+    return {
+      TAG: "Error",
+      _0: `a URL field takes an http:// or https:// address, got ` + Semantic$Reventless.showString(raw) + `. Use Email or Phone for mailto:/tel:, and a storage ref for an uploaded object.`
+    };
+  }
+}
+
+let schema = Semantic$Reventless.refined(S.string, Semantic$Reventless.Id.url, fromString);
+
+export {
+  grammar,
+  hasWebScheme,
+  fromString,
+  schema,
+}
+/* grammar Not a pure module */

package/src/types/Authorization.res

@@ -0,0 +1,23 @@
+// Provider-agnostic authorization rules. Evaluated against the
+// `Identity.t` resolved by an `Auth_Adapter.Provider.authenticate` call.
+//
+// `array<string>` for groups (not a parameterised variant) keeps the
+// framework decoupled from any application's specific group set —
+// applications can define their own typed `group` variant and convert via
+// a thin helper, see docs/analysis/authentication-authorization.md §4.2.
+
+@schema
+type permission =
+  | AllowGroups(array<string>)
+  | AllowAuthenticated
+  | AllowAnonymous
+  | DenyAll
+
+let isAllowed = (rule: permission, identity: Identity.t): bool =>
+  switch rule {
+  | DenyAll => false
+  | AllowAnonymous => true
+  | AllowAuthenticated => identity.userId !== "anonymous"
+  | AllowGroups(groups) =>
+    groups->Array.some(group => identity.groups->Array.includes(group))
+  }