@voxgig/sdkgen 4.32.1 → 4.34.0

package/project/.sdk/src/cmp/ocaml/TestClean_ocaml.ts

@@ -0,0 +1,538 @@
+import {
+  cmp,
+  each,
+  File,
+  Content,
+  isAuthSuppressed,
+  isHttpBasicAuth,
+  resolveAuthIn,
+  resolveAuthName,
+} from '@voxgig/sdkgen'
+
+
+import { ocamlString, ocamlVarName } from './utility_ocaml'
+
+
+// The canary sweep, the ocaml port of TestClean_ts.ts: see that component.
+const TestClean = cmp(function TestClean(props: any) {
+  const { model } = props.ctx$
+  const { target, entity } = props
+
+  const auth = {
+    suppressed: isAuthSuppressed(model),
+    where: resolveAuthIn(model),
+    name: 'header' === resolveAuthIn(model)
+      ? resolveAuthName(model).toLowerCase() : resolveAuthName(model),
+    basic: isHttpBasicAuth(model),
+  }
+
+  File({ name: 'clean_test.' + target.ext }, () => Content(render(model, entity, auth)))
+})
+
+
+const OP_ORDER: Record<string, number> = { list: 0, load: 1 }
+
+
+// The path parameters an operation's points declare, as the runtime config
+// carries them under points[].args.params.
+function pointParams(opdef: any): string[] {
+  const names: string[] = []
+  for (const point of each(opdef?.points || [])) {
+    if (false === point?.a) continue
+    for (const arg of each(point?.g?.params || [])) {
+      if (false !== arg?.a && 'string' === typeof arg?.n && !names.includes(arg.n)) {
+        names.push(arg.n)
+      }
+    }
+  }
+  return names
+}
+
+
+// The operations to try, list and load first: a required path parameter is
+// what usually stops a candidate, and the read ops need none. Each runs to
+// the record so the candidates share one type.
+function candidates(entity: any[]): string {
+  const rows: { rank: number, text: string }[] = []
+  each(entity, (e: any) => {
+    const fn = ocamlVarName(e.name)
+    for (const op of Object.keys(e.op || {})) {
+      const run = 'list' === op
+        ? `lst (List.map (fun en -> en.e_data_get ()) (ent.e_list m ctrl))`
+        : 'load' === op ? `(ent.e_load m ctrl).e_data_get ()`
+          : 'create' === op ? `(ent.e_create m ctrl).e_data_get ()`
+            : 'update' === op ? `(ent.e_update m ctrl).e_data_get ()`
+              : 'remove' === op ? `(ent.e_remove m ctrl).e_data_get ()`
+                : null
+      if (null == run) continue
+      rows.push({
+        rank: OP_ORDER[op] ?? 2,
+        text: `  { c_name = "${ocamlString(e.name + '.' + op)}";
+    c_params = [${pointParams(e.op[op]).map((p) => '"' + ocamlString(p) + '"').join('; ')}];
+    c_run = (fun sdk m ctrl -> let ent = Sdk_client.${fn} sdk Noval in ${run});
+    c_stream = (fun sdk m callopts ->
+        let ent = Sdk_client.${fn} sdk Noval in List.of_seq (ent.e_stream "${op}" m callopts)) };`,
+      })
+    }
+  })
+  rows.sort((a, b) => a.rank - b.rank)
+  return rows.map((r) => r.text).join('\n')
+}
+
+
+function render(model: any, entity: any[], auth: {
+  suppressed: boolean, where: string, name: string, basic: boolean
+}): string {
+  return `(* ${model.const.Name} SDK canary sweep (generated by @voxgig/sdkgen).
+ *
+ * Every credential slot holds a distinctive value, every diagnostic feature
+ * this SDK ships is switched on with a capturing sink, a real operation runs
+ * through every outcome, and every string that leaves the SDK is searched
+ * for the canaries and their encoded forms. It also proves its own
+ * sensitivity: with clean switched off the canary MUST show. *)
+
+open Voxgig_struct
+open Sdk_types
+open Sdk_helpers
+open Sdk_runtime
+open Testutil
+
+(* Generated: the credential's wire placement is fixed when the SDK is built. *)
+let auth_suppressed = ${auth.suppressed}
+let auth_where = "${ocamlString(auth.where)}"
+let auth_name = "${ocamlString(auth.name)}"
+let auth_basic = ${auth.basic}
+let _ = auth_basic
+
+let canary = [
+  ("apikey", "CANARY-APIKEY-k9x2m7q4p1");
+  ("secret", "CANARY-SECRET-w3e8r5t2y6");
+  ("header", "CANARY-HEADER-z1x4c7v0b3");
+  ("value", "CANARY-VALUE-n5m8b2v9c4") ]
+
+let canary_of (k : string) : string = List.assoc k canary
+let mask = "[redacted]"
+
+(* Every form a canary can travel in. *)
+let forms_all : string list =
+  List.concat (List.map (fun (_, v) -> [v; base64_encode v; escurl_s v]) canary)
+  @ [base64_encode (canary_of "apikey" ^ ":" ^ canary_of "secret")]
+
+let leaks (text : string) : string list = List.filter (fun f -> substr_contains text f) forms_all
+
+let ends_with_s (s : string) (suf : string) : bool =
+  let ls = String.length s and lf = String.length suf in
+  ls >= lf && String.sub s (ls - lf) lf = suf
+
+(* Header maps keep the caller's spelling; the assertion should not care. *)
+let header (m : value) (name : string) : value = header_ci m name
+
+type sinks = (string * string) list ref
+
+let push (sinks : sinks) (name : string) (kind : string) (f : unit -> string) : unit =
+  try sinks := !sinks @ [(name ^ ":" ^ kind, f ())] with _ -> ()
+
+(* Every print and serialisation of a value, as a sink each. *)
+let value_forms (sinks : sinks) (name : string) (v : value) : unit =
+  push sinks name "json" (fun () -> jsonify v);
+  push sinks name "stringify" (fun () -> stringify v);
+  push sinks name "js" (fun () -> js_string v)
+
+let error_forms (sinks : sinks) (name : string) (e : exn) : unit =
+  push sinks name "printexc" (fun () -> Printexc.to_string e);
+  match e with
+  | Sdk_error_exc er ->
+    push sinks name "message" (fun () -> er.err_msg);
+    push sinks name "code" (fun () -> er.err_code);
+    value_forms sinks (name ^ ".result") er.err_result;
+    value_forms sinks (name ^ ".spec") er.err_spec;
+    value_forms sinks (name ^ ".value") (err_to_value er)
+  | _ -> ()
+
+(* Captures the serialised context from inside the pipeline: what a hook
+ * author would hand to a logger. *)
+let capture_feature (sinks : sinks) : feature =
+  let f = { f_name = "capture"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+            f_init = (fun _ _ -> ()); f_hook = (fun _ _ -> ()) } in
+  f.f_hook <- (fun name ctx ->
+      match name with
+      | "PreRequest" | "PreResponse" | "PreUnexpected" -> value_forms sinks ("ctx@" ^ name) (ctx_to_value ctx)
+      | _ -> ());
+  f
+
+let response ?(headers = []) (status : int) (data : value) : value =
+  let h = jo [("content-type", Str "application/json")] in
+  List.iter (fun (k, v) -> setp h k (Str v)) headers;
+  jo [("status", vint_of status); ("statusText", Str (if status < 400 then "OK" else "ERR"));
+      ("headers", h); ("body", Str (jsonify data)); ("json", json_thunk data)]
+
+type scenario = { s_name : string; s_respond : string -> value -> value }
+
+(* system.fetch answers a value; "__err__" is the transport-failure form. *)
+let scenarios : scenario list = [
+  { s_name = "ok"; s_respond = (fun _ _ ->
+        response ~headers:[("x-session-token", "RESP-TOKEN-a1b2c3d4e5")] 200
+          (jo [("id", Str "i1"); ("name", Str "n1")])) };
+  { s_name = "notfound"; s_respond = (fun _ _ -> response 404 (jo [("error", Str "no such record")])) };
+  { s_name = "server"; s_respond = (fun _ _ -> response 500 (jo [("error", Str "boom")])) };
+  { s_name = "transport"; s_respond = (fun url _ ->
+        jo [("__err__", Str ("socket hang up (URL was: \\"" ^ url ^ "\\")"))]) };
+  { s_name = "notjson"; s_respond = (fun _ _ ->
+        jo [("status", Num 200.); ("statusText", Str "OK"); ("headers", empty_map ());
+            ("body", Str "<html>");
+            ("json", Func (fun _ _ _ _ -> failwith "Unexpected token < in JSON"))]) } ]
+
+let make_sdk ?(extra = []) (sc : scenario) (sinks : sinks) (cleanopts : (string * value) list) : sdk_client =
+  let capture name = vfunc1 (fun record -> value_forms sinks name record; Noval) in
+  let feature = empty_map () in
+  let on name kvs = if Harness.has_feature name then setp feature name (jo (("active", Bool true) :: kvs)) in
+  on "log" [("logger", capture "log")];
+  on "debug" [("onEntry", capture "debug")];
+  on "audit" [("sink", capture "audit")];
+  on "telemetry" [("exporter", capture "telemetry")];
+  on "cost" [("sink", capture "cost")];
+  on "metrics" [];
+  on "clienttrack" [];
+  let clean = jo [("values", Str (canary_of "value"))] in
+  List.iter (fun (k, v) -> setp clean k v) cleanopts;
+  let fetch = Func (fun _ args _ _ ->
+      let url = match getelem args (Num 0.) with Str s -> s | _ -> "" in
+      sc.s_respond url (getelem args (Num 1.))) in
+  let client = Sdk_client.make (jo [
+      ("apikey", Str (canary_of "apikey")); ("secret", Str (canary_of "secret"));
+      ("headers", jo [("X-Custom-Token", Str (canary_of "header"))]);
+      ("clean", clean); ("feature", feature);
+      ("system", jo [("fetch", fetch)])]) in
+  client.cl_features <- client.cl_features @ [capture_feature sinks] @ extra;
+  client
+
+(* A feature that raises from inside the pipeline, quoting the request it
+ * saw: an error make_error never handled. The unexpected variant raises the
+ * SDK's own error there, so the catch path fires PreUnexpected, and raises
+ * again from that hook. *)
+let throw_feature ?(unexpected = false) () : feature =
+  let saw ctx = "hook saw " ^ (match ctx.c_spec with
+      | Some sp -> jsonify (spec_to_value sp)
+      | None -> "null") in
+  { f_name = "throwhook"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+    f_init = (fun _ _ -> ());
+    f_hook = (fun name ctx ->
+        match name, unexpected with
+        | "PreResponse", true ->
+          raise (Sdk_error_exc { err_code = "throwhook"; err_msg = saw ctx;
+                                 err_result = Noval; err_spec = Noval })
+        | "PreResponse", false | "PreUnexpected", true -> failwith (saw ctx)
+        | _ -> ()) }
+
+(* Features that fail the operation with the SDK's own error, whose code
+ * quotes a registered value: one refuses it as rbac does, and records the
+ * error PreUnexpected hands a hook; the other raises. *)
+let deny_feature (sinks : sinks) : feature =
+  { f_name = "denyhook"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+    f_init = (fun _ _ -> ());
+    f_hook = (fun name ctx ->
+        match name with
+        | "PrePoint" ->
+          Hashtbl.replace ctx.c_out "point"
+            (OErr (ctx_make_error ctx ("denied:" ^ canary_of "value") "denied"))
+        | "PreUnexpected" ->
+          (match ctx.c_ctrl.ctrl_err with
+           | Some er -> error_forms sinks "error" (Sdk_error_exc er)
+           | None -> ())
+        | _ -> ()) }
+
+let raise_feature () : feature =
+  { f_name = "raisehook"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+    f_init = (fun _ _ -> ());
+    f_hook = (fun name _ ->
+        if name = "PreResponse" then
+          raise (Sdk_error_exc { err_code = "raised:" ^ canary_of "value"; err_msg = "raised";
+                                 err_result = Noval; err_spec = Noval })) }
+
+(* A stream whose producer fails while the caller consumes it, quoting a
+ * credential. *)
+let stream_throw_feature () : feature =
+  { f_name = "streamthrow"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+    f_init = (fun _ _ -> ());
+    f_hook = (fun name ctx ->
+        match name, ctx.c_result with
+        | "PreDone", Some result ->
+          result.rt_stream <- Some (fun () -> failwith ("stream saw " ^ canary_of "apikey"))
+        | _ -> ()) }
+
+(* A stream a feature supplies, which succeeds. *)
+let stream_ok_feature () : feature =
+  { f_name = "streamok"; f_version = "0.0.1"; f_active = true; f_options = Noval;
+    f_init = (fun _ _ -> ());
+    f_hook = (fun name ctx ->
+        match name, ctx.c_result with
+        | "PreDone", Some result ->
+          let items = match result.rt_resdata with List r -> !r | v when is_nullish v -> [] | v -> [v] in
+          result.rt_stream <- Some (fun () -> items)
+        | _ -> ()) }
+
+let code_of (e : exn option) : string =
+  match e with Some (Sdk_error_exc er) -> er.err_code | _ -> "<no SDK error>"
+
+let msg_of (e : exn option) : string =
+  match e with Some (Sdk_error_exc er) -> er.err_msg | _ -> "<no SDK error>"
+
+type candidate = {
+  c_name : string;
+  c_params : string list;
+  c_run : sdk_client -> value -> value -> value;
+  c_stream : sdk_client -> value -> value -> value list;
+}
+
+type target = { t_cand : candidate; t_params : string list }
+
+(* A fresh match for each call, since an operation may keep what it is given. *)
+let args (params : string list) : value = jo (List.map (fun p -> (p, Str "p1")) params)
+
+let rec first_some (f : 'a -> 'b option) (l : 'a list) : 'b option =
+  match l with
+  | [] -> None
+  | x :: rest -> (match f x with Some _ as r -> r | None -> first_some f rest)
+
+(* The operations this SDK generated, read ops first. *)
+let candidates : candidate list = [
+${candidates(entity)}
+]
+
+(* The first operation that completes against a plain 200: with no
+ * arguments, else with every path parameter its points declare filled in. *)
+let usable_op () : target option =
+  let plain = Sdk_client.make (jo [
+      ("apikey", Str (canary_of "apikey"));
+      ("system", jo [("fetch", Func (fun _ _ _ _ -> response 200 (jo [("id", Str "i1")])))])]) in
+  first_some (fun c ->
+      first_some (fun ps ->
+          try ignore (c.c_run plain (args ps) (empty_map ())); Some { t_cand = c; t_params = ps }
+          with _ -> None) [[]; c.c_params]) candidates
+
+let drive (sdk : sdk_client) (t : target) (ctrl : value) (sinks : sinks) : exn option =
+  (* A caller may keep the record it passed rather than read ctrl.explain. *)
+  let held = getp ctrl "explain" in
+  let err =
+    try value_forms sinks "result" (t.t_cand.c_run sdk (args t.t_params) ctrl); None
+    with e -> error_forms sinks "error" e; Some e in
+  (match getp ctrl "explain" with Map _ as ex -> value_forms sinks "explain" ex | _ -> ());
+  (match held, getp ctrl "explain" with
+   | Map h, Map now when h == now -> ()
+   | Map _, _ -> value_forms sinks "explain:held" held
+   | _ -> ());
+  err
+
+let variants : (string * (unit -> value)) list = [
+  ("throw", (fun () -> empty_map ()));
+  ("explain", (fun () -> jo [("explain", empty_map ())]));
+  ("nothrow", (fun () -> jo [("throw", Bool false); ("explain", empty_map ())])) ]
+
+let no_target = "no operation of this SDK completes against a plain 200; nothing to sweep"
+
+(* The harness has no skip, so a sweep with nothing to drive says so. *)
+let () =
+  test "clean.no_credential_leaves_the_sdk" (fun () ->
+      match usable_op () with
+      | None -> Printf.printf "SKIP clean.no_credential_leaves_the_sdk: %s\\n%!" no_target
+      | Some target ->
+      let sinks : sinks = ref [] in
+      let errors = ref [] and explains = ref [] in
+      List.iter (fun sc ->
+          List.iter (fun (vname, mkctrl) ->
+              let sdk = make_sdk sc sinks [] in
+              let ctrl = mkctrl () in
+              let err = drive sdk target ctrl sinks in
+              let key = sc.s_name ^ "/" ^ vname in
+              (match err with Some e -> errors := (key, e) :: !errors | None -> ());
+              (match getp ctrl "explain" with Map _ as ex -> explains := (key, ex) :: !explains | _ -> ());
+              value_forms sinks "sdk" (client_to_value sdk)) variants) scenarios;
+      (* A credential mistyped as a map is rejected by validation, whose
+       * message quotes the value it rejected. *)
+      let rejected =
+        try
+          ignore (Sdk_client.make (jo [
+              ("apikey", jo [("value", Str (canary_of "apikey"))]);
+              ("clean", jo [("values", Str (canary_of "value"))])]));
+          None
+        with e -> Some e in
+      (match rejected with
+       | Some e -> error_forms sinks "rejected" e
+       | None -> failwith "a credential mistyped as a map should be rejected");
+      (* An error a feature hook raises, quoting the request, skips make_error,
+       * and the explain record it interrupted leaves cleaned too. *)
+      List.iter (fun unexpected ->
+          let hooked = make_sdk ~extra:[throw_feature ~unexpected ()] (List.hd scenarios) sinks [] in
+          check "the throwing hook should fail the operation"
+            (match drive hooked target (jo [("explain", empty_map ())]) sinks with
+             | Some (Failure m) -> substr_contains m "hook saw"
+             | _ -> false)) [false; true];
+      (* A feature's own error keeps its code, which is cleaned like the
+       * message: returned, handed to a hook, and raised by a hook. *)
+      let denied = drive (make_sdk ~extra:[deny_feature sinks] (List.hd scenarios) sinks [])
+          target (empty_map ()) sinks in
+      let raised = drive (make_sdk ~extra:[raise_feature ()] (List.hd scenarios) sinks [])
+          target (empty_map ()) sinks in
+      (* Consuming a stream runs inside the same catch path as the operation,
+       * and the explain record the caller passed is cleaned however it ends. *)
+      List.iter (fun (name, extra) ->
+          let streamed = make_sdk ~extra (List.hd scenarios) sinks [] in
+          let explain = empty_map () in
+          let streamerr =
+            try ignore (target.t_cand.c_stream streamed (args target.t_params)
+                          (jo [("ctrl", jo [("explain", explain)])])); None
+            with e -> error_forms sinks name e; Some e in
+          check (name ^ ": only the failing stream throws") ((name = "stream") = (streamerr <> None));
+          check (name ^ ": the explain record was not filled") (keysof explain <> []);
+          value_forms sinks (name ^ ":explain") explain)
+        [("stream", [stream_throw_feature ()]); ("stream-ok", [stream_ok_feature ()]);
+         ("stream-plain", [])];
+      (* A client given no clean block at all masks by the schema defaults. *)
+      let bare = Sdk_client.make (jo [
+          ("apikey", Str (canary_of "apikey")); ("secret", Str (canary_of "secret"));
+          ("headers", jo [("X-Custom-Token", Str (canary_of "header"))]);
+          ("system", jo [("fetch", Func (fun _ args _ _ ->
+               let url = match getelem args (Num 0.) with Str s -> s | _ -> "" in
+               (List.nth scenarios 1).s_respond url (getelem args (Num 1.))))])]) in
+      let barerr = drive bare target (empty_map ()) sinks in
+      (* The raw path returns its failure rather than raising it. *)
+      let direct = Sdk_client.direct (make_sdk (List.nth scenarios 3) sinks []) (jo [("path", Str "raw")]) in
+      check "a transport failure should fail direct()" (getp direct "ok" = Bool false);
+      value_forms sinks "direct" direct;
+      let leaked = List.filter (fun (_, text) -> leaks text <> []) !sinks in
+      Printf.printf "clean: swept %d surface(s), %d leak(s)\\n%!" (List.length !sinks) (List.length leaked);
+      if leaked <> [] then
+        failwith ("credential leaked through: "
+                  ^ String.concat "; " (List.map (fun (n, t) -> n ^ " [" ^ String.concat ", " (leaks t) ^ "]") leaked));
+      (* The positive half: the slot the credential travelled in is masked,
+       * and an unregistered token in a response header is masked by name. *)
+      let notfound = match List.assoc_opt "notfound/throw" !errors with
+        | Some (Sdk_error_exc e) -> e
+        | _ -> failwith "the 404 scenario must throw an SDK error" in
+      check_vnum "status 404" (getp notfound.err_result "status") 404.;
+      let spec = notfound.err_spec in
+      if not auth_suppressed then begin
+        if auth_where = "query" then
+          check_vstr "query credential masked" (header (getp spec "query") auth_name) mask
+        else if auth_where = "cookie" then
+          check "cookie masked" (substr_contains (vstring (header (getp spec "headers") "cookie")) mask)
+        else
+          check "credential header masked" (ends_with_s (vstring (header (getp spec "headers") auth_name)) mask)
+      end;
+      check_vstr "custom token masked" (header (getp spec "headers") "x-custom-token") mask;
+      check ("the refusal's code is masked: " ^ code_of denied) (code_of denied = "denied:" ^ mask);
+      check ("the raised code is masked: " ^ code_of raised) (code_of raised = "raised:" ^ mask);
+      (match barerr with
+       | Some (Sdk_error_exc e) ->
+         check_vstr "no clean block: custom token masked" (header (getp e.err_spec "headers") "x-custom-token") mask
+       | _ -> failwith "the 404 scenario must throw without a clean block");
+      let explained = match List.assoc_opt "ok/explain" !explains with
+        | Some ex -> ex
+        | None -> failwith "the ok scenario recorded no explain" in
+      let result = getp explained "result" in
+      check "the explain record should carry the result" (ismap result);
+      check_vstr "response token masked" (header (getp result "headers") "x-session-token") mask)
+
+let () =
+  test "clean.the_sweep_can_see_a_leak" (fun () ->
+      match usable_op () with
+      | None -> Printf.printf "SKIP clean.the_sweep_can_see_a_leak: %s\\n%!" no_target
+      | Some target ->
+      let sinks : sinks = ref [] in
+      let sdk = make_sdk (List.nth scenarios 1) sinks [("active", Bool false)] in
+      let err = drive sdk target (empty_map ()) sinks in
+      check "with clean off, nothing showed the canary: the sweep is blind"
+        (List.exists (fun (_, t) -> leaks t <> []) !sinks);
+      (* Explaining a failure must not cost it its error. *)
+      let quiet : sinks = ref [] in
+      let explained = drive (make_sdk (List.nth scenarios 1) quiet [("active", Bool false)])
+          target (jo [("explain", empty_map ())]) quiet in
+      check ("with clean off, explain lost the error: " ^ msg_of explained)
+        (msg_of explained = msg_of err);
+      match err with
+      | Some (Sdk_error_exc e) ->
+        if not auth_suppressed then begin
+          let text = jsonify e.err_spec in
+          check "the raw spec should carry the credential when clean is off"
+            (substr_contains text (canary_of "apikey")
+             || substr_contains text (base64_encode (canary_of "apikey" ^ ":" ^ canary_of "secret")))
+        end
+      | _ -> failwith "the 404 scenario must throw an SDK error")
+
+let clean_ctx () : value * ctx =
+  let cfg = make_clean_config (jo [("keys", Str "key,secret,token")]) in
+  let base = make_context_impl (default_ctxspec ()) None in
+  (cfg, { base with c_options = jo [("__derived__", jo [("clean", cfg)])] })
+
+let () =
+  test "clean.a_registered_value_used_as_a_property_name" (fun () ->
+      let (_, ctx) = clean_ctx () in
+      clean_add_util ctx "ZZVAL-abc123";
+      clean_add_util ctx "ZZVAL-xyz789";
+      let out = clean_util ctx
+          (jo [("ZZVAL-abc123", Num 1.); ("ZZVAL-xyz789", Num 2.); ("plain", Num 3.)]) in
+      check_vnum "a registered name is masked" (getp out mask) 1.;
+      check_vnum "a colliding masked name is numbered" (getp out (mask ^ "#1")) 2.;
+      check_vnum "a plain name is kept" (getp out "plain") 3.;
+      check "the registered name is gone" (not (List.mem "ZZVAL-abc123" (keysof out))))
+
+(* A feature's name is not a field name: a feature called secrets does not
+ * make its settings secret, though a sensitive field inside it still is. An
+ * entity block, of per-entity settings or seeded records keyed by entity name
+ * and id, is not read at all. *)
+let () =
+  test "clean.a_feature_name_is_read_as_a_name" (fun () ->
+      let seeded = jo [("zztoken", jo [("ZZTOKEN01", jo [("note", Str "PLAINRECORD-t5r3e1w9")])])] in
+      let client = Sdk_client.make (jo [
+          ("apikey", Str (canary_of "apikey"));
+          ("feature", jo [
+              ("secrets", jo [("active", Bool false); ("name", Str "ZZNAME-feat123");
+                              ("token", Str "ZZTOKEN-feat456")]);
+              ("test", jo [("active", Bool false); ("entity", seeded)])]);
+          ("entity", jo [("zztoken", jo [("alias", jo [("zzkey", Str "PLAINALIAS-m2n4b6v8")])])])]) in
+      match client.cl_rootctx with
+      | Some ctx ->
+        check_vstr "only the sensitive field is masked"
+          (clean_util ctx (Str "ZZNAME-feat123 ZZTOKEN-feat456")) ("ZZNAME-feat123 " ^ mask);
+        check_vstr "a record seeded under an entity block is not registered"
+          (clean_util ctx (Str "record PLAINRECORD-t5r3e1w9")) "record PLAINRECORD-t5r3e1w9";
+        check_vstr "an entity's own settings are not registered"
+          (clean_util ctx (Str "alias PLAINALIAS-m2n4b6v8")) "alias PLAINALIAS-m2n4b6v8"
+      | None -> failwith "the client has no root context")
+
+let () =
+  test "clean.the_generated_configs_own_clean_block_is_honoured" (fun () ->
+      let base = make_context_impl (default_ctxspec ()) None in
+      let config = jo [("options", jo [("clean", jo [
+          ("keys", Str "zzsens"); ("values", Str "CONFIG-SEEDED-1")])])] in
+      let opts = make_options_util { base with c_config = config;
+                                               c_options = jo [("clean", jo [("values", Str "CALLER-SEEDED-2")])] } in
+      let ctx = { base with c_options = opts } in
+      check_vstr "both seeded values are masked"
+        (clean_util ctx (Str "a CONFIG-SEEDED-1 b CALLER-SEEDED-2")) ("a " ^ mask ^ " b " ^ mask);
+      let out = clean_util ctx (jo [("my_zzsens", Str "x"); ("other", Str "y")]) in
+      check_vstr "the config's key name is sensitive" (getp out "my_zzsens") mask;
+      check_vstr "an ordinary name is kept" (getp out "other") "y";
+      check_vstr "the config's keys are left alone" (getpath_s config "options.clean.keys") "zzsens";
+      check_vstr "the config's values are left alone" (getpath_s config "options.clean.values") "CONFIG-SEEDED-1")
+
+let () =
+  test "clean.add_sensitive_registers_every_scalar_under_a_sensitive_name" (fun () ->
+      let (cfg, ctx) = clean_ctx () in
+      clean_add_sensitive ctx (jo [
+          ("apikey", jo [("value", Str "NESTED-SECRET-1")]);
+          ("headers", jo [("X-Api-Token", ja [Str "LISTED-SECRET-2"])]);
+          ("secret", Num 123456789.);
+          ("name", Str "not-a-secret")]);
+      let values = str_values (getp cfg "values") in
+      check "nested under apikey" (List.mem "NESTED-SECRET-1" values);
+      check "listed under a token header" (List.mem "LISTED-SECRET-2" values);
+      check "a number, as its text" (List.mem "123456789" values);
+      check "an ordinary name" (not (List.mem "not-a-secret" values)))
+`
+}
+
+
+export {
+  TestClean
+}

package/project/.sdk/src/cmp/ocaml/Test_ocaml.ts

@@ -8,6 +8,7 @@ import { cmp, each, Folder, entityCollection } from '@voxgig/sdkgen'
 
 import { TestEntity } from './TestEntity_ocaml'
 import { TestDirect } from './TestDirect_ocaml'
+import { TestClean } from './TestClean_ocaml'
 import { ReadmeExamplesTest } from './ReadmeExamplesTest_ocaml'
 
 
@@ -24,6 +25,10 @@ const Test = cmp(function Test(props: any) {
       TestDirect({ target, entity })
     })
 
+    // The canary sweep (test/clean_test.ml), linked by the Makefile's
+    // CLEAN_TESTS.
+    TestClean({ target, entity })
+
     // Structural gate over the ```ocaml blocks in the generated docs.
     ReadmeExamplesTest({ target })
   })

package/project/.sdk/src/cmp/ocaml/fragment/RunOp.fragment.ml

@@ -1,3 +1,18 @@
+(* The catch path every entity call leaves through: an error that never
+ * passed through make_error leaves cleaned, and so does the explain record
+ * it interrupted. An SDK error fires PreUnexpected here, and whatever that
+ * hook raises is cleaned in its place. *)
+let unexpected (ctx : ctx) (e : exn) : 'a =
+  let e = match e with
+    | Sdk_error_exc _ ->
+      (try
+         (* #PreUnexpected-Hook *)
+         e
+       with hookerr -> hookerr)
+    | _ -> e in
+  clean_explain ctx;
+  raise (clean_exn ctx e)
+
 (* Run the operation pipeline, firing feature hooks between stages via the
  * generated hook-marker lines. post_done runs after the PreDone stage, just
  * before done. Errors from any stage go through make_error (which either
@@ -26,7 +41,4 @@ let run_op (ctx : ctx) (post_done : unit -> unit) : value =
        post_done ();
        utility.u_done ctx
      with Op_return v -> v)
-  with
-  | Sdk_error_exc _ as e ->
-    (* #PreUnexpected-Hook *)
-    raise e
+  with e -> unexpected ctx e

package/project/.sdk/src/cmp/perl/PrepareAuth_perl.ts

@@ -291,6 +291,9 @@ function basicBlock(spec: AuthSpec, wantBasic: boolean): string {
       # newline inside a header value is not a header value.
       my $pass = $no_secret ? '' : $secret;
       my $b64 = MIME::Base64::encode_base64("$apikey:$pass", '');
+      # The joined, encoded pair is a wire form neither credential's own
+      # registration covers.
+      $ctx->{utility}{clean_add}->($ctx, $b64);
       $headers->{$CRED_NAME} =
         ('' eq $auth_prefix) ? $b64 : "$auth_prefix $b64";
     }