Full deserialization for the hypermedia client

src/services/hypermedia.ml

@@ -13,85 +13,156 @@ let headersForResources = [|
 type reference = { ref: string }
 
 type schemaLink = {
-  href: string;
-  rel: string;
-  submissionSchema: reference;
-  targetSchema: reference;
-  title: string;
+  anchor: string option;
+  href: string option;
+  rel: string option;
+  submissionSchema: reference option;
+  targetSchema: reference option;
+  title: string option;
 }
 
-type rootSchema = {
+type schemaObjectType = {
+  (* "type" = "object" *)
+  title: string option;
   links: schemaLink list;
-  title: string;
-}
-
-type entityPreview = {
-  id: string;
-  title: string;
-  meta: string;
-}
-
-type itemLink = {
-  anchor: string;
-  href: string;
-  rel: string;
+  properties: schemaObjectProperty list;
 }
-
-type valueSchema =
-  | Primitive of string
-  | Object of objectSchema
-  | Array of arraySchema
-and propertySchema = {
+and schemaObjectProperty = {
   name: string;
-  meta: valueSchema;
+  format: string option;
+  ptype: schemaType;
 }
-and objectSchema = {
-  links: itemLink list;
-  properties: propertySchema list;
+and schemaArrayType = {
+  (* "type" = "array" *)
+  title: string option;
+  links: schemaLink list;
+  items: schemaType
 }
-and arraySchema = {
+and schemaRoot = {
+  (* "type" = "null" *)
   title: string;
   links: schemaLink list;
-  items: valueSchema;
 }
+and schemaType =
+  | PrimitiveType of string
+  | ArrayType of schemaArrayType
+  | ObjectType of schemaObjectType
+  | RootType of schemaRoot
 
-type propertyValue =
-  | Simple of string
-  | Collection of string list;;
-
-type property = {
+type entity = {
+  properties: entityProperty list;
+}
+and entityProperty = {
   name: string;
-  value: propertyValue;
+  value: entityValue;
 }
+and entityValue =
+  | ValueNull
+  | ValuePrimitive of string
+  | ValueArray of entityValue list
+  | ValueObject of entity
+
+
+
 
-type entity = {
-  id: string;
-  properties: property list;
-}
 
 module Decode = struct
+  exception DecodeError of string
+
+  let optional_field key decode json = begin
+    let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in
+    match Js.Dict.get dict key with
+    | Some value -> Some(decode value)
+    | None -> None
+  end;;
+
   let reference json = {
-      ref = (Json.Decode.field "$ref" Json.Decode.string json)
+    ref = (Json.Decode.field "$ref" Json.Decode.string json)
   };;
 
   let schemaLink json = {
-      href = (Json.Decode.field "href" Json.Decode.string json);
-      rel = (Json.Decode.field "rel" Json.Decode.string json);
-      submissionSchema = (Json.Decode.field "submissionSchema" reference json);
-      targetSchema = (Json.Decode.field "targetSchema" reference json);
-      title = (Json.Decode.field "title" Json.Decode.string json);
-  };;
-
-  let rootSchema json = {
-    title = (Json.Decode.field "title" Json.Decode.string json);
-    links = (Json.Decode.field "links" (fun x -> Json.Decode.list schemaLink x) json)
+    anchor = (optional_field "anchor" Json.Decode.string json);
+    href = (optional_field "href" Json.Decode.string json);
+    rel = (optional_field "rel" Json.Decode.string json);
+    submissionSchema = (optional_field "submissionSchema" reference json);
+    targetSchema = (optional_field "targetSchema" reference json);
+    title = (optional_field "title" Json.Decode.string json);
   };;
 
-  let entityPreview json = {
-    id = (Json.Decode.field "id" Json.Decode.string json);
+  let rec schemaObjectType json = {
+    title = (optional_field "title" Json.Decode.string json);
+    links = (Json.Decode.field "links" (fun x -> Json.Decode.list schemaLink x) json);
+    properties = (Json.Decode.field "properties" schemaObjectProperties json);
+  }
+  and schemaObjectProperties json = begin
+    let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in
+    let keys = Js.Dict.keys source in
+    let result = Js.Array.map
+        (fun key -> schemaObjectProperty key (Js.Dict.unsafeGet source key))
+        keys in
+    Array.to_list result
+  end
+  and schemaObjectProperty name json = {
+    name = name;
+    format = (optional_field "format" Json.Decode.string json);
+    ptype = (Json.Decode.field "type" schemaType json)
+  }
+  and schemaArrayType json = {
+    title = (optional_field "title" Json.Decode.string json);
+    links = (Json.Decode.field "links" (fun x -> Json.Decode.list schemaLink x) json);
+    items = (Json.Decode.field "items" schemaType json);
+  }
+  and schemaRoot json = {
     title = (Json.Decode.field "title" Json.Decode.string json);
-    meta = (Json.Decode.field "type" Json.Decode.string json);
-  };;
-
-  let entityPreviews json = (Json.Decode.list entityPreview json);;
+    links = (Json.Decode.field "links" (fun x -> Json.Decode.list schemaLink x) json);
+  }
+  and schemaType json = begin
+    let ty = Js.typeof json in
+    if ty = "string" then
+      PrimitiveType(Obj.magic json)
+    else
+      let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in
+      match Js.Dict.get dict "type" with
+      | Some value -> schemaTypeComplex (Obj.magic value) json
+      | None -> RootType(schemaRoot json)
+  end
+  and schemaTypeComplex itype json =
+    if itype = "object" then
+      ObjectType(schemaObjectType json)
+    else if itype = "array" then
+      ArrayType(schemaArrayType json)
+    else
+      RootType(schemaRoot json)
+  ;;
+
+  let rec entity json = {
+    properties = (Json.Decode.field "properties" entityProperties json);
+  }
+  and entityProperties json = begin
+    let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in
+    let keys = Js.Dict.keys source in
+    let result = Js.Array.map
+        (fun key -> entityProperty key (Js.Dict.unsafeGet source key))
+        keys in
+    Array.to_list result
+  end
+  and entityProperty name json = {
+    name = name;
+    value = entityValue json;
+  }
+  and entityValue json = begin
+    let ty = Js.typeof json in
+    if ty = "string" then
+      ValuePrimitive(Obj.magic json)
+    else if ty = "number" then
+      ValuePrimitive(Obj.magic json)
+    else if ty = "boolean" then
+      ValuePrimitive(Obj.magic json)
+    else if (Obj.magic json) == Js.null then
+      ValueNull
+    else if Js_array.isArray json then
+      ValueArray(Array.to_list (Json.Decode.array entityValue json))
+    else
+      ValueObject(entity json)
+  end;;
 end
\ No newline at end of file