package octez-libs

  1. Overview
  2. Docs
package octez-libs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file core_maker.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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let json_pp id description encoding ppf data =
  Format.pp_print_string ppf @@ Data_encoding.Json.to_string
  @@
  let pp_encoding =
    Data_encoding.(
      obj3 (req "id" string) (req "description" string) (req "data" encoding))
  in
  Data_encoding.Json.construct pp_encoding (id, description, data)

(* This is a global variable because it is shared amongst all the error monads (the
   shell's and the protocols'). See below for use. *)
let set_error_encoding_cache_dirty = ref (fun () -> ())

module Make (Prefix : Sig.PREFIX) (Error_category : Sig.ERROR_CATEGORY) : sig
  type error = ..

  type error_category = Error_category.t

  include
    Sig.CORE with type error := error and type error_category := error_category

  include Sig.WITH_WRAPPED with type error := error
end = struct
  type error_category = Error_category.t

  include (Error_category : Sig.ERROR_CATEGORY with type t := error_category)

  type error = ..

  module type Wrapped_error_monad = sig
    type unwrapped = ..

    include Sig.CORE with type error := unwrapped

    val unwrap : error -> unwrapped option

    val wrap : unwrapped -> error
  end

  type full_error_category =
    | Main of Error_category.t
    | Wrapped of (module Wrapped_error_monad)

  type encoding_case = error Data_encoding.case

  (* the toplevel store for error kinds *)
  type error_kind =
    | Error_kind : {
        id : string;
        title : string;
        description : string;
        from_error : error -> 'err option;
        category : full_error_category;
        encoding_case : encoding_case;
        pp : Format.formatter -> 'err -> unit;
      }
        -> error_kind

  type error_info = {
    category : error_category;
    id : string;
    title : string;
    description : string;
    schema : Data_encoding.json_schema;
  }

  let error_kinds : error_kind list ref = ref []

  let get_registered_errors () : error_info list =
    List.flatten
      (List.map
         (function
           | Error_kind {id = ""; _} -> []
           | Error_kind
               {
                 id;
                 title;
                 description;
                 category = Main category;
                 encoding_case;
                 _;
               } ->
               [
                 {
                   id;
                   title;
                   description;
                   category;
                   schema =
                     Data_encoding.Json.schema
                       (Data_encoding.union [encoding_case]);
                 };
               ]
           | Error_kind {category = Wrapped (module WEM); _} ->
               List.map
                 (fun {WEM.id; title; description; category = _; schema} ->
                   {
                     id;
                     title;
                     description;
                     category = (* Can we do better ? *) default_category;
                     schema;
                   })
                 (WEM.get_registered_errors ()))
         !error_kinds)

  let error_encoding_cache = ref None

  let () =
    let set_older_caches_dirty = !set_error_encoding_cache_dirty in
    set_error_encoding_cache_dirty :=
      fun () ->
        set_older_caches_dirty () ;
        error_encoding_cache := None

  let pp_info ppf {category; id; title; description; schema} =
    Format.fprintf
      ppf
      "@[<v 2>category : %s\n\
       id : %s\n\
       title : %s\n\
       description : %s\n\
       schema : %a@]"
      (Error_category.string_of_category category)
      id
      title
      description
      (Json_repr.pp (module Json_repr.Ezjsonm))
      (Json_schema.to_json schema)

  (* Catch all error when 'serializing' an error. *)
  type error += Unclassified of string

  let () =
    let id = "" in
    let category = Main Error_category.default_category in
    let to_error msg = Unclassified msg in
    let from_error = function
      | Unclassified msg -> Some msg
      | error ->
          let msg = Obj.Extension_constructor.(name @@ of_val error) in
          Some ("Unclassified error: " ^ msg ^ ". Was the error registered?")
    in
    let title = "Generic error" in
    let description = "An unclassified error" in
    let encoding_case =
      let open Data_encoding in
      case
        Json_only
        ~title:"Generic error"
        (def "generic_error" ~title ~description
        @@ conv (fun x -> ((), x)) (fun ((), x) -> x)
        @@ obj2 (req "kind" (constant "generic")) (req "error" string))
        from_error
        to_error
    in
    let pp ppf s = Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s in
    error_kinds :=
      Error_kind
        {id; title; description; from_error; category; encoding_case; pp}
      :: !error_kinds

  (* Catch all error when 'deserializing' an error. *)
  type error += Unregistered_error of Data_encoding.json

  let () =
    let id = "" in
    let category = Main Error_category.default_category in
    let to_error msg = Unregistered_error msg in
    let from_error = function
      | Unregistered_error json -> Some json
      | _ -> None
    in
    let encoding_case =
      let open Data_encoding in
      case Json_only ~title:"Unregistered error" json from_error to_error
    in
    let pp ppf json =
      Format.fprintf
        ppf
        "@[<v 2>Unregistered error:@ %a@]"
        Data_encoding.Json.pp
        json
    in
    error_kinds :=
      Error_kind
        {
          id;
          title = "";
          description = "";
          from_error;
          category;
          encoding_case;
          pp;
        }
      :: !error_kinds

  let prepare_registration new_id =
    !set_error_encoding_cache_dirty () ;
    let name = Prefix.id ^ new_id in
    if List.exists (fun (Error_kind {id; _}) -> name = id) !error_kinds then
      invalid_arg
        (Printf.sprintf "register_error_kind: duplicate error name: %s" name) ;
    name

  let register_wrapped_error_kind (module WEM : Wrapped_error_monad) ~id ~title
      ~description =
    let name = prepare_registration id in
    let encoding_case =
      let unwrap err =
        match WEM.unwrap err with
        | Some (WEM.Unclassified _) -> None
        | Some (WEM.Unregistered_error _) -> None
        | res -> res
      in
      let wrap err =
        match err with
        | WEM.Unclassified _ -> failwith "ignore wrapped error when serializing"
        | WEM.Unregistered_error _ ->
            failwith "ignore wrapped error when deserializing"
        | res -> WEM.wrap res
      in
      case Json_only ~title:name WEM.error_encoding unwrap wrap
    in
    error_kinds :=
      Error_kind
        {
          id = name;
          category = Wrapped (module WEM);
          title;
          description;
          from_error = WEM.unwrap;
          encoding_case;
          pp = WEM.pp;
        }
      :: !error_kinds

  let add_kind_and_id ~category ~name ~title ~description encoding from_error
      to_error =
    if not (Data_encoding.is_obj encoding) then
      invalid_arg
        (Printf.sprintf
           "Specified encoding for \"%s%s\" is not an object, but error \
            encodings must be objects."
           Prefix.id
           name) ;
    let with_id_and_kind_encoding =
      merge_objs
        (obj2
           (req "kind" (constant (Error_category.string_of_category category)))
           (req "id" (constant name)))
        encoding
    in
    case
      Json_only
      ~title
      ~description
      (conv
         (fun x -> (((), ()), x))
         (fun (((), ()), x) -> x)
         with_id_and_kind_encoding)
      from_error
      to_error

  let register_error_kind category ~id ~title ~description ?pp encoding
      from_error to_error =
    let name = prepare_registration id in
    let encoding_case =
      add_kind_and_id
        ~category
        ~name
        ~title
        ~description
        encoding
        from_error
        to_error
    in
    error_kinds :=
      Error_kind
        {
          id = name;
          category = Main category;
          title;
          description;
          from_error;
          encoding_case;
          pp = Option.value ~default:(json_pp name description encoding) pp;
        }
      :: !error_kinds

  let error_encoding () =
    match !error_encoding_cache with
    | None ->
        let encoding =
          let cases =
            List.map
              (fun (Error_kind {encoding_case; _}) -> encoding_case)
              !error_kinds
          in
          let union_encoding = Data_encoding.union cases in
          let open Data_encoding in
          splitted
            ~json:union_encoding
            ~binary:
              (conv
                 (Json.construct union_encoding)
                 (Json.destruct union_encoding)
                 json)
        in
        error_encoding_cache := Some encoding ;
        encoding
    | Some encoding -> encoding

  let error_encoding = Data_encoding.delayed error_encoding

  let () =
    (* HACK
       There is an issue with the interaction of
       (a) error-monad's delayed error-encoding
       (b) data-encoding's cached json-encoding conversion

       More specifically.

       On the error-monad side: The [error_encoding] is a
       [Data_encoding.delayed] encoding. The delaying allows to dynamically find
       the list of registered errors and generate the encoding based on that.
       (There is a cache mechanism to avoid recomputing it if no new errors have
       been registered. That is the original purpose of the
       [set_error_encoding_cache_dirty].)

       On the data-encoding side: Each encoding is actually a record with the
       [data-encoding] AST in one field and the [json-data-encoding] in the
       other. The fields are used for serialisation/deserialisation in,
       respectively, binary and in JSON. The JSON field is computed on-demand
       (e.g., when `Data_encoding.Json.construct` is called). To avoid
       expensive recomputations, the result of this conversion is stored in the
       [json-data-encoding].

       The end result is that, whilst the cache-invalidation mechanism can mark
       the encoding {e inside} the [delayed] node dirty so it is recomputed on
       each use, it cannot mark the json-encoding cache of the [delayed] node
       itself dirty.

       As a result, the json encoding for errors is set in stone as soon as it
       is used, even if new errors are registered.

       To circumvent this, we use the hack below: We explicitly tamper with the
       internal representation of the encoding. More specifically, we reset the
       json-encoding field of [error_encoding] to [None] to force it being
       recomputed. *)
    let set_older_caches_dirty = !set_error_encoding_cache_dirty in
    set_error_encoding_cache_dirty :=
      fun () ->
        set_older_caches_dirty () ;
        error_encoding.json_encoding <- None

  let json_of_error error = Data_encoding.Json.construct error_encoding error

  let error_of_json json = Data_encoding.Json.destruct error_encoding json

  let find_info_of_error error =
    List.find
      (fun (Error_kind {from_error; _}) -> Option.is_some (from_error error))
      !error_kinds
    |> function
    | Error_kind {id; title; description; category; encoding_case; _} -> (
        match category with
        | Wrapped (module WEM) -> (
            match WEM.unwrap error with
            | None -> failwith "incorrectly registered wrapped error"
            | Some error ->
                let {WEM.id; title; description; category = _; schema} =
                  WEM.find_info_of_error error
                in
                {
                  id;
                  title;
                  description;
                  category = (* Can we do better ? *) default_category;
                  schema;
                })
        | Main category ->
            {
              id;
              title;
              description;
              category;
              schema =
                Data_encoding.Json.schema (Data_encoding.union [encoding_case]);
            })

  let classify_error error =
    let rec find e = function
      | [] -> Error_classification.default
      | Error_kind {from_error; category; _} :: rest -> (
          match from_error e with
          | Some _ -> (
              match category with
              | Main error_category -> Error_category.classify error_category
              | Wrapped (module WEM) -> (
                  match WEM.unwrap e with
                  | Some e -> WEM.classify_error e
                  | None -> find e rest))
          | None -> find e rest)
    in
    find error !error_kinds

  let pp ppf error =
    let rec find = function
      | [] ->
          Format.fprintf
            ppf
            "An unspecified error happened, the component that threw it did \
             not provide a specific trace. This should be reported."
      | Error_kind {from_error; pp; _} :: errors -> (
          match from_error error with None -> find errors | Some x -> pp ppf x)
    in
    find !error_kinds
end
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