@kaiko.io/rescript-deser 2.0.0 → 2.1.0

package/Makefile

@@ -18,3 +18,7 @@ RESCRIPT_FILES := $(shell find src -type f -name '*.res')
 
 compile-rescript: $(RESCRIPT_FILES) yarn.lock
 	[ -n "$(INSIDE_EMACS)" ] && (rescript build -with-deps | sed "s@  $(shell pwd)/@@") || rescript build -with-deps
+
+
+test: compile
+	esbuild lib/js/tests/index.js --bundle --outdir=www --servedir=www --serve=4369

package/bsconfig.json

@@ -11,13 +11,10 @@
     }
   ],
   "suffix": ".js",
-  "reason": {
-    "react-jsx": 3
-  },
   "bs-dependencies": [
     "@kaiko.io/rescript-prelude"
   ],
-  "package-specs": {
-    "module": "es6"
+  "warnings": {
+    "error": "+8+11+26+27+33+56"
   }
 }

package/package.json

@@ -1,6 +1,6 @@
 {
   "name": "@kaiko.io/rescript-deser",
-  "version": "2.0.0",
+  "version": "2.1.0",
   "keywords": [
     "json",
     "deserializer",
@@ -15,6 +15,8 @@
     "@kaiko.io/rescript-prelude": "^3.0.1"
   },
   "devDependencies": {
+    "esbuild": "^0.15.7",
+    "qunit": "^2.16.0",
     "rescript": "^10.0.1"
   }
 }

package/src/JSON.res

@@ -27,6 +27,7 @@ module type Deserializer = {
   type t
   let name: string
   let fromJSON: Js.Json.t => result<t, string>
+  let checkFieldsSanity: unit => result<unit, string>
 }
 
 module Field = {
@@ -68,6 +69,8 @@ module Field = {
     // a Constraints for this in the future.
     | Morphism(t, FieldValue.t => FieldValue.t)
 
+    | Self
+
   let usingString = (f: string => 'a, value) => value->FieldValue.asString->f->FieldValue.any
   let usingInt = (f: int => 'a, value) => value->FieldValue.asInt->f->FieldValue.any
   let usingFloat = (f: float => 'a, value) => value->FieldValue.asFloat->f->FieldValue.any
@@ -104,6 +107,7 @@ module Field = {
     | Boolean => "Boolean"
     | Datetime
     | Date => "Date"
+    | Self => "Self (recursive)"
     | Collection(m) => {
         module M = unpack(m: Deserializer)
         "Collection of " ++ M.name
@@ -141,19 +145,24 @@ module Field = {
     }
   }
 
-  let rec extractValue = (values: Dict.t<Js.Json.t>, field: string, shape: t): FieldValue.t => {
+  let rec extractValue = (
+    values: Dict.t<Js.Json.t>,
+    field: string,
+    shape: t,
+    self: t,
+  ): FieldValue.t => {
     switch values->Dict.get(field) {
-    | Some(value) => value->fromUntagged(shape)
+    | Some(value) => value->fromUntagged(shape, self)
     | None =>
       switch shape {
-      | DefaultWhenInvalid(_, _) => Js.Json.null->fromUntagged(shape)
-      | Optional(_) => Js.Json.null->fromUntagged(shape)
+      | DefaultWhenInvalid(_, _) => Js.Json.null->fromUntagged(shape, self)
+      | Optional(_) => Js.Json.null->fromUntagged(shape, self)
       | OptionalWithDefault(_, default) => default
       | _ => raise(TypeError(`Missing non-optional field '${field}'`))
       }
     }
   }
-  and fromUntagged = (untagged: Js.Json.t, shape: t): FieldValue.t => {
+  and fromUntagged = (untagged: Js.Json.t, shape: t, self: t): FieldValue.t => {
     switch (shape, untagged->Js.Json.classify) {
     | (Any, _) => untagged->FieldValue.any
     | (String, Js.Json.JSONString(text)) => FieldValue.string(text)
@@ -165,7 +174,7 @@ module Field = {
         let lenbases = bases->Array.length
         let lenitems = items->Array.length
         if lenbases == lenitems {
-          let values = Array.zipBy(items, bases, fromUntagged)
+          let values = Array.zipBy(items, bases, (i, b) => fromUntagged(i, b, self))
           values->FieldValue.array
         } else {
           raise(
@@ -193,14 +202,14 @@ module Field = {
       }
 
     | (Array(shape), Js.Json.JSONArray(items)) =>
-      FieldValue.array(items->Array.map(item => item->fromUntagged(shape)))
+      FieldValue.array(items->Array.map(item => item->fromUntagged(shape, self)))
     | (Mapping(f), Js.Json.JSONObject(values)) =>
-      values->Dict.mapValues(v => v->fromUntagged(f))->FieldValue.mapping
+      values->Dict.mapValues(v => v->fromUntagged(f, self))->FieldValue.mapping
     | (Object(fields), Js.Json.JSONObject(values)) =>
       FieldValue.object(
         fields
         ->Array.map(((field, shape)) => {
-          let value = switch extractValue(values, field, shape) {
+          let value = switch extractValue(values, field, shape, self) {
           | value => value
           | exception TypeError(msg) => raise(TypeError(`Field "${field}": ${msg}`))
           }
@@ -210,10 +219,10 @@ module Field = {
       )
 
     | (OptionalWithDefault(_, value), Js.Json.JSONNull) => value
-    | (OptionalWithDefault(shape, _), _) => untagged->fromUntagged(shape)
+    | (OptionalWithDefault(shape, _), _) => untagged->fromUntagged(shape, self)
     | (Optional(_), Js.Json.JSONNull) => FieldValue.null
-    | (Optional(shape), _) => untagged->fromUntagged(shape)
-    | (Morphism(shape, f), _) => untagged->fromUntagged(shape)->f->FieldValue.any
+    | (Optional(shape), _) => untagged->fromUntagged(shape, self)
+    | (Morphism(shape, f), _) => untagged->fromUntagged(shape, self)->f->FieldValue.any
 
     | (Collection(m), Js.Json.JSONArray(items)) => {
         module M = unpack(m: Deserializer)
@@ -234,18 +243,63 @@ module Field = {
       }
 
     | (DefaultWhenInvalid(t, default), _) =>
-      switch untagged->fromUntagged(t) {
+      switch untagged->fromUntagged(t, self) {
       | res => res
       | exception TypeError(msg) => {
           Js.Console.warn2("Detected and ignore (with default): ", msg)
           default
         }
       }
-
+    | (Self, _) => untagged->fromUntagged(self, self)
     | (expected, actual) =>
       raise(TypeError(`Expected ${expected->toString}, but got ${actual->_taggedToString} instead`))
     }
   }
+
+  let rec checkFieldsSanity = (name: string, fields: t, optional: bool): result<unit, string> =>
+    switch (fields, optional) {
+    | (Self, false) => Error(`${name}: Trivial infinite recursion 'let fields = Self'`)
+    | (Self, true) => Ok()
+
+    | (Any, _) => Ok()
+    | (String, _) | (Float, _) | (Int, _) => Ok()
+    | (Boolean, _) | (Date, _) | (Datetime, _) => Ok()
+    | (Morphism(_, _), _) => Ok()
+
+    | (Collection(mod), _)
+    | (Deserializer(mod), _) => {
+        module M = unpack(mod: Deserializer)
+        switch M.checkFieldsSanity() {
+        | Ok() => Ok()
+        | Error(msg) => Error(`${name}/ ${msg}`)
+        }
+      }
+
+    | (DefaultWhenInvalid(fields, _), _)
+    | (OptionalWithDefault(fields, _), _)
+    | (Optional(fields), _) =>
+      checkFieldsSanity(name, fields, true)
+
+    | (Object(fields), optional) =>
+      fields
+      ->Array.map(((fieldName, field), ()) =>
+        checkFieldsSanity(`${name}::${fieldName}`, field, optional)
+      )
+      ->ManyResults.bailU
+      ->ManyResults.map(_ => ())
+
+    /// Mappings and arrays can be empty, so their payloads are
+    /// automatically optional.
+    | (Mapping(field), _) | (Array(field), _) => checkFieldsSanity(name, field, true)
+
+    | (Tuple(fields), optional) =>
+      fields
+      ->Array.mapWithIndex((index, field, ()) =>
+        checkFieldsSanity(`${name}[${index->Int.toString}]`, field, optional)
+      )
+      ->ManyResults.bailU
+      ->ManyResults.map(_ => ())
+    }
 }
 
 module type Serializable = {
@@ -261,9 +315,20 @@ module MakeDeserializer = (S: Serializable): (Deserializer with type t = S.t) =>
 
   %%private(external _toNativeType: FieldValue.t => t = "%identity")
 
-  /// Parse a `Js.Json.t` into `result<t, string>`
+  @doc("Checks for trivial infinite-recursion in the fields of the module.
+
+  Notice this algorithm is just an heuristic, and it might happen that are
+  cases of infinite-recursion not detected and cases where detection is a
+  false positive.
+
+  You should use this only while debugging/developing to verify your data.
+
+  ")
+  let checkFieldsSanity = () => Field.checkFieldsSanity(name, fields, false)
+
+  @doc("Parse a `Js.Json.t` into `result<t, string>`")
   let fromJSON = (json: Js.Json.t): result<t, _> => {
-    switch json->Field.fromUntagged(fields) {
+    switch json->Field.fromUntagged(fields, fields) {
     | res => Ok(res->_toNativeType)
     | exception TypeError(e) => Error(e)
     }

package/tests/QUnit.res

@@ -0,0 +1,72 @@
+type description = string
+type message = string
+
+type result<'a> = {
+  result: bool,
+  actual: 'a,
+  expected: 'a,
+  message: string,
+}
+
+type assertion
+type block = assertion => unit
+type matcher<'a> = 'a => bool
+
+// Library stuff
+
+@scope("QUnit") external start: unit => unit = "start"
+@scope("QUnit") external done: (unit => unit) => unit = "done"
+
+@send external expect: (assertion, int) => unit = "expect"
+@send external pushResult: (assertion, result<'a>) => unit = "notOk"
+@send external step: (assertion, description) => unit = "step"
+@send external verifySteps: (assertion, array<description>) => unit = "verifySteps"
+
+// Values
+
+@send external equal: (assertion, 'a, 'a, description) => unit = "equal"
+@send external notEqual: (assertion, 'a, 'a, description) => unit = "notEqual"
+
+@send external isFalse: (assertion, 'a, description) => unit = "false"
+@send external isTrue: (assertion, 'a, description) => unit = "true"
+
+@send external deepEqual: (assertion, 'a, 'a, description) => unit = "deepEqual"
+@send external notDeepEqual: (assertion, 'a, 'a, description) => unit = "notDeepEqual"
+
+@send external strictEqual: (assertion, 'a, 'a, description) => unit = "strictEqual"
+@send external notStrictEqual: (assertion, 'a, 'a, description) => unit = "notStrictEqual"
+
+@send external ok: (assertion, 'a, 'a) => unit = "ok"
+@send external notOk: (assertion, 'a, 'a) => unit = "notOk"
+
+@send external propEqual: (assertion, 'a, 'a) => unit = "propEqual"
+@send external notPropEqual: (assertion, 'a, 'a) => unit = "notPropEqual"
+
+// Promises
+
+type done = unit => unit
+
+@send external async: assertion => done = "async"
+@send external asyncMany: (assertion, int) => done = "async"
+@send external rejects: (assertion, Js.Promise.t<'a>, message) => unit = "rejects"
+@send external rejectsM: (assertion, Js.Promise.t<'a>, message) => unit = "rejects"
+@send
+external rejectMatches: (assertion, Js.Promise.t<'a>, matcher<'a>, message) => unit = "rejects"
+@send
+external rejectMatchesM: (assertion, Js.Promise.t<'a>, matcher<'a>, message) => unit = "rejects"
+@send external timeout: (assertion, int) => unit = "timeout"
+
+// Exceptions
+
+@send external throws: (assertion, block, message) => unit = "throws"
+@send
+external throwMatches: (assertion, block, matcher<'a>, message) => unit = "throws"
+
+type hooks
+@send external before: (hooks, block) => unit = "before"
+@send external beforeEach: (hooks, block) => unit = "beforeEach"
+@send external afterEach: (hooks, block) => unit = "afterEach"
+@send external after: (hooks, block) => unit = "after"
+
+@module("qunit") @val external module_: (description, hooks => unit) => unit = "module"
+@module("qunit") @val external test: (description, block) => unit = "test"

package/tests/index.res

@@ -0,0 +1,192 @@
+open JSON
+open QUnit
+open Prelude
+
+%%private(external cast: 'a => 'b = "%identity")
+
+module Appointment = {
+  type t = {
+    note: string,
+    date: Js.Date.t,
+    extra: option<string>,
+  }
+  module Deserializer = MakeDeserializer({
+    type t = t
+    open JSON.Field
+
+    let fields = Object([("note", String), ("date", Date), ("extra", Optional(String))])
+  })
+}
+
+module_("Basic deserializer", _ => {
+  let valid: array<(_, Appointment.t)> = [
+    (
+      %raw(`{"note": "Bicentennial doctor's appointment", "date": "2100-01-01"}`),
+      {
+        note: "Bicentennial doctor's appointment",
+        date: Js.Date.fromString("2100-01-01"),
+        extra: None,
+      },
+    ),
+    (
+      %raw(`{
+      "note": "Bicentennial doctor's appointment",
+      "date": "2100-01-01",
+      "extra": "Don't take your stop-aging pills the night before the appointment",
+    }`),
+      {
+        note: "Bicentennial doctor's appointment",
+        date: Js.Date.fromString("2100-01-01"),
+        extra: Some("Don't take your stop-aging pills the night before the appointment"),
+      },
+    ),
+  ]
+
+  test("Correctly deserializes data", qunit => {
+    qunit->expect(valid->Array.length)
+    valid->Array.forEach(
+      ((data, expected)) => {
+        Js.Console.log2("Running sample", data)
+        switch Appointment.Deserializer.fromJSON(data) {
+        | Ok(result) => qunit->deepEqual(result, expected, "result == expected")
+        | Error(msg) => Js.Console.error(msg)
+        }
+      },
+    )
+  })
+
+  let invalid = [
+    (
+      "Missing non-optional field",
+      %raw(`{"extra": "Bicentennial doctor's appointment", "date": "2100-01-01"}`),
+    ),
+  ]
+
+  test("Correctly catches invalid data", qunit => {
+    qunit->expect(invalid->Array.length)
+    invalid->Array.forEach(
+      ((message, data)) => {
+        Js.Console.log3("Running sample", message, data)
+        switch Appointment.Deserializer.fromJSON(data) {
+        | Ok(result) => Js.Console.error2("Invalid being accepted: ", result)
+        | Error(msg) => {
+            Js.Console.log2("Correctly detected:", msg)
+            qunit->ok(true, true)
+          }
+        }
+      },
+    )
+  })
+})
+
+module_("Recursive deserializer", _ => {
+  module TrivialTree = {
+    type rec t<'a> = {
+      data: 'a,
+      children: array<t<'a>>,
+    }
+
+    module DeserializerImpl = MakeDeserializer({
+      type payload
+      type rec t = {
+        data: payload,
+        children: array<t>,
+      }
+      open JSON.Field
+
+      let fields = Object([("data", Any), ("children", Array(Self))])
+    })
+
+    module Deserializer = {
+      include DeserializerImpl
+
+      let fromJSON = data => data->DeserializerImpl.fromJSON->Result.map(cast)
+    }
+  }
+
+  let valid: array<(_, TrivialTree.t<string>)> = [
+    (
+      %raw(`{"data": "A", "children": [{"data": "A1", "children": []}, {"data": "B", "children": [{"data": "C", "children": []}, {"data": "D", "children": []}]}]}`),
+      {
+        data: "A",
+        children: [
+          {data: "A1", children: []},
+          {data: "B", children: [{data: "C", children: []}, {data: "D", children: []}]},
+        ],
+      },
+    ),
+  ]
+
+  test("Trivial recursion detection: Ok", qunit => {
+    qunit->expect(1)
+    qunit->deepEqual(TrivialTree.Deserializer.checkFieldsSanity(), Ok(), "Ok")
+  })
+
+  test("Infinite list", qunit => {
+    module InfiniteList = MakeDeserializer({
+      open JSON.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Self)])
+    })
+
+    qunit->expect(1)
+    qunit->deepEqual(InfiniteList.checkFieldsSanity()->Result.isError, true, "Ok")
+  })
+
+  test("Finite list", qunit => {
+    module List = MakeDeserializer({
+      open JSON.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Optional(Self))])
+    })
+
+    qunit->expect(1)
+    qunit->deepEqual(List.checkFieldsSanity(), Ok(), "Ok")
+  })
+
+  test("Correctly deserializes recursive data", qunit => {
+    qunit->expect(valid->Array.length)
+    valid->Array.forEach(
+      ((data, expected)) => {
+        Js.Console.log2("Running sample", data)
+        switch TrivialTree.Deserializer.fromJSON(data) {
+        | Ok(result) => qunit->deepEqual(result, expected, "result == expected")
+        | Error(msg) => Js.Console.error(msg)
+        }
+      },
+    )
+  })
+
+  test("Recursion in sub-deserializer", qunit => {
+    module List = MakeDeserializer({
+      open JSON.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Optional(Self))])
+    })
+
+    module Ledger = MakeDeserializer({
+      open JSON.Field
+
+      type t
+      let fields = Object([("records", Deserializer(module(List))), ("next", Optional(Self))])
+    })
+
+    let data = %raw(`
+       {"records": {"head": "A", "tail": {"head": "B"}},
+        "next": {"records": {"head": "A", "tail": {"head": "B"}}}}
+    `)
+    let expected = {
+      "records": {"head": "A", "tail": {"head": "B", "tail": None}},
+      "next": {
+        "records": {"head": "A", "tail": {"head": "B", "tail": None}},
+        "next": None,
+      },
+    }
+
+    qunit->expect(1)
+    qunit->deepEqual(data->Ledger.fromJSON->cast, Ok(expected), "nice ledger")
+  })
+})

package/www/index.html

@@ -0,0 +1,20 @@
+<!DOCTYPE html>
+<html lang="en">
+
+<head>
+  <meta charset="UTF-8">
+  <meta http-equiv="X-UA-Compatible" content="IE=edge">
+  <meta name="viewport" content="width=device-width, initial-scale=1.0">
+  <link rel="shortcut icon" href="#" />
+  <link rel="stylesheet" href="https://code.jquery.com/qunit/qunit-2.16.0.css" type="text/css" media="screen" />
+  <title>Document</title>
+</head>
+
+<script type="module" defer src="index.js"></script>
+
+<body>
+  <div id="qunit"></div>
+  <div id="qunit-fixture"></div>
+</body>
+
+</html>

package/tests/compile.res

@@ -1,22 +0,0 @@
-open JSON
-
-module Test = {
-  type appointment = {
-    note: string,
-    date: Js.Date.t,
-  }
-  module Appointment = MakeDeserializer({
-    type t = appointment
-    open JSON.Field
-
-    let fields = Object([("note", String), ("date", Date)])
-  })
-
-  type foo = array<appointment>
-  module Foo = MakeDeserializer({
-    type t = foo
-    open JSON.Field
-
-    let fields = DefaultWhenInvalid(Array(Deserializer(module(Appointment))), []->FieldValue.array)
-  })
-}