package protocell

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

Source file text_format.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
open Base

type t =
  | String of string
  | Integer of int64
  | Float of float
  | Bool of bool
  | Message of string
  | Enum of string

type sort =
  | String_sort
  | Integer_sort
  | Float_sort
  | Bool_sort
  | Message_sort
  | Enum_sort

type id = string

type serialization_error = Field_value.validation_error

type parsed_message = (id, t list) Hashtbl.t

type parse_error =
  [ `Unexpected_character of char
  | `Invalid_number_string of string
  | `Identifier_expected
  | `Nested_message_unfinished
  | Byte_input.error ]

type deserialization_error =
  [ parse_error
  | sort Types.decoding_error
  | Field_value.validation_error ]

module Id = String

let to_sort = function
  | String _ -> String_sort
  | Integer _ -> Integer_sort
  | Float _ -> Float_sort
  | Bool _ -> Bool_sort
  | Message _ -> Message_sort
  | Enum _ -> Enum_sort

let sort_to_string = function
  | String_sort -> "String"
  | Integer_sort -> "Integer"
  | Float_sort -> "Float"
  | Bool_sort -> "Boolean"
  | Message_sort -> "Message"
  | Enum_sort -> "Enum"

module Encoding : Types.Encoding with type t := t with type sort := sort = struct
  let encode_string value = String (Field_value.unpack value)

  let decode_string typ value =
    match value with
    | String string -> Ok string
    | _ -> Error (`Wrong_value_sort_for_string_field (to_sort value, typ))

  let encode_int value = Integer (value |> Field_value.unpack |> Int64.of_int)

  let decode_int typ value =
    match value with
    | Integer int64 -> (
      match Int64.to_int int64 with
      | None -> Error (`Integer_outside_int_type_range int64)
      | Some i -> Ok i)
    | _ -> Error (`Wrong_value_sort_for_int_field (to_sort value, typ))

  let encode_float value = Float (value |> Field_value.unpack)

  let decode_float typ value =
    match value with
    | Float float -> (
      match typ with
      | Field_value.Float_t -> Ok (float |> Int32.bits_of_float |> Int32.float_of_bits)
      | Field_value.Double_t -> Ok float)
    | Integer int -> (
        let float = Float.of_int64 int in
        match typ with
        | Field_value.Float_t -> Ok (float |> Int32.bits_of_float |> Int32.float_of_bits)
        | Field_value.Double_t -> Ok float)
    | _ -> Error (`Wrong_value_sort_for_float_field (to_sort value, typ))

  let encode_bool value = Bool (value |> Field_value.unpack)

  let decode_bool typ value =
    match value with
    | Bool bool -> Ok bool
    | _ -> Error (`Wrong_value_sort_for_bool_field (to_sort value, typ))
end

module Writer = struct
  let write_value output value =
    match value with
    | String string ->
        Byte_output.write_byte output '"';
        Byte_output.write_bytes output (String.escaped string);
        Byte_output.write_byte output '"'
    | Integer int -> Int64.to_string int |> Byte_output.write_bytes output
    | Float float -> Float.to_string float |> Byte_output.write_bytes output
    | Bool bool -> Bool.to_string bool |> Byte_output.write_bytes output
    | Message encoding ->
        Byte_output.write_bytes output "{ ";
        Byte_output.write_bytes output encoding;
        Byte_output.write_byte output '}'
    | Enum name -> Byte_output.write_bytes output name

  let write_field output (id, value) =
    Byte_output.write_bytes output id;
    (match value with
    | Message _ -> Byte_output.write_bytes output " "
    | _ -> Byte_output.write_bytes output ": ");
    write_value output value;
    Byte_output.write_byte output ' '
end

module Reader = struct
  type token =
    | Whitespace of string
    | Identifier of string
    | String of string
    | Key_value_separator
    | Open_message
    | Close_message

  let token_to_string = function
    | Whitespace s -> s
    | Identifier s -> s
    | String s -> Printf.sprintf "\"%s\"" s
    | Key_value_separator -> ":"
    | Open_message -> "{"
    | Close_message -> "}"

  let is_whitespace character =
    List.exists [' '; '\t'; '\r'; '\n'] ~f:(Char.equal character)

  let is_letter character =
    Char.between ~low:'a' ~high:'z' character
    || Char.between ~low:'A' ~high:'Z' character

  let is_digit character = Char.between ~low:'0' ~high:'9' character

  let is_word_character character =
    is_letter character
    || is_digit character
    || Char.equal character '_'
    || Char.equal character '-'
    || Char.equal character '.'
    || Char.equal character '+'

  let tokenize input =
    let read_rest input character condition =
      Char.to_string character ^ Byte_input.read_while input condition
    in
    let rec collect accumulator =
      match Byte_input.read_byte input with
      | Ok character -> (
          let token =
            match character with
            | '"' -> (
                let contents =
                  let is_escaped = ref false in
                  Byte_input.read_while input (fun c ->
                      match c, !is_escaped with
                      | '"', false -> false
                      | '\\', old_is_escaped ->
                          is_escaped := not old_is_escaped;
                          true
                      | _, _ ->
                          is_escaped := false;
                          true)
                in
                match Byte_input.read_byte input with
                | Ok '"' -> Ok (String (Caml.Scanf.unescaped contents))
                | Ok character -> Error (`Unexpected_character character)
                | Error `Not_enough_bytes as error -> error)
            | '{' -> Ok Open_message
            | '}' -> Ok Close_message
            | ':' -> Ok Key_value_separator
            | _ when is_whitespace character ->
                Ok (Whitespace (read_rest input character is_whitespace))
            | _ when is_word_character character ->
                Ok (Identifier (read_rest input character is_word_character))
            | _ -> Error (`Unexpected_character character)
          in
          match token with
          | Ok t -> collect (t :: accumulator)
          | Error _ as error -> error)
      | Error `Not_enough_bytes -> Ok (List.rev accumulator)
    in
    collect []

  let rec read_key_value_pair tokens =
    match tokens with
    | Identifier key :: Key_value_separator :: Identifier literal :: rest -> (
      match literal with
      | "true" -> Ok (key, Bool true, rest)
      | "false" -> Ok (key, Bool false, rest)
      | _ -> (
        match Int64.of_string literal with
        | int -> Ok (key, Integer int, rest)
        | exception _ -> (
          match Float.of_string literal with
          | float -> Ok (key, Float float, rest)
          | exception _ -> Ok (key, Enum literal, rest))))
    | Identifier key :: Key_value_separator :: String string :: rest ->
        Ok (key, String string, rest)
    | Identifier key :: Open_message :: rest ->
        let rec consume_message acc inner_open_count tokens =
          match tokens, inner_open_count with
          | Open_message :: rest, _ ->
              consume_message (Open_message :: acc) (Int.succ inner_open_count) rest
          | Close_message :: rest, 0 ->
              Ok
                ( key,
                  Message
                    (List.rev acc |> List.map ~f:token_to_string |> String.concat ~sep:""),
                  rest )
          | Close_message :: rest, _ ->
              consume_message (Close_message :: acc) (Int.pred inner_open_count) rest
          | [], _ -> Error `Nested_message_unfinished
          | token :: rest, _ -> consume_message (token :: acc) inner_open_count rest
        in
        consume_message [] 0 rest
    | _ -> Error `Identifier_expected

  and read_key_value_pairs tokens =
    let rec collect accumulator tokens =
      match tokens with
      | [] -> Ok accumulator
      | _ -> (
        match read_key_value_pair tokens with
        | Ok (key, value, tokens) -> collect ((key, value) :: accumulator) tokens
        | Error _ as error -> error)
    in
    let tokens =
      List.filter tokens ~f:(function
          | Whitespace _ -> false
          | _ -> true)
    in
    collect [] tokens

  let read input =
    let open Result.Let_syntax in
    tokenize input >>= read_key_value_pairs
end

let encode : type v. v Field_value.t -> t =
 fun value ->
  let module F = Field_value in
  let typ = F.typ value in
  match typ with
  | F.String_t -> Encoding.encode_string value
  | F.Bytes_t -> Encoding.encode_string value
  | F.Int32_t -> Encoding.encode_int value
  | F.Int64_t -> Encoding.encode_int value
  | F.Sint32_t -> Encoding.encode_int value
  | F.Sint64_t -> Encoding.encode_int value
  | F.Uint32_t -> Encoding.encode_int value
  | F.Uint64_t -> Encoding.encode_int value
  | F.Fixed32_t -> Encoding.encode_int value
  | F.Fixed64_t -> Encoding.encode_int value
  | F.Sfixed32_t -> Encoding.encode_int value
  | F.Sfixed64_t -> Encoding.encode_int value
  | F.Float_t -> Encoding.encode_float value
  | F.Double_t -> Encoding.encode_float value
  | F.Bool_t -> Encoding.encode_bool value

let serialize_field id typ value output =
  let open Result.Let_syntax in
  Field_value.create typ value >>| encode >>| fun value ->
  Writer.write_field output (id, value)

let serialize_optional_field id typ value output =
  match value with
  | None -> Ok ()
  | Some value -> serialize_field id typ value output

let serialize_repeated_field id typ values output =
  List.map values ~f:(fun value -> serialize_field id typ value output)
  |> Result.all_unit

let serialize_user_value id serializer value output =
  let open Result.Let_syntax in
  serializer value >>| fun encoding -> Writer.write_field output (id, Message encoding)

let serialize_user_field id serializer value output =
  match value with
  | None -> Ok ()
  | Some value -> serialize_user_value id serializer value output

let serialize_user_oneof_field = serialize_user_value

let serialize_repeated_user_field id serializer values output =
  List.map values ~f:(fun value -> serialize_user_value id serializer value output)
  |> Result.all_unit

let serialize_enum_field id to_string value output =
  let open Result.Let_syntax in
  return @@ Writer.write_field output (id, Enum (to_string value))

let serialize_repeated_enum_field id to_string values output =
  List.map values ~f:(fun value -> serialize_enum_field id to_string value output)
  |> Result.all_unit

let deserialize_message input =
  let open Result.Let_syntax in
  Reader.read input >>| fun records ->
  Hashtbl.of_alist_multi ~growth_allowed:false (module Id) records

let decode_value : type v. t -> v Field_value.typ -> (v, _) Result.t =
 fun value typ ->
  let module F = Field_value in
  match typ with
  | F.String_t -> Encoding.decode_string typ value
  | F.Bytes_t -> Encoding.decode_string typ value
  | F.Int32_t -> Encoding.decode_int typ value
  | F.Int64_t -> Encoding.decode_int typ value
  | F.Sint32_t -> Encoding.decode_int typ value
  | F.Sint64_t -> Encoding.decode_int typ value
  | F.Uint32_t -> Encoding.decode_int typ value
  | F.Uint64_t -> Encoding.decode_int typ value
  | F.Fixed32_t -> Encoding.decode_int typ value
  | F.Fixed64_t -> Encoding.decode_int typ value
  | F.Sfixed32_t -> Encoding.decode_int typ value
  | F.Sfixed64_t -> Encoding.decode_int typ value
  | F.Float_t -> Encoding.decode_float typ value
  | F.Double_t -> Encoding.decode_float typ value
  | F.Bool_t -> Encoding.decode_bool typ value

let decode_field_value typ value =
  let open Result.Let_syntax in
  decode_value value typ >>= Field_value.create typ >>| Field_value.unpack

let decode_field id typ records =
  match Hashtbl.find records id with
  | None -> Ok (Field_value.default typ)
  | Some values -> (
    match List.last values with
    | None -> Ok (Field_value.default typ)
    | Some value -> decode_field_value typ value)

let decode_optional_field id typ records =
  let open Result.Let_syntax in
  match Hashtbl.find records id with
  | None -> Ok None
  | Some values -> (
    match List.last values with
    | None -> Ok None
    | Some value -> decode_field_value typ value >>| Option.some)

let decode_repeated_field id typ records =
  match Hashtbl.find records id with
  | None -> Ok []
  | Some values -> List.map values ~f:(decode_field_value typ) |> Result.all

let decode_user_value deserializer value =
  match value with
  | Message encoding -> deserializer encoding
  | _ as value -> Error (`Wrong_value_sort_for_user_field (to_sort value))

let decode_user_field id deserializer records =
  let open Result.Let_syntax in
  match Hashtbl.find records id with
  | None -> Ok None
  | Some values -> (
    match List.last values with
    | None -> Ok None
    | Some value -> decode_user_value deserializer value >>| Option.some)

let decode_user_oneof_field id deserializer records =
  let values = Hashtbl.find_exn records id in
  decode_user_value deserializer (List.last_exn values)

let decode_repeated_user_field id deserializer records =
  match Hashtbl.find records id with
  | None -> Ok []
  | Some values -> List.map values ~f:(decode_user_value deserializer) |> Result.all

let decode_enum_value of_string = function
  | Enum name -> of_string name |> Result.of_option ~error:`Unrecognized_enum_value
  | _ as value -> Error (`Wrong_value_sort_for_enum_field (to_sort value))

let decode_enum_field id of_string default records =
  match Hashtbl.find records id with
  | None -> Ok (default ())
  | Some values -> (
    match List.last values with
    | None -> Ok (default ())
    | Some value -> decode_enum_value of_string value)

let decode_repeated_enum_field id of_string _default records =
  match Hashtbl.find records id with
  | None -> Ok []
  | Some values -> List.map values ~f:(decode_enum_value of_string) |> Result.all

let decode_oneof_field deserializers records =
  let open Result.Let_syntax in
  let applicable =
    List.filter deserializers ~f:(fun (id, _) -> Hashtbl.mem records id)
  in
  match List.length applicable with
  | 0 -> Ok None
  | 1 ->
      applicable |> List.hd_exn |> snd |> fun deserializer ->
      deserializer records >>| Option.some
  | _ -> Error `Multiple_oneof_fields_set
OCaml

Innovation. Community. Security.