package octez-libs

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

Source file media_type.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
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2021 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto_cohttp.Media_type.Make (Tezos_rpc.Encoding)

(* emits chunks of size approx chunk_size_hint but occasionally a bit bigger *)
let chunk_size_hint = 4096

(* This function is an ad-hoc optimization that should, in a near
   future, be addressed in [Data_encoding]. For the sake of practicity
   and performances, this function is temporarly defined here. *)
let json_to_string json =
  let repr_to_string json =
    let escape_and_add_string b s =
      Buffer.add_char b '"' ;
      for i = 0 to String.length s - 1 do
        match s.[i] with
        | '\"' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b '"'
        | '\n' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b 'n'
        | '\r' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b 'r'
        | '\b' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b 'b'
        | '\t' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b 't'
        | '\\' ->
            Buffer.add_char b '\\' ;
            Buffer.add_char b '\\'
        | '\x00' .. '\x1F' as c -> Printf.bprintf b "\\u%04x" (Char.code c)
        | c -> Buffer.add_char b c
      done ;
      Buffer.add_char b '"'
    in
    let rec iter_sep b f = function
      | [] -> ()
      | [x] -> f x
      | x :: t ->
          f x ;
          Buffer.add_char b ',' ;
          (iter_sep [@tailcall]) b f t
    in
    let rec write b = function
      | `Bool true -> Buffer.add_string b "true"
      | `Bool false -> Buffer.add_string b "false"
      | `Null -> Buffer.add_string b "null"
      | `String s -> escape_and_add_string b s
      | `Float f ->
          let fract, intr = modf f in
          if fract = 0.0 then Printf.bprintf b "%.0f" intr
          else Printf.bprintf b "%g" f
      | `O ol ->
          Buffer.add_char b '{' ;
          iter_sep
            b
            (fun (s, v) ->
              escape_and_add_string b s ;
              Buffer.add_char b ':' ;
              write b v)
            ol ;
          Buffer.add_char b '}'
      | `A l ->
          Buffer.add_char b '[' ;
          iter_sep b (fun v -> write b v) l ;
          Buffer.add_char b ']'
    in
    let b = Buffer.create 4096 in
    write b json ;
    Buffer.add_char b '\n' ;
    Buffer.contents b
  in
  repr_to_string json

let json =
  {
    name = Cohttp.Accept.MediaType ("application", "json");
    q = Some 1000;
    pp =
      (fun _enc ppf raw ->
        match Data_encoding.Json.from_string raw with
        | Error err ->
            Format.fprintf
              ppf
              "@[Invalid JSON:@  - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ \
               %s@]@]"
              err
              raw
        | Ok json -> Data_encoding.Json.pp ppf json);
    construct =
      (fun enc v ->
        let json = Data_encoding.Json.construct enc v in
        json_to_string json);
    construct_seq =
      (fun enc v ->
        let buffer = Bytes.create chunk_size_hint in
        Data_encoding.Json.blit_instructions_seq_of_jsonm_lexeme_seq
          ~newline:true
          ~buffer
        @@ Data_encoding.Json.construct_seq enc v);
    destruct =
      (fun enc body ->
        match Data_encoding.Json.from_string body with
        | Error _ as err -> err
        | Ok json -> (
            try Ok (Data_encoding.Json.destruct enc json) with
            | (Stack_overflow | Out_of_memory) as exc -> raise exc
            | Data_encoding.Json.Cannot_destruct (_, exc) ->
                Error
                  (Format.asprintf
                     "%a"
                     (fun fmt -> Data_encoding.Json.print_error fmt)
                     exc)
            | exc -> Error (Printexc.to_string exc)));
  }

let bson =
  let construct_bytes enc v =
    Json_repr_bson.bson_to_bytes @@ Data_encoding.Bson.construct enc v
  in
  {
    name = Cohttp.Accept.MediaType ("application", "bson");
    q = Some 100;
    pp =
      (fun _enc ppf raw ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.of_string raw)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, _) ->
            Format.fprintf ppf "@[Invalid BSON:@ %s@]" msg
        | bson ->
            let json =
              Json_repr.convert
                (module Json_repr_bson.Repr)
                (module Json_repr.Ezjsonm)
                bson
            in
            Data_encoding.Json.pp ppf json);
    construct = (fun env v -> Bytes.unsafe_to_string (construct_bytes env v));
    construct_seq =
      (fun enc v ->
        let b = construct_bytes enc v in
        Seq.return (b, 0, Bytes.length b));
    destruct =
      (fun enc body ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.of_string body)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
            Error (Format.asprintf "(at offset: %d) %s" pos msg)
        | bson -> (
            try Ok (Data_encoding.Bson.destruct enc bson) with
            | (Stack_overflow | Out_of_memory) as exc -> raise exc
            | Data_encoding.Json.Cannot_destruct (_, exc) ->
                Error
                  (Format.asprintf
                     "%a"
                     (fun fmt -> Data_encoding.Json.print_error fmt)
                     exc)
            | exc -> Error (Printexc.to_string exc)));
  }

let octet_stream =
  let dynsize enc =
    (* We add a size header to all the binary exchanges between server and
       client *)
    Data_encoding.dynamic_size enc
  in
  let construct_bytes enc v =
    Data_encoding.Binary.to_bytes_exn (dynsize enc) v
  in
  let construct_string enc v =
    Data_encoding.Binary.to_string_exn (dynsize enc) v
  in
  {
    name = Cohttp.Accept.MediaType ("application", "octet-stream");
    q = Some 200;
    pp =
      (fun enc ppf raw ->
        match Data_encoding.Binary.of_string (dynsize enc) raw with
        | Error Data_encoding.Binary.Not_enough_data ->
            Format.fprintf
              ppf
              "Partial read (%d bytes), waiting for more data (Not enough \
               data): %a"
              (String.length raw)
              Hex.pp
              (Hex.of_string raw)
        | Error re ->
            Format.fprintf
              ppf
              "Invalid binary data: %a."
              Data_encoding.Binary.pp_read_error
              re
        | Ok v ->
            Format.fprintf
              ppf
              ";; binary equivalent of the following json@.%a"
              Data_encoding.Json.pp
              (Data_encoding.Json.construct (dynsize enc) v));
    construct = construct_string;
    construct_seq =
      (fun enc v ->
        let b = construct_bytes enc v in
        Seq.return (b, 0, Bytes.length b));
    destruct =
      (fun enc s ->
        match Data_encoding.Binary.of_string (dynsize enc) s with
        | Error re ->
            Error
              (Format.asprintf
                 "Failed to parse binary data: %a."
                 Data_encoding.Binary.pp_read_error
                 re)
        | Ok data -> Ok data);
  }

let all_media_types = [json; bson; octet_stream]

let encoding : t Tezos_rpc.Encoding.t =
  Data_encoding.string_enum
    [
      ("application/json", json);
      ("application/bson", bson);
      ("application/octet-stream", octet_stream);
    ]

module Content_type = struct
  type t = string * string

  let json = ("application", "json")

  let bson = ("application", "bson")

  let octet_stream = ("application", "octet-stream")

  let pp fmt (l, r) = Format.fprintf fmt "%s/%s" l r
end

let of_content_type c =
  if c = Content_type.json then Some json
  else if c = Content_type.bson then Some bson
  else if c = Content_type.octet_stream then Some octet_stream
  else None

module Command_line = struct
  type t = Any | Json | Binary

  let parse_cli_parameter = function
    | "json" -> Some Json
    | "binary" -> Some Binary
    | "any" -> Some Any
    | _ -> None

  let of_command_line = function
    | Any -> all_media_types
    | Binary -> [octet_stream]
    | Json -> [json; bson]

  let pp_parameter ppf = function
    | Any -> Format.fprintf ppf "any"
    | Binary -> Format.fprintf ppf "binary"
    | Json -> Format.fprintf ppf "json"

  let encoding =
    Data_encoding.string_enum [("json", Json); ("binary", Binary); ("any", Any)]
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