@reventlessdev/reventless-spec 3.0.0-alpha.85 → 3.0.0-alpha.87

package/src/semantic/Phone.res.mjs

@@ -0,0 +1,29 @@
+// 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 e164 = /^\+[1-9]\d{0,14}$/;
+
+function fromString(raw) {
+  if (e164.test(raw)) {
+    return {
+      TAG: "Ok",
+      _0: raw
+    };
+  } else {
+    return {
+      TAG: "Error",
+      _0: `expected a phone number in E.164 form — "+" then up to 15 digits, as in "+4930123456" — got ` + Semantic$Reventless.showString(raw) + `. Spaces, dashes and brackets are not part of the stored form.`
+    };
+  }
+}
+
+let schema = Semantic$Reventless.refined(S.string, Semantic$Reventless.Id.phone, fromString);
+
+export {
+  e164,
+  fromString,
+  schema,
+}
+/* schema Not a pure module */

package/src/semantic/Semantic.res

@@ -48,6 +48,16 @@ module Id = {
   let dateTime = "dateTime"
   let reference = "reference"
   let storageRef = "storageRef"
+
+  // 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"
 }
 
 let semanticId: S.Metadata.Id.t<t> = S.Metadata.Id.make(~namespace="reventless", ~name="semantic")
@@ -56,8 +66,67 @@ let semanticId: S.Metadata.Id.t<t> = S.Metadata.Id.make(~namespace="reventless",
 let mark = (schema: S.t<'a>, ~id: string, ~payload: payload=Plain): S.t<'a> =>
   schema->S.Metadata.set(~id=semanticId, {id, payload})
 
-/** The semantic a field's schema carries, if any. */
-let get = (fieldSchema: S.t<'a>): option<t> => S.Metadata.get(fieldSchema, ~id=semanticId)
+/**
+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 =>

package/src/semantic/Semantic.res.mjs

@@ -5,7 +5,14 @@ import * as S from "sury/src/S.res.mjs";
 let Id = {
   dateTime: "dateTime",
   reference: "reference",
-  storageRef: "storageRef"
+  storageRef: "storageRef",
+  email: "email",
+  phone: "phone",
+  url: "url",
+  percent: "percent",
+  bytes: "bytes",
+  duration: "duration",
+  color: "color"
 };
 
 let semanticId = S.Metadata.Id.make("reventless", "semantic");
@@ -18,12 +25,52 @@ function mark(schema, id, payloadOpt) {
   });
 }
 
-function get(fieldSchema) {
-  return S.Metadata.get(fieldSchema, semanticId);
+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 = S.Metadata.get(fieldSchema, semanticId);
+  let s = getFrom(fieldSchema);
   if (s !== undefined) {
     return s.id === id;
   } else {
@@ -35,6 +82,9 @@ export {
   Id,
   semanticId,
   mark,
+  refined,
+  showString,
+  getFrom,
   get,
   has,
 }

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 */