@reventlessdev/reventless-seed 1.0.0-alpha.2 → 1.0.0-alpha.21

package/src/Seed_Client.res

@@ -21,7 +21,8 @@ type response
 @val external setTimeout: (unit => unit, int) => unit = "setTimeout"
 @scope("Date") @val external nowMs: unit => float = "now"
 
-let sleep = (ms: int): promise<unit> => Promise.make((resolve, _) => setTimeout(() => resolve(), ms))
+let sleep = (ms: int): promise<unit> =>
+  Promise.make((resolve, _) => setTimeout(() => resolve(), ms))
 
 // ── Configuration ───────────────────────────────────────────────────────────
 
@@ -43,11 +44,143 @@ let make = (~config: config): t => {config, token: None}
     Seed.Upload) can authenticate side-channel requests with the same identity. */
 let currentToken = (t: t): option<string> => t.token
 
+/** The GraphQL endpoint this client targets — so `Seed.Upload` can resolve a
+    relative presigned `uploadUrl` against the same origin. */
+let endpoint = (t: t): string => t.config.endpoint
+
 /** Injects a bearer obtained out-of-band (e.g. a Cognito id token), instead of
     minting one via `login`. Provider-agnostic: the harness only cares that the
     token is a valid bearer for `endpoint`. */
 let useToken = (t: t, token: string): unit => t.token = Some(token)
 
+// ── What the bearer actually grants ─────────────────────────────────────────
+//
+// An account's listed groups are not necessarily the ones its token carries:
+// both platforms narrow a token to the single role the caller last chose to act
+// as. So a seed can log in as an account that looks eligible and be refused, and
+// the account list cannot explain it — only the token can.
+
+/** Claim names a narrowed token carries. These mirror the cross-provider
+    contract in `ReventlessCore.Auth_ActiveRole`; spelled out rather than
+    imported because this harness deliberately depends on no framework package. */
+let activeRoleClaim = "activeRole"
+let availableRolesClaim = "availableRoles"
+
+/** Group claim per provider, tried in order. */
+let groupClaimNames = ["cognito:groups", "groups"]
+
+/** Claim carrying the caller's id, per provider, tried in order. A Cognito JWT
+    says `sub`; the local dev token is a base64url `Identity.t`, whose field is
+    `userId`. Same shape as `groupClaimNames`, for the same reason: this harness
+    depends on no framework package and must not learn who signed the token. */
+let callerIdClaimNames = ["sub", "userId"]
+
+let decodeSegment = (segment: string): option<dict<JSON.t>> =>
+  try {
+    segment
+    ->NodeBuffer.fromStringBase64Url
+    ->NodeBuffer.toStringUtf8
+    ->JSON.parseOrThrow
+    ->JSON.Decode.object
+  } catch {
+  | _ => None
+  }
+
+/**
+ * A JOSE header rather than a claims set.
+ *
+ * RFC 7515 requires `alg` on the header, and nothing puts it on a payload. The
+ * test matters because a JWT header is base64url JSON exactly as the payload is,
+ * so it decodes just as readily — and it comes first.
+ */
+let isJoseHeader = (obj: dict<JSON.t>): bool => obj->Dict.get("alg")->Option.isSome
+
+/** The bearer's payload, from whichever segment carries it — a Cognito JWT puts
+    it second and a local dev token first, so trying each in turn saves this from
+    having to know which platform signed the token. A segment that is not a JSON
+    object (a signature) simply does not decode, and a JOSE header is skipped:
+    it IS a decodable JSON object, so taking the first one that parsed read a
+    real Cognito token's `{kid, alg}` as its claims and found no groups and no
+    id in it — silently, since an unreadable token is not an error here. */
+let claims = (t: t): option<dict<JSON.t>> =>
+  t.token->Option.flatMap(token =>
+    token
+    ->String.split(".")
+    ->Array.reduce(None, (found, segment) =>
+      switch found {
+      | Some(_) => found
+      | None =>
+        switch decodeSegment(segment) {
+        | Some(obj) if obj->isJoseHeader => None
+        | decoded => decoded
+        }
+      }
+    )
+  )
+
+// Arrays on the group claim, comma-joined on `availableRoles`.
+let asStrings = (value: JSON.t): option<array<string>> =>
+  switch value {
+  | Array(entries) => Some(entries->Array.filterMap(JSON.Decode.string))
+  | String(joined) =>
+    Some(joined->String.split(",")->Array.map(String.trim)->Array.filter(s => s != ""))
+  | _ => None
+  }
+
+let claimStrings = (t: t, name: string): option<array<string>> =>
+  t->claims->Option.flatMap(c => c->Dict.get(name))->Option.flatMap(asStrings)
+
+/** The groups the bearer actually presents — what every enforcement point reads.
+    `None` when the token is opaque to us, which is not an error: it just means
+    this cannot add anything. */
+let effectiveGroups = (t: t): option<array<string>> =>
+  groupClaimNames->Array.reduce(None, (found, name) =>
+    switch found {
+    | Some(_) => found
+    | None => t->claimStrings(name)
+    }
+  )
+
+/** The id the bearer presents — what an `@owner` field is stamped with, and so
+    the only id a seed can key owner-scoped rows to and have an account read them
+    back. `None` when the token is opaque to us or names no id. */
+let callerId = (t: t): option<string> =>
+  callerIdClaimNames->Array.reduce(None, (found, name) =>
+    switch found {
+    | Some(_) => found
+    | None => t->claims->Option.flatMap(c => c->Dict.get(name))->Option.flatMap(JSON.Decode.string)
+    }
+  )
+
+/**
+ * The membership a narrowed token was reduced *from*, or `None` when the bearer
+ * is not narrowed.
+ *
+ * `availableRoles` is only written when a role was chosen, so its presence is
+ * the narrowing — the group claim alone cannot tell you, since a token carrying
+ * one group looks identical whether the account holds one or five.
+ */
+let narrowedFrom = (t: t): option<array<string>> =>
+  switch t->claimStrings(availableRolesClaim) {
+  | Some(available) if available->Array.length > 0 => Some(available)
+  | _ => None
+  }
+
+/** One line naming the identity the bearer carries, and — when it was narrowed —
+    the membership it was narrowed from. The second half is the point: without it
+    a refusal looks like a misconfigured grant rather than a role switch. */
+let identitySummary = (t: t): option<string> =>
+  t
+  ->effectiveGroups
+  ->Option.map(groups => {
+    let held = groups->Array.length == 0 ? "no groups" : groups->Array.join(", ")
+    switch t->claimStrings(availableRolesClaim) {
+    | Some(available) if available->Array.length > 0 =>
+      `${held} — narrowed to this role from ${available->Array.join(", ")}`
+    | _ => held
+    }
+  })
+
 // ── JSON helpers ────────────────────────────────────────────────────────────
 
 let field = (json: JSON.t, key: string): option<JSON.t> =>
@@ -93,8 +226,9 @@ let login = async (t: t): unit => {
     let detail = await res->responseText
     throw(
       Failed(
-        `login as "${username}" failed with HTTP ${(res->responseStatus)
-            ->Int.toString}: ${detail}`,
+        `login as "${username}" failed with HTTP ${res
+          ->responseStatus
+          ->Int.toString}: ${detail}`,
       ),
     )
   }
@@ -102,12 +236,86 @@ let login = async (t: t): unit => {
   t.token = json->field("token")->Option.flatMap(asString)
 }
 
+/** Error types the endpoint returns for a fault on its own side rather than a
+    problem with the document. They say nothing about the request, so the same
+    request sent again can succeed — and across the few hundred commands a seed
+    issues, one of these is ordinary rather than exceptional.
+
+    Everything else — a validation error, an unknown field, a refused token — is
+    an answer, and the same answer comes back however many times it is asked. */
+let transientErrorTypes = [
+  "InternalFailure",
+  "ServiceUnavailable",
+  "ServiceUnavailableError",
+  "Throttling",
+  "ThrottlingException",
+  "TooManyRequestsException",
+  "RequestTimeout",
+]
+
+/** Every entry must be transient for the document to be worth resending: one
+    real error alongside a transient one still means the request was wrong. An
+    empty `errors` array is not a reason to retry either. */
+let isTransient = (errors: JSON.t): bool =>
+  switch errors->JSON.Decode.array {
+  | None | Some([]) => false
+  | Some(entries) =>
+    entries->Array.every(e =>
+      switch e->nodeString("errorType") {
+      | Some(errorType) => transientErrorTypes->Array.includes(errorType)
+      | None => false
+      }
+    )
+  }
+
+/** An authorization refusal, in either platform's vocabulary — AppSync answers
+    `errorType: "Unauthorized"`, the local server carries it in the message. */
+let isDenied = (errors: JSON.t): bool =>
+  switch errors->JSON.Decode.array {
+  | None => false
+  | Some(entries) =>
+    entries->Array.some(e =>
+      switch (e->nodeString("errorType"), e->nodeString("message")) {
+      | (Some(errorType), _) if errorType->String.includes("Unauthorized") => true
+      | (_, Some(message)) => message->String.includes("Not Authorized")
+      | _ => false
+      }
+    )
+  }
+
+let attempts = 4
+
 /**
  * Sends one GraphQL document and returns its `data`. A GraphQL-level error
  * aborts the run: a half-seeded store is worse than an empty one, because it
  * looks like a working dataset.
+ *
+ * Which is exactly why a fault on the endpoint's own side must not abort it. A
+ * seed issues hundreds of commands, many of them concurrently and all of them
+ * against runtimes that a preceding reset left cold, so a single
+ * `InternalFailure` somewhere in the batch is a normal event. Treating it as
+ * fatal threw away every command that had already landed and demanded a full
+ * wipe and re-run — for a request that would have succeeded on being asked
+ * again. So resend those, backing off between tries, and keep failing fast on
+ * everything that is an answer rather than a fault.
+ *
+ * The backoff is jittered because the commands go out in concurrent batches: a
+ * fixed delay would have the whole batch retry in lockstep and rebuild the same
+ * burst that provoked the fault.
  */
-let gql = async (t: t, ~query: string, ~label: string): JSON.t => {
+/** What a document came back as. `Errors` carries both the raw array — so a
+    caller can classify it, e.g. as a refusal — and the message `gql` would have
+    thrown, so the two paths cannot describe the same failure differently. */
+type failure = {errors: JSON.t, message: string}
+type outcome = Data(JSON.t) | Errors(failure)
+
+/**
+ * Sends one document and reports what came back, resending a transient fault
+ * along the way. Returning the errors rather than throwing is what lets a caller
+ * treat a refusal as an *answer* — which the authorization probe needs and
+ * seeding must never do.
+ */
+let gqlOutcome = async (t: t, ~query: string, ~label: string): outcome => {
   let headers = Dict.fromArray([("content-type", "application/json")])
   switch t.token {
   | Some(token) => headers->Dict.set("authorization", `Bearer ${token}`)
@@ -116,20 +324,71 @@ let gql = async (t: t, ~query: string, ~label: string): JSON.t => {
   let body = JSON.stringify(
     JSON.Encode.object(Dict.fromArray([("query", JSON.Encode.string(query))])),
   )
-  let res = try await fetch(t.config.endpoint, {method: "POST", headers, body}) catch {
-  | _ =>
-    throw(Failed(`${label}: cannot reach ${t.config.endpoint} — is the platform running?`))
-  }
-  let json = await res->responseJson
-  switch json->field("errors") {
-  | Some(errors) =>
-    throw(
-      Failed(`${label} failed\n  query: ${query}\n  response: ${JSON.stringify(errors)}`),
-    )
-  | None => json->field("data")->Option.getOr(JSON.Encode.null)
+  let rec attempt = async (n: int): outcome => {
+    let res = try await fetch(t.config.endpoint, {method: "POST", headers, body}) catch {
+    | _ => throw(Failed(`${label}: cannot reach ${t.config.endpoint} — is the platform running?`))
+    }
+    let json = await res->responseJson
+    switch json->field("errors") {
+    | Some(errors) =>
+      if errors->isTransient && n < attempts {
+        await sleep(250 * Int.shiftLeft(1, n - 1) + Int.fromFloat(Math.random() *. 250.))
+        await attempt(n + 1)
+      } else {
+        let tried = n > 1 ? `\n  gave up after ${n->Int.toString} attempts` : ""
+        // A refusal is the one failure the response cannot explain on its own:
+        // it names the field, never the caller. The account list can't either —
+        // it holds membership, and a narrowed token carries less.
+        let identity = switch isDenied(errors) ? t->identitySummary : None {
+        | Some(summary) => `\n  identity: ${summary}`
+        | None => ""
+        }
+        Errors({
+          errors,
+          message: `${label} failed\n  query: ${query}\n  response: ${JSON.stringify(
+              errors,
+            )}${identity}${tried}`,
+        })
+      }
+    | None => Data(json->field("data")->Option.getOr(JSON.Encode.null))
+    }
   }
+  await attempt(1)
 }
 
+let gql = async (t: t, ~query: string, ~label: string): JSON.t =>
+  switch await gqlOutcome(t, ~query, ~label) {
+  | Data(data) => data
+  | Errors({message}) => throw(Failed(message))
+  }
+
+/**
+ * Whether the endpoint let this caller through, for a probe that means to find
+ * out rather than to succeed.
+ *
+ * Three outcomes and not two: "not refused" and "worked" are different claims,
+ * and collapsing them would let a misspelled field name read as a passing
+ * authorization check. `Granted` covers a domain rejection too — a
+ * `CommandRejected` arrives inside `data` with no GraphQL error, which is
+ * precisely how a probe confirms access without writing anything.
+ */
+type access =
+  | Granted
+  | Refused
+  | // Served, and carrying nothing. Its own case because the two platforms deny a
+  // read differently: AppSync answers `Unauthorized`, while the local resolver's
+  // interceptor returns an empty connection — so on local an unauthorized read
+  // and an empty view are the same response, and no caller can tell them apart.
+  // Naming it lets a probe say "consistent with a denial" instead of guessing.
+  Empty
+  | Broke(string)
+
+let checkAccess = async (t: t, ~query: string, ~label: string): access =>
+  switch await gqlOutcome(t, ~query, ~label) {
+  | Data(_) => Granted
+  | Errors({errors, message}) => errors->isDenied ? Refused : Broke(message)
+  }
+
 // ── Commands ────────────────────────────────────────────────────────────────
 
 let commandResultSelection = `__typename
@@ -161,6 +420,61 @@ let send = async (t: t, m: mutation, ~tolerate: array<string>=[]): option<string
   }
 }
 
+/**
+ * Whether this caller may issue one command — asked with the very document
+ * `send` would have sent, so what the probe tests is what the seed actually
+ * uses rather than a hand-built lookalike.
+ *
+ * Pair it with a payload the domain would refuse anyway. Then `Granted` arrives
+ * as a `CommandRejected` inside `data`, which appends nothing: the probe learns
+ * that the door opened without walking through it, and a regression that wrongly
+ * opens a door still writes no events.
+ */
+/** Refusal codes a command result carries. The two platforms answer a refused
+    command differently — AppSync rejects at the field and produces a GraphQL
+    `Unauthorized` error, while the local resolver runs the command handler and
+    answers `CommandRejected { errorCode: "Forbidden" }` inside `data`. Reading
+    only the first reports the second as allowed. */
+let deniedCommandCodes = ["Forbidden", "Unauthorized", "AccessDenied"]
+
+let isDeniedResult = (result: JSON.t): bool =>
+  switch (result->nodeString("errorCode"), result->nodeString("errorDetail")) {
+  | (Some(code), _) if deniedCommandCodes->Array.includes(code) => true
+  | (_, Some(detail)) => detail->String.toLowerCase->String.includes("not authorized")
+  | _ => false
+  }
+
+let checkCommandAccess = async (t: t, m: mutation): access =>
+  switch await gqlOutcome(
+    t,
+    ~query=`mutation { r: ${m.field}(${m.args->renderArgs}) { ${commandResultSelection} } }`,
+    ~label=m->describe,
+  ) {
+  | Errors({errors, message}) => errors->isDenied ? Refused : Broke(message)
+  // No GraphQL error is not yet a grant: the local platform's refusal lives in
+  // the command result, so the domain's own answer has to be read too. Any other
+  // rejection IS a grant — the door opened and the domain refused what came
+  // through it, which is exactly the outcome a non-writing probe wants.
+  | Data(data) =>
+    data->field("r")->Option.getOr(JSON.Encode.null)->isDeniedResult ? Refused : Granted
+  }
+
+/** Whether this caller may read one connection field. One row is enough: the
+    door is answered by the first request, not by the page behind it — but
+    whether a row came back is what separates a grant from a silent denial. */
+let checkQueryAccess = async (t: t, ~field as fieldName: string): access => {
+  let query = `{ ${fieldName}(first: 1) { edges { node { id } } } }`
+  switch await gqlOutcome(t, ~query, ~label=fieldName) {
+  | Errors({errors, message}) => errors->isDenied ? Refused : Broke(message)
+  | Data(data) =>
+    let edges = switch data->field(fieldName)->Option.flatMap(c => c->field("edges")) {
+    | Some(Array(rows)) => rows->Array.length
+    | _ => 0
+    }
+    edges > 0 ? Granted : Empty
+  }
+}
+
 let sendAll = async (t: t, mutations: array<mutation>): unit =>
   for i in 0 to mutations->Array.length - 1 {
     switch mutations->Array.get(i) {
@@ -175,18 +489,27 @@ let sendAll = async (t: t, mutations: array<mutation>): unit =>
  * Walks a Relay-style connection to the end. Connections page at 50 by default,
  * so any count taken from a single request silently truncates.
  */
-let queryAllNodes = async (t: t, ~field as fieldName: string, ~selection: string): array<
-  JSON.t,
-> => {
+let // `~args` is spliced into the connection's argument list — `"includeRetired: true"`
+// is the case it exists for, and the only way to read rows the resolvers withhold
+// by default. Literal GraphQL rather than a typed argument list because a seed
+// writes the query it means; the alternative is a builder that has to grow a case
+// per argument the platform adds.
+queryAllNodes = async (
+  t: t,
+  ~field as fieldName: string,
+  ~selection: string,
+  ~args: string="",
+): array<JSON.t> => {
   let nodes = []
   let after = ref(None)
   let more = ref(true)
+  let extra = args == "" ? "" : `, ${args}`
   while more.contents {
     let cursor = switch after.contents {
     | Some(c) => `, after: ${quote(c)}`
     | None => ""
     }
-    let query = `{ ${fieldName}(first: 100${cursor}) { edges { node { ${selection} } } pageInfo { hasNextPage endCursor } } }`
+    let query = `{ ${fieldName}(first: 100${extra}${cursor}) { edges { node { ${selection} } } pageInfo { hasNextPage endCursor } } }`
     let data = await gql(t, ~query, ~label=fieldName)
     let connection = data->field(fieldName)->Option.getOr(JSON.Encode.null)
     switch connection->field("edges") {
@@ -216,6 +539,43 @@ let queryAllNodes = async (t: t, ~field as fieldName: string, ~selection: string
 let countNodes = async (t: t, ~field: string): int =>
   (await queryAllNodes(t, ~field, ~selection="id"))->Array.length
 
+/**
+ * Polls a connection field until the collected nodes satisfy `satisfied`, or the
+ * timeout elapses. Read models are eventually consistent: a view queried the
+ * instant after the writes that feed it can still read empty or partial (a
+ * DynamoDB connection scan is eventually consistent by default, and the write and
+ * read-back can land on different replicas), so a cross-check that asserts on a
+ * single immediate read races the projection. Same rationale as `waitForIds`,
+ * for the "observe the whole connection" case rather than a fixed id set.
+ *
+ * On timeout, throws `Failed(onTimeout(finalNodes))` so the caller can report
+ * what the view actually settled on — distinguishing a still-empty view from a
+ * genuine count mismatch — instead of a bare assertion.
+ */
+let queryAllNodesUntil = async (
+  t: t,
+  ~field: string,
+  ~selection: string,
+  ~args: string="",
+  ~satisfied: array<JSON.t> => bool,
+  ~onTimeout: array<JSON.t> => string,
+  ~timeoutMs: int=60000,
+): array<JSON.t> => {
+  let deadline = nowMs() +. Int.toFloat(timeoutMs)
+  let result = ref(None)
+  while result.contents == None {
+    let nodes = await queryAllNodes(t, ~field, ~selection, ~args)
+    if satisfied(nodes) {
+      result := Some(nodes)
+    } else if nowMs() > deadline {
+      throw(Failed(onTimeout(nodes)))
+    } else {
+      await sleep(500)
+    }
+  }
+  result.contents->Option.getOr([])
+}
+
 /**
  * Polls a `<View>ByIds` field until every id is present.
  *
@@ -250,8 +610,9 @@ let waitForIds = async (
         missing->Array.length > 10 ? ` (+${(missing->Array.length - 10)->Int.toString} more)` : ""
       throw(
         Failed(
-          `only ${(found->Array.length)->Int.toString}/${(ids->Array.length)
-              ->Int.toString} ids reached ${fieldName} within ${timeoutMs->Int.toString}ms.\n  missing: ${shown}${extra}`,
+          `only ${found->Array.length->Int.toString}/${ids
+            ->Array.length
+            ->Int.toString} ids reached ${fieldName} within ${timeoutMs->Int.toString}ms.\n  missing: ${shown}${extra}`,
         ),
       )
     } else {