Source file `registration.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
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type id = string

type t =
  | Record : {
      encoding : 'a Encoding.t;
      description : string option;
      pp : (Format.formatter -> 'a -> unit) option;
    }
      -> t

type introspectable = Any : _ Encoding.t -> introspectable

module EncodingTable = Map.Make (String)

let table = ref EncodingTable.empty

let description (Record {description; _}) = description

let slice (Record {encoding; _}) bytes =
  Binary_slicer.slice_string encoding bytes

let slice_all bytes =
  EncodingTable.fold
    (fun enc_id (Record {encoding; _}) sliced ->
      try
        match Binary_reader.of_string encoding bytes with
        | Ok _ ->
            let slice = Binary_slicer.slice_string_exn encoding bytes in
            (enc_id, slice) :: sliced
        | Error _ -> sliced
      with
      | (Out_of_memory | Stack_overflow) as e -> raise e
      | _ -> sliced)
    !table
    []

let json_schema (Record {encoding; _}) =
  let json_schema = Json.schema encoding in
  json_schema

let binary_schema (Record {encoding; _}) =
  let binary_schema = Binary_description.describe encoding in
  binary_schema

let json_pretty_printer (Record {encoding; pp; _}) fmt json =
  match pp with
  | Some pp ->
      let json = Json.destruct encoding json in
      Format.fprintf fmt "%a" pp json
  | None -> Format.fprintf fmt "%a" Json.pp json

let binary_pretty_printer (Record {encoding; pp; _}) fmt bytes =
  let data = Binary_reader.of_bytes_exn encoding bytes in
  match pp with
  | Some pp -> Format.fprintf fmt "%a" pp data
  | None ->
      let json = Json.construct encoding data in
      Format.fprintf fmt "%a" Json.pp json

let rec lookup_id_descr : 'a. 'a Encoding.t -> _ =
  fun (type a) ({encoding; _} : a Encoding.t) ->
   match encoding with
   | Splitted {encoding; _}
   | Dynamic_size {encoding; _}
   | Check_size {encoding; _} ->
       lookup_id_descr encoding
   | Describe {id; description; _} -> Some (id, description)
   | Null | Empty | Ignore | Constant _ | Bool | Int8 | Uint8 | Int16 | Uint16
   | Int31 | Int32 | Int64 | N | Z | RangedInt _ | RangedFloat _ | Float
   | Bytes _ | String _
   | Padded (_, _)
   | String_enum (_, _)
   | Array _ | List _ | Obj _ | Objs _ | Tup _ | Tups _ | Union _ | Mu _
   | Conv _ | Delayed _ ->
       None

let register ?pp encoding =
  match lookup_id_descr encoding with
  | None ->
      invalid_arg "Data_encoding.Registration.register: non def(in)ed encoding"
  | Some (id, description) ->
      table :=
        EncodingTable.update
          id
          (function
            | None ->
                let record = Record {encoding; description; pp} in
                Some record
            | Some _ ->
                Format.kasprintf
                  invalid_arg
                  "Encoding %s previously registered"
                  id)
          !table

let find id = EncodingTable.find_opt id !table

let find_introspectable id =
  match EncodingTable.find_opt id !table with
  | Some (Record {encoding; _}) -> Some (Any encoding)
  | None -> None

let list () = EncodingTable.bindings !table

let iter : id:string -> (introspectable -> unit) -> unit =
 fun ~id f ->
  match find_introspectable id with
  | Some introspectable -> f introspectable
  | None -> ()

let bytes_of_json (Record {encoding; _}) json =
  let data = Json.destruct encoding json in
  Binary_writer.to_bytes_opt encoding data

let json_of_bytes (Record {encoding; _}) bytes =
  match Binary_reader.of_bytes_opt encoding bytes with
  | Some v -> Some (Json.construct encoding v)
  | None -> None