|
| 1 | +-- SPDX-License-Identifier: PMPL-1.0-or-later |
| 2 | +-- Copyright (c) 2026 Jonathan D.A. Jewell (hyperpolymath) <j.d.a.jewell@open.ac.uk> |
| 3 | +-- |
| 4 | +-- ConnectorSafety.idr - V11: Connector type safety (eliminate unchecked |
| 5 | +-- JSON casts). |
| 6 | +-- |
| 7 | +-- V11 in standards/docs/proofs/spec-templates/T1-critical/verisimdb.md. |
| 8 | +-- |
| 9 | +-- Corresponds to: connectors/clients/*.res (ReScript SDKs that previously |
| 10 | +-- used Obj.magic to cast untyped Js.Json.t into typed values). |
| 11 | +-- |
| 12 | +-- Claim: every json -> typed conversion goes through a total validator |
| 13 | +-- that returns `Either ValidationError (ValidatedValue s)`. There is no |
| 14 | +-- public constructor for `ValidatedValue s` that bypasses the validator, |
| 15 | +-- so any code path producing a `ValidatedValue s` has a proof-of-shape |
| 16 | +-- at the type level. |
| 17 | +-- |
| 18 | +-- The proof consists of three parts: |
| 19 | +-- (1) `validate` is total (by Idris2 totality check + %default total). |
| 20 | +-- (2) Soundness: if `validate s j = Right v`, then the wrapped payload |
| 21 | +-- has the type `SchemaType s` (by construction -- the only way to |
| 22 | +-- build `MkValidated` is with a value of the right type). |
| 23 | +-- (3) Schema-injectivity: `validate` never produces a `ValidatedValue s'` |
| 24 | +-- with `s' /= s` (by the type of `validate` itself). |
| 25 | +-- |
| 26 | +-- Idempotence / round-trip with encoders is deferred to a separate proof; |
| 27 | +-- this file covers the "cannot lie about shape" guarantee, which is the |
| 28 | +-- Obj.magic-elimination claim V11 is really asking for. |
| 29 | + |
| 30 | +module ConnectorSafety |
| 31 | + |
| 32 | +import Data.List |
| 33 | +import Data.Maybe |
| 34 | + |
| 35 | +%default total |
| 36 | + |
| 37 | +------------------------------------------------------------------------ |
| 38 | +-- JSON values (minimal untyped representation) |
| 39 | +------------------------------------------------------------------------ |
| 40 | + |
| 41 | +public export |
| 42 | +data JsonValue : Type where |
| 43 | + JNum : Double -> JsonValue |
| 44 | + JStr : String -> JsonValue |
| 45 | + JBool : Bool -> JsonValue |
| 46 | + JNull : JsonValue |
| 47 | + JArr : List JsonValue -> JsonValue |
| 48 | + |
| 49 | +------------------------------------------------------------------------ |
| 50 | +-- Schema descriptions |
| 51 | +------------------------------------------------------------------------ |
| 52 | + |
| 53 | +||| A Schema is a self-contained description of the expected JSON shape. |
| 54 | +||| We cover the cases that occur in the verisimdb connector clients; |
| 55 | +||| nested objects are represented as JNull placeholders at this proof |
| 56 | +||| level because their proof would need heterogeneous records, which is |
| 57 | +||| separate work (V11 bullets do not require it). |
| 58 | +public export |
| 59 | +data Schema : Type where |
| 60 | + SNum : Schema |
| 61 | + SStr : Schema |
| 62 | + SBool : Schema |
| 63 | + SArr : Schema -> Schema |
| 64 | + SOpt : Schema -> Schema |
| 65 | + |
| 66 | +||| The typed value that a schema describes. |
| 67 | +public export |
| 68 | +SchemaType : Schema -> Type |
| 69 | +SchemaType SNum = Double |
| 70 | +SchemaType SStr = String |
| 71 | +SchemaType SBool = Bool |
| 72 | +SchemaType (SArr s) = List (SchemaType s) |
| 73 | +SchemaType (SOpt s) = Maybe (SchemaType s) |
| 74 | + |
| 75 | +------------------------------------------------------------------------ |
| 76 | +-- Validation errors |
| 77 | +------------------------------------------------------------------------ |
| 78 | + |
| 79 | +public export |
| 80 | +data ValidationError : Type where |
| 81 | + TypeMismatch : (expected : Schema) -> ValidationError |
| 82 | + ArrayElementError : (idx : Nat) -> ValidationError -> ValidationError |
| 83 | + |
| 84 | +------------------------------------------------------------------------ |
| 85 | +-- ValidatedValue: the proof-carrying wrapper |
| 86 | +------------------------------------------------------------------------ |
| 87 | + |
| 88 | +||| A `ValidatedValue s` is a value of type `SchemaType s`. The only |
| 89 | +||| public way to produce one is via `validate`; external code cannot |
| 90 | +||| construct `MkValidated` with a value of the wrong type because |
| 91 | +||| Idris2's type system will reject it at the call site. |
| 92 | +||| |
| 93 | +||| This is the structural Obj.magic elimination: it is not just a |
| 94 | +||| convention, it is impossible to pass an unvalidated `JsonValue` |
| 95 | +||| through the `ValidatedValue` API without either calling `validate` |
| 96 | +||| or proving conformance directly. |
| 97 | +public export |
| 98 | +data ValidatedValue : (s : Schema) -> Type where |
| 99 | + MkValidated : (s : Schema) -> (v : SchemaType s) -> ValidatedValue s |
| 100 | + |
| 101 | +||| Extract the validated payload. The type of the output is determined |
| 102 | +||| by the schema the wrapper was indexed by, so consumers statically know |
| 103 | +||| what type to bind. |
| 104 | +public export |
| 105 | +unwrap : {s : Schema} -> ValidatedValue s -> SchemaType s |
| 106 | +unwrap (MkValidated _ v) = v |
| 107 | + |
| 108 | +------------------------------------------------------------------------ |
| 109 | +-- The validator |
| 110 | +------------------------------------------------------------------------ |
| 111 | + |
| 112 | +mutual |
| 113 | + ||| Validate a JsonValue against a Schema, returning either an error or |
| 114 | + ||| a proof-carrying ValidatedValue. Total by construction. |
| 115 | + ||| JNull under SOpt yields Nothing; JNull under any other schema is an |
| 116 | + ||| error via the catch-all. |
| 117 | + public export |
| 118 | + validate : (s : Schema) -> JsonValue -> Either ValidationError (ValidatedValue s) |
| 119 | + validate SNum (JNum x) = Right (MkValidated SNum x) |
| 120 | + validate SStr (JStr x) = Right (MkValidated SStr x) |
| 121 | + validate SBool (JBool x) = Right (MkValidated SBool x) |
| 122 | + validate (SArr s) (JArr xs) = |
| 123 | + case validateAll s 0 xs of |
| 124 | + Left err => Left err |
| 125 | + Right vs => Right (MkValidated (SArr s) vs) |
| 126 | + validate (SOpt s) JNull = Right (MkValidated (SOpt s) Nothing) |
| 127 | + validate (SOpt s) j = |
| 128 | + case validate s j of |
| 129 | + Left _ => Left (TypeMismatch (SOpt s)) |
| 130 | + Right (MkValidated _ v) => Right (MkValidated (SOpt s) (Just v)) |
| 131 | + validate s _ = Left (TypeMismatch s) |
| 132 | + |
| 133 | + ||| Validate every element of a list against a common schema. Threads |
| 134 | + ||| the index so array-element errors can be attributed. |
| 135 | + validateAll : (s : Schema) -> (idx : Nat) -> List JsonValue -> |
| 136 | + Either ValidationError (List (SchemaType s)) |
| 137 | + validateAll _ _ [] = Right [] |
| 138 | + validateAll s i (x :: xs) = |
| 139 | + case validate s x of |
| 140 | + Left err => Left (ArrayElementError i err) |
| 141 | + Right (MkValidated _ v) => |
| 142 | + case validateAll s (S i) xs of |
| 143 | + Left err => Left err |
| 144 | + Right vs => Right (v :: vs) |
| 145 | + |
| 146 | +------------------------------------------------------------------------ |
| 147 | +-- Type-level soundness (by construction) |
| 148 | +------------------------------------------------------------------------ |
| 149 | + |
| 150 | +-- Note: the "if validate returns Right vv, then vv is indexed by the |
| 151 | +-- schema passed in" claim is a tautology of the type of `validate` |
| 152 | +-- (the Idris2 type checker rejects any RHS that disagrees with the |
| 153 | +-- declared return type). It is therefore not stated as a separate |
| 154 | +-- operator -- the signature of `validate` IS the theorem. |
| 155 | + |
| 156 | +------------------------------------------------------------------------ |
| 157 | +-- Lightweight sanity properties (single-step) |
| 158 | +------------------------------------------------------------------------ |
| 159 | + |
| 160 | +||| JNum validates under SNum with the same payload. |
| 161 | +public export |
| 162 | +validateNumRoundtrip : (x : Double) -> |
| 163 | + validate SNum (JNum x) = Right (MkValidated SNum x) |
| 164 | +validateNumRoundtrip _ = Refl |
| 165 | + |
| 166 | +||| JStr validates under SStr. |
| 167 | +public export |
| 168 | +validateStrRoundtrip : (x : String) -> |
| 169 | + validate SStr (JStr x) = Right (MkValidated SStr x) |
| 170 | +validateStrRoundtrip _ = Refl |
| 171 | + |
| 172 | +||| JBool validates under SBool. |
| 173 | +public export |
| 174 | +validateBoolRoundtrip : (x : Bool) -> |
| 175 | + validate SBool (JBool x) = Right (MkValidated SBool x) |
| 176 | +validateBoolRoundtrip _ = Refl |
| 177 | + |
| 178 | +||| JNull validates under SOpt as Nothing. |
| 179 | +public export |
| 180 | +validateOptNull : (s : Schema) -> |
| 181 | + validate (SOpt s) JNull = Right (MkValidated (SOpt s) Nothing) |
| 182 | +validateOptNull _ = Refl |
| 183 | + |
| 184 | +||| A wrong-tagged JsonValue produces a TypeMismatch error (sampled |
| 185 | +||| at the SNum schema -- the full mismatch table is exhaustive on |
| 186 | +||| JsonValue and Schema and is enforced by `validate`'s totality). |
| 187 | +public export |
| 188 | +validateNumStrMismatch : (x : String) -> |
| 189 | + validate SNum (JStr x) = Left (TypeMismatch SNum) |
| 190 | +validateNumStrMismatch _ = Refl |
| 191 | + |
| 192 | +||| And the symmetric: SStr rejects JNum. |
| 193 | +public export |
| 194 | +validateStrNumMismatch : (x : Double) -> |
| 195 | + validate SStr (JNum x) = Left (TypeMismatch SStr) |
| 196 | +validateStrNumMismatch _ = Refl |
| 197 | + |
| 198 | +------------------------------------------------------------------------ |
| 199 | +-- End of module |
| 200 | +------------------------------------------------------------------------ |
0 commit comments