package goblint

  1. Overview
  2. Docs
package goblint
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file jsonSchema.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
(** JSON schema validation. *)

module JS = Json_schema.Make (Json_repr.Yojson)
module JE = Json_encoding.Make (Json_repr.Yojson)
module JQ = Json_query.Make (Json_repr.Yojson)

(* copied & modified from json_encoding.ml *)
let unexpected kind expected =
  let kind =
    match Json_repr.from_yojson kind with
    | `O [] -> "empty object"
    | `A [] -> "empty array"
    | `O _ -> "object"
    | `A _ -> "array"
    | `Null -> "null"
    | `String _ -> "string"
    | `Float _ -> "number"
    | `Bool _ -> "boolean"
  in
  Json_encoding.Cannot_destruct ([], Json_encoding.Unexpected (kind, expected))

let schema_to_yojson schema = JS.to_json schema
let schema_of_yojson json = JS.of_json json

let erase: type t. t Json_encoding.encoding -> unit Json_encoding.encoding = fun encoding -> Json_encoding.conv (fun _ -> failwith "erase construct") (fun _ -> ()) encoding

let rec encoding_of_schema_element (top: unit Json_encoding.encoding) (schema_element: Json_schema.element): unit Json_encoding.encoding =
  let open Json_encoding in
  match schema_element.kind with
  | Any -> unit
  | String string_specs ->
    begin match schema_element.enum with
      | None ->
        erase string
      | Some enum ->
        enum
        |> List.map (fun value ->
            match Json_repr.any_to_repr (module Json_repr.Yojson) value with
            | `String value -> (value, ())
            | _ -> failwith "encoding_of_schema_element: string_enum"
          )
        |> string_enum
    end
  | Boolean -> erase bool
  | Integer numeric_specs -> erase int
  | Monomorphic_array (el, array_specs) ->
    erase @@ array (encoding_of_schema_element top el)
  | Id_ref "" ->
    top
  | Object object_specs ->
    let properties_encoding = List.fold_left (fun acc (name, element, required, _) ->
        let field =
          if required then
            req name (encoding_of_schema_element top element)
          else
            dft name (encoding_of_schema_element top element) ()
        in
        erase @@ merge_objs acc (obj1 field)
      ) empty object_specs.properties
    in
    begin match object_specs.additional_properties with
      | Some additional_properties ->
        let additional_encoding = encoding_of_schema_element top additional_properties in
        JE.custom (fun _ -> failwith "erase construct") (function
            | `Assoc fields ->
              let is_properties_field (name, _) = List.exists (fun (name', _, _, _) -> name = name') object_specs.properties in
              let (properties_fields, additional_fields) = List.partition is_properties_field fields in
              JE.destruct properties_encoding (`Assoc properties_fields);
              List.iter (fun (name, value) ->
                  try
                    JE.destruct additional_encoding value
                  with Cannot_destruct (path, err) ->
                    raise (Cannot_destruct (`Field name :: path, err))
                ) additional_fields
            | j ->
              raise (unexpected j "object")
          ) ~schema:(Json_schema.create schema_element)
      | None ->
        properties_encoding
    end
  | _ -> failwith (Format.asprintf "encoding_of_schema_element: %a" Json_schema.pp (Json_schema.create schema_element))

let encoding_of_schema (schema: Json_schema.schema): unit Json_encoding.encoding =
  let root = Json_schema.root schema in
  Json_encoding.mu "" (fun top -> encoding_of_schema_element top root)

open Json_schema

let rec element_defaults ?additional_field (element: element): Yojson.Safe.t =
  match element.default with
  | Some default ->
    Json_repr.any_to_repr (module Json_repr.Yojson) default
  | None ->
    begin match element.kind with
      | Object object_specs ->
        let additional = match additional_field, object_specs.additional_properties with
          | Some additional_field, Some additional_properties ->
            (* create additional field with the additionalProperties default value for lookup in GobConfig *)
            [(additional_field, element_defaults ~additional_field additional_properties)]
          | _, _ ->
            []
        in
        `Assoc (additional @ List.map (fun (name, field_element, _, _) ->
            (name, element_defaults ?additional_field field_element)
          ) object_specs.properties)
      | _ ->
        Logs.Format.error "%a" Json_schema.pp (create element);
        failwith "element_defaults"
    end

let schema_defaults ?additional_field (schema: schema): Yojson.Safe.t =
  element_defaults ?additional_field (root schema)

let create_schema element =
  create element

let rec element_require_all (element: element): element =
  let kind' = match element.kind with
    | String _
    | Boolean
    | Id_ref _
    | Integer _
    | Number _ -> element.kind
    | Monomorphic_array (element_element, array_specs) ->
      let array_specs' =
        { array_specs with
          additional_items = Option.map element_require_all array_specs.additional_items;
        }
      in
      Monomorphic_array (element_require_all element_element, array_specs')
    | Object object_specs ->
      let properties' = List.map (fun (name, field_element, required, unknown) ->
          (name, element_require_all field_element, true, unknown) (* change required to true *)
        ) object_specs.properties
      in
      Object { object_specs with properties = properties' }
    | _ ->
      Logs.Format.error "%a" Json_schema.pp (create element);
      failwith "element_require_all"
  in
  { element with kind = kind' }

let schema_require_all (schema: schema): schema =
  create_schema (element_require_all (root schema))


module type Schema =
sig
  val schema: schema
end

module Validator (Schema: Schema) =
struct
  let schema_encoding = encoding_of_schema Schema.schema

  (** @raise Json_encoding.Cannot_destruct if invalid. *)
  let validate_exn json = JE.destruct schema_encoding json

  (* TODO: bool-returning validate? *)
end


let () = Printexc.register_printer (function
    | Json_encoding.Unexpected _
    | Json_encoding.No_case_matched _
    | Json_encoding.Bad_array_size _
    | Json_encoding.Missing_field _
    | Json_encoding.Unexpected_field _
    | Json_encoding.Bad_schema _
    | Json_encoding.Cannot_destruct _ as exn ->
      let msg = Format.asprintf "Json_encoding: %a" (Json_encoding.print_error ?print_unknown:None) exn in
      Some msg
    | Json_schema.Cannot_parse _
    | Json_schema.Dangling_reference _
    | Json_schema.Bad_reference _
    | Json_schema.Unexpected _
    | Json_schema.Duplicate_definition _ as exn ->
      let msg = Format.asprintf "Json_schema: %a" (Json_encoding.print_error ?print_unknown:None) exn in
      Some msg
    | Json_query.Illegal_pointer_notation _
    | Json_query.Unsupported_path_item _
    | Json_query.Cannot_merge _ as exn ->
      let msg = Format.asprintf "Json_query: %a" (Json_encoding.print_error ?print_unknown:None) exn in
      Some msg
    | _ -> None (* for other exceptions *)
  )
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct