Protocol Buffers codec for hand-written schemas
ocaml-linkedin: apply dune fmt
Pure formatting changes from `dune fmt`: doc comment placement moves
from above the binding to below it for `type`s, multi-line `match`
expressions collapse onto one line where they fit, and infix operator
applications pick up spaces (`Soup.($?)` -> `Soup.( $? )`). No
semantic changes.
+481
-415
+31
-13
README.md
+31
-13
README.md
···
9
9
10
10
## Installation
11
11
12
+
Install with opam:
13
+
14
+
```sh
15
+
$ opam install protobuf
12
16
```
13
-
opam install protobuf
17
+
18
+
If opam cannot find the package, it may not yet be released in the public
19
+
`opam-repository`. Add the overlay repository, then install it:
20
+
21
+
```sh
22
+
$ opam repo add samoht https://tangled.org/gazagnaire.org/opam-overlay.git
23
+
$ opam update
24
+
$ opam install protobuf
14
25
```
15
26
16
27
## Usage
···
20
31
21
32
let person_codec : person Protobuf.t =
22
33
let open Protobuf.Message in
23
-
let* name = required 1 (fun p -> p.name) Protobuf.string in
24
-
let* age = required 2 (fun p -> p.age) Protobuf.int32 in
25
-
let* hobbies = repeated 3 (fun p -> p.hobbies) Protobuf.string in
26
-
return { name; age; hobbies } |> finish
34
+
v (fun name age hobbies -> { name; age; hobbies })
35
+
|> required 1 Protobuf.string ~enc:(fun p -> p.name)
36
+
|> required 2 Protobuf.int32 ~enc:(fun p -> p.age)
37
+
|> repeated 3 Protobuf.string ~enc:(fun p -> p.hobbies)
38
+
|> seal
27
39
28
40
let wire =
29
-
Protobuf.encode_string person_codec
41
+
Protobuf.to_string person_codec
30
42
{ name = "Ada"; age = 36l; hobbies = [ "math"; "sewing" ] }
31
43
32
44
let () =
33
-
match Protobuf.decode_string person_codec wire with
45
+
match Protobuf.of_string person_codec wire with
34
46
| Ok p -> Printf.printf "%s, %ld, %d hobbies\n" p.name p.age (List.length p.hobbies)
35
-
| Error msg -> prerr_endline msg
47
+
| Error e -> prerr_endline (Protobuf.Error.to_string e)
36
48
```
37
49
38
50
## Scalar codecs
···
57
69
58
70
## Field combinators
59
71
60
-
- `required n get c` — a field at tag `n`, codec `c`. Absent decodes as the
72
+
The pipeline starts with `v ctor` and each step adds one field:
73
+
74
+
- `required n c ~enc` — a field at tag `n`, codec `c`. Absent decodes as the
61
75
scalar's default (`0`, `""`, `false`, etc., matching proto3 semantics).
62
-
- `optional n get c` — the value as `'a option`; decoded as `None` iff the
76
+
- `optional n c ~enc` — the value as `'a option`; decoded as `None` iff the
63
77
tag is absent.
64
-
- `repeated n get c` — multiple values (non-packed). Each occurrence of
78
+
- `repeated n c ~enc` — multiple values (non-packed). Each occurrence of
65
79
tag `n` appends to the list.
66
-
- `packed n get c` — packed repeated: one length-delimited blob holds all
80
+
- `packed n c ~enc` — packed repeated: one length-delimited blob holds all
67
81
values concatenated. Required for numeric repeated fields in proto3.
68
-
- `message n get c` — a nested message (length-delimited).
82
+
- `map n kc vc ~enc` — a `map<K, V>` field.
83
+
- `oneof ~default ~enc cases` — at most one of a set of alternative fields.
84
+
85
+
Each step takes a builder `('o, 'a -> 'dec) t_` and returns `('o, 'dec) t_`;
86
+
`seal` closes `('o, 'o) t_` into an `'o Protobuf.t`.
69
87
70
88
## Limitations (v0.1)
71
89
+4
dune
+4
dune
+2
dune-project
+2
dune-project
+36
-40
fuzz/fuzz_protobuf.ml
+36
-40
fuzz/fuzz_protobuf.ml
···
61
61
62
62
let inner_codec : inner Protobuf.t =
63
63
let open Protobuf.Message in
64
-
finish
65
-
(let* x = required 1 (fun r -> r.x) Protobuf.int32 in
66
-
return { x })
64
+
v (fun x -> { x }) |> required 1 Protobuf.int32 ~enc:(fun r -> r.x) |> seal
67
65
68
66
type kitchen = {
69
67
i32 : int32;
···
85
83
86
84
let kitchen_codec : kitchen Protobuf.t =
87
85
let open Protobuf.Message in
88
-
finish
89
-
(let* i32 = required 1 (fun r -> r.i32) Protobuf.int32 in
90
-
let* i64 = required 2 (fun r -> r.i64) Protobuf.int64 in
91
-
let* u32 = required 3 (fun r -> r.u32) Protobuf.uint32 in
92
-
let* s64 = required 4 (fun r -> r.s64) Protobuf.sint64 in
93
-
let* f32 = required 5 (fun r -> r.f32) Protobuf.fixed32 in
94
-
let* f64 = required 6 (fun r -> r.f64) Protobuf.fixed64 in
95
-
let* flt = required 7 (fun r -> r.flt) Protobuf.float in
96
-
let* dbl = required 8 (fun r -> r.dbl) Protobuf.double in
97
-
let* bl = required 9 (fun r -> r.bl) Protobuf.bool in
98
-
let* str = required 10 (fun r -> r.str) Protobuf.string in
99
-
let* byts = required 11 (fun r -> r.byts) Protobuf.bytes in
100
-
let* name = optional 12 (fun r -> r.name) Protobuf.string in
101
-
let* tags = repeated 13 (fun r -> r.tags) Protobuf.string in
102
-
let* nums = packed 14 (fun r -> r.nums) Protobuf.int32 in
103
-
let* inner = required 15 (fun r -> r.inner) inner_codec in
104
-
return
105
-
{
106
-
i32;
107
-
i64;
108
-
u32;
109
-
s64;
110
-
f32;
111
-
f64;
112
-
flt;
113
-
dbl;
114
-
bl;
115
-
str;
116
-
byts;
117
-
name;
118
-
tags;
119
-
nums;
120
-
inner;
121
-
})
86
+
v (fun i32 i64 u32 s64 f32 f64 flt dbl bl str byts name tags nums inner ->
87
+
{
88
+
i32;
89
+
i64;
90
+
u32;
91
+
s64;
92
+
f32;
93
+
f64;
94
+
flt;
95
+
dbl;
96
+
bl;
97
+
str;
98
+
byts;
99
+
name;
100
+
tags;
101
+
nums;
102
+
inner;
103
+
})
104
+
|> required 1 Protobuf.int32 ~enc:(fun r -> r.i32)
105
+
|> required 2 Protobuf.int64 ~enc:(fun r -> r.i64)
106
+
|> required 3 Protobuf.uint32 ~enc:(fun r -> r.u32)
107
+
|> required 4 Protobuf.sint64 ~enc:(fun r -> r.s64)
108
+
|> required 5 Protobuf.fixed32 ~enc:(fun r -> r.f32)
109
+
|> required 6 Protobuf.fixed64 ~enc:(fun r -> r.f64)
110
+
|> required 7 Protobuf.float ~enc:(fun r -> r.flt)
111
+
|> required 8 Protobuf.double ~enc:(fun r -> r.dbl)
112
+
|> required 9 Protobuf.bool ~enc:(fun r -> r.bl)
113
+
|> required 10 Protobuf.string ~enc:(fun r -> r.str)
114
+
|> required 11 Protobuf.bytes ~enc:(fun r -> r.byts)
115
+
|> optional 12 Protobuf.string ~enc:(fun r -> r.name)
116
+
|> repeated 13 Protobuf.string ~enc:(fun r -> r.tags)
117
+
|> packed 14 Protobuf.int32 ~enc:(fun r -> r.nums)
118
+
|> required 15 inner_codec ~enc:(fun r -> r.inner)
119
+
|> seal
122
120
123
121
let kitchen_equal a b =
124
122
let f_eq x y = (Float.is_nan x && Float.is_nan y) || x = y in
···
220
218
221
219
let packed_codec : packed_i32 Protobuf.t =
222
220
let open Protobuf.Message in
223
-
finish
224
-
(let* xs = packed 1 (fun r -> r.xs) Protobuf.int32 in
225
-
return { xs })
221
+
v (fun xs -> { xs }) |> packed 1 Protobuf.int32 ~enc:(fun r -> r.xs) |> seal
226
222
227
223
let test_packed_roundtrip xs =
228
224
let s = Protobuf.to_string packed_codec { xs } in
+142
-151
lib/codec.ml
+142
-151
lib/codec.ml
···
309
309
310
310
(* -- Message combinators --
311
311
312
-
The [(o, a) field] GADT captures a sequence of field declarations
313
-
and the continuation that builds the record value. Encoding walks
314
-
the GADT in declaration order and emits (tag, value) per field.
315
-
Decoding pre-parses the wire into a tag -> wire_value list table
316
-
and then walks the same GADT, looking each field up in the table. *)
312
+
A message codec is built with a pipeline: [v ctor |> required ... |>
313
+
required ... |> seal]. The [ctor] is a decoder function whose
314
+
arguments are filled in left-to-right by each field step; [seal]
315
+
closes the pipeline into a [Protobuf.t].
316
+
317
+
Under the hood, each field pushes an [_ field_spec] onto the builder
318
+
and wraps the decoder so that it consumes the field's wire entry
319
+
before applying one more argument to [ctor]. *)
317
320
318
321
module Message = struct
319
-
type (_, _) field =
320
-
| Return : 'a -> ('o, 'a) field
321
-
| Required : {
322
+
type 'o field_spec =
323
+
| FS_Required : { tag : int; codec : 'x t; get : 'o -> 'x } -> 'o field_spec
324
+
| FS_Optional : {
322
325
tag : int;
323
-
get : 'o -> 'x;
324
326
codec : 'x t;
325
-
cont : 'x -> ('o, 'a) field;
326
-
}
327
-
-> ('o, 'a) field
328
-
| Optional : {
329
-
tag : int;
330
327
get : 'o -> 'x option;
331
-
codec : 'x t;
332
-
cont : 'x option -> ('o, 'a) field;
333
328
}
334
-
-> ('o, 'a) field
335
-
| Repeated : {
329
+
-> 'o field_spec
330
+
| FS_Repeated : {
336
331
tag : int;
337
-
get : 'o -> 'x list;
338
332
codec : 'x t;
339
333
packed : bool;
340
-
cont : 'x list -> ('o, 'a) field;
341
-
}
342
-
-> ('o, 'a) field
343
-
| Oneof : {
344
-
get : 'o -> 'x;
345
-
default : 'x;
346
-
cases : 'x case list;
347
-
cont : 'x -> ('o, 'a) field;
334
+
get : 'o -> 'x list;
348
335
}
349
-
-> ('o, 'a) field
336
+
-> 'o field_spec
337
+
| FS_Oneof : { get : 'o -> 'x; cases : 'x case list } -> 'o field_spec
350
338
351
339
and 'a case =
352
340
| Case : {
···
357
345
}
358
346
-> 'a case
359
347
360
-
let return v = Return v
348
+
type wire_table = (int, (int * wire_value) list ref) Hashtbl.t
361
349
362
-
let required tag get codec =
363
-
Required { tag; get; codec; cont = (fun x -> Return x) }
350
+
type ('o, 'dec) t_ = {
351
+
fields_rev : 'o field_spec list;
352
+
dec : wire_table -> 'dec;
353
+
}
364
354
365
-
let optional tag get codec =
366
-
Optional { tag; get; codec; cont = (fun x -> Return x) }
367
-
368
-
let repeated tag get codec =
369
-
Repeated { tag; get; codec; packed = false; cont = (fun x -> Return x) }
370
-
371
-
let packed tag get codec =
372
-
Repeated { tag; get; codec; packed = true; cont = (fun x -> Return x) }
355
+
let v : type o dec. dec -> (o, dec) t_ =
356
+
fun f -> { fields_rev = []; dec = (fun _ -> f) }
373
357
374
358
let case tag codec ~inject ~extract = Case { tag; codec; inject; extract }
375
359
376
-
let oneof ~default get cases =
377
-
Oneof { get; default; cases; cont = (fun x -> Return x) }
378
-
379
-
let rec ( let* ) : type o a b.
380
-
(o, a) field -> (a -> (o, b) field) -> (o, b) field =
381
-
fun m f ->
382
-
match m with
383
-
| Return a -> f a
384
-
| Required r ->
385
-
Required
386
-
{
387
-
r with
388
-
cont =
389
-
(fun x ->
390
-
let* y = r.cont x in
391
-
f y);
392
-
}
393
-
| Optional r ->
394
-
Optional
395
-
{
396
-
r with
397
-
cont =
398
-
(fun x ->
399
-
let* y = r.cont x in
400
-
f y);
401
-
}
402
-
| Repeated r ->
403
-
Repeated
404
-
{
405
-
r with
406
-
cont =
407
-
(fun x ->
408
-
let* y = r.cont x in
409
-
f y);
410
-
}
411
-
| Oneof r ->
412
-
Oneof
413
-
{
414
-
r with
415
-
cont =
416
-
(fun x ->
417
-
let* y = r.cont x in
418
-
f y);
419
-
}
420
-
421
360
(* -- Encoding -- *)
422
361
423
362
let write_field buf ~tag codec v =
···
450
389
Leb128.add_u63_to_buffer buf (Buffer.length body);
451
390
Buffer.add_buffer buf body
452
391
453
-
let rec encode_fields : type o a. Buffer.t -> o -> (o, a) field -> unit =
454
-
fun buf o m ->
455
-
match m with
456
-
| Return _ -> ()
457
-
| Required { tag; get; codec; cont } ->
392
+
let encode_field : type o. Buffer.t -> o -> o field_spec -> unit =
393
+
fun buf o -> function
394
+
| FS_Required { tag; codec; get } ->
458
395
let v = get o in
459
396
(* proto3 semantics: omit a required scalar field that equals
460
397
the codec's default. *)
461
-
if v <> default_of codec then write_field buf ~tag codec v;
462
-
encode_fields buf o (cont v)
463
-
| Optional { tag; get; codec; cont } ->
464
-
let v_opt = get o in
465
-
(match v_opt with Some v -> write_field buf ~tag codec v | None -> ());
466
-
encode_fields buf o (cont v_opt)
467
-
| Repeated { tag; get; codec; packed; cont } ->
468
-
let vs = get o in
469
-
(match vs with
398
+
if v <> default_of codec then write_field buf ~tag codec v
399
+
| FS_Optional { tag; codec; get } -> (
400
+
match get o with Some v -> write_field buf ~tag codec v | None -> ())
401
+
| FS_Repeated { tag; codec; packed; get } -> (
402
+
match get o with
470
403
| [] -> ()
471
-
| _ when packed -> write_packed buf ~tag codec vs
472
-
| _ -> List.iter (write_field buf ~tag codec) vs);
473
-
encode_fields buf o (cont vs)
474
-
| Oneof { get; cases; cont; _ } ->
404
+
| vs when packed -> write_packed buf ~tag codec vs
405
+
| vs -> List.iter (write_field buf ~tag codec) vs)
406
+
| FS_Oneof { get; cases } ->
475
407
let v = get o in
476
408
let rec emit_case = function
477
409
| [] -> ()
···
480
412
| Some x -> write_field buf ~tag codec x
481
413
| None -> emit_case rest)
482
414
in
483
-
emit_case cases;
484
-
encode_fields buf o (cont v)
415
+
emit_case cases
485
416
486
417
(* -- Decoding helpers -- *)
487
418
···
631
562
values;
632
563
List.rev !acc
633
564
634
-
let rec decode_fields : type o a.
635
-
(int, (int * wire_value) list ref) Hashtbl.t -> (o, a) field -> a =
636
-
fun table m ->
637
-
match m with
638
-
| Return a -> a
639
-
| Required { tag; codec; cont; _ } ->
640
-
let v =
641
-
match take_last table tag with
642
-
| Some w -> decode_value codec w
643
-
| None -> default_of codec
644
-
in
645
-
decode_fields table (cont v)
646
-
| Optional { tag; codec; cont; _ } ->
647
-
let v =
648
-
match take_last table tag with
649
-
| Some w -> Some (decode_value codec w)
650
-
| None -> None
651
-
in
652
-
decode_fields table (cont v)
653
-
| Repeated { tag; codec; cont; _ } ->
654
-
let vs = decode_packed_or_repeated codec (take_all table tag) in
655
-
decode_fields table (cont vs)
656
-
| Oneof { default; cases; cont; _ } ->
657
-
let v =
658
-
match take_oneof_last table cases with
659
-
| None -> default
660
-
| Some (Case { codec; inject; _ }, w) -> inject (decode_value codec w)
661
-
in
662
-
decode_fields table (cont v)
663
-
664
565
(* A [map<K, V>] field is sugar for [repeated Entry { K key = 1; V value
665
566
= 2 }] on the wire — each entry is a length-delimited submessage with
666
567
two required fields. [map_entry_codec] builds the entry codec; [map]
667
568
declares a field that collects a list of [(k, v)] pairs. *)
668
569
let map_entry_codec : type k v. k t -> v t -> (k * v) t =
669
570
fun key_codec value_codec ->
670
-
(* Constructed directly (not via [finish]) because the entry is an
671
-
ephemeral tuple rather than a named record — skips the
672
-
let* / return chain. *)
673
571
let encode_body buf (k, v) =
674
572
if k <> default_of key_codec then begin
675
573
Wire.write_tag buf ~field_number:1 ~wire_type:(wire_type_of key_codec);
···
702
600
let msg_default = (default_of key_codec, default_of value_codec) in
703
601
Message { encode_body; decode_body; decode_body_with_unknowns; msg_default }
704
602
705
-
let map tag get key_codec value_codec =
706
-
Repeated
707
-
{
708
-
tag;
709
-
get;
710
-
codec = map_entry_codec key_codec value_codec;
711
-
packed = false;
712
-
cont = (fun x -> Return x);
713
-
}
603
+
(* -- Pipeline builder steps --
604
+
605
+
Each step pushes a field spec onto the builder's list and wraps
606
+
[dec] so that the decoder reads one value from the wire table and
607
+
applies it to the partial constructor. *)
608
+
609
+
let required : type x o dec.
610
+
int -> x t -> enc:(o -> x) -> (o, x -> dec) t_ -> (o, dec) t_ =
611
+
fun tag codec ~enc b ->
612
+
{
613
+
fields_rev = FS_Required { tag; codec; get = enc } :: b.fields_rev;
614
+
dec =
615
+
(fun table ->
616
+
let v =
617
+
match take_last table tag with
618
+
| Some w -> decode_value codec w
619
+
| None -> default_of codec
620
+
in
621
+
b.dec table v);
622
+
}
714
623
715
-
let finish : type o. (o, o) field -> o t =
716
-
fun spec ->
717
-
let encode_body buf o = encode_fields buf o spec in
624
+
let optional : type x o dec.
625
+
int ->
626
+
x t ->
627
+
enc:(o -> x option) ->
628
+
(o, x option -> dec) t_ ->
629
+
(o, dec) t_ =
630
+
fun tag codec ~enc b ->
631
+
{
632
+
fields_rev = FS_Optional { tag; codec; get = enc } :: b.fields_rev;
633
+
dec =
634
+
(fun table ->
635
+
let v =
636
+
match take_last table tag with
637
+
| Some w -> Some (decode_value codec w)
638
+
| None -> None
639
+
in
640
+
b.dec table v);
641
+
}
642
+
643
+
let repeated : type x o dec.
644
+
int -> x t -> enc:(o -> x list) -> (o, x list -> dec) t_ -> (o, dec) t_ =
645
+
fun tag codec ~enc b ->
646
+
{
647
+
fields_rev =
648
+
FS_Repeated { tag; codec; packed = false; get = enc } :: b.fields_rev;
649
+
dec =
650
+
(fun table ->
651
+
let vs = decode_packed_or_repeated codec (take_all table tag) in
652
+
b.dec table vs);
653
+
}
654
+
655
+
let packed : type x o dec.
656
+
int -> x t -> enc:(o -> x list) -> (o, x list -> dec) t_ -> (o, dec) t_ =
657
+
fun tag codec ~enc b ->
658
+
{
659
+
fields_rev =
660
+
FS_Repeated { tag; codec; packed = true; get = enc } :: b.fields_rev;
661
+
dec =
662
+
(fun table ->
663
+
let vs = decode_packed_or_repeated codec (take_all table tag) in
664
+
b.dec table vs);
665
+
}
666
+
667
+
let map : type k v o dec.
668
+
int ->
669
+
k t ->
670
+
v t ->
671
+
enc:(o -> (k * v) list) ->
672
+
(o, (k * v) list -> dec) t_ ->
673
+
(o, dec) t_ =
674
+
fun tag key_codec value_codec ~enc b ->
675
+
let codec = map_entry_codec key_codec value_codec in
676
+
{
677
+
fields_rev =
678
+
FS_Repeated { tag; codec; packed = false; get = enc } :: b.fields_rev;
679
+
dec =
680
+
(fun table ->
681
+
let vs = decode_packed_or_repeated codec (take_all table tag) in
682
+
b.dec table vs);
683
+
}
684
+
685
+
let oneof : type x o dec.
686
+
default:x ->
687
+
enc:(o -> x) ->
688
+
x case list ->
689
+
(o, x -> dec) t_ ->
690
+
(o, dec) t_ =
691
+
fun ~default ~enc cases b ->
692
+
{
693
+
fields_rev = FS_Oneof { get = enc; cases } :: b.fields_rev;
694
+
dec =
695
+
(fun table ->
696
+
let v =
697
+
match take_oneof_last table cases with
698
+
| None -> default
699
+
| Some (Case { codec; inject; _ }, w) ->
700
+
inject (decode_value codec w)
701
+
in
702
+
b.dec table v);
703
+
}
704
+
705
+
let seal : type o. (o, o) t_ -> o t =
706
+
fun b ->
707
+
let fields = List.rev b.fields_rev in
708
+
let encode_body buf o = List.iter (encode_field buf o) fields in
718
709
let decode_body s start end_ =
719
710
let table = parse_wire s start end_ in
720
-
decode_fields table spec
711
+
b.dec table
721
712
in
722
713
let decode_body_with_unknowns s start end_ =
723
714
let table = parse_wire s start end_ in
724
-
let value = decode_fields table spec in
715
+
let value = b.dec table in
725
716
(value, collect_unknowns table)
726
717
in
727
718
(* A message with no fields populated: all scalars take their
+39
-10
lib/codec.mli
+39
-10
lib/codec.mli
···
37
37
(** {1 Messages} *)
38
38
39
39
module Message : sig
40
-
type ('o, 'a) field
40
+
type ('o, 'dec) t_
41
+
42
+
val v : 'dec -> ('o, 'dec) t_
43
+
val seal : ('o, 'o) t_ -> 'o t
44
+
45
+
val required :
46
+
int -> 'a t -> enc:('o -> 'a) -> ('o, 'a -> 'dec) t_ -> ('o, 'dec) t_
47
+
48
+
val optional :
49
+
int ->
50
+
'a t ->
51
+
enc:('o -> 'a option) ->
52
+
('o, 'a option -> 'dec) t_ ->
53
+
('o, 'dec) t_
41
54
42
-
val ( let* ) : ('o, 'a) field -> ('a -> ('o, 'b) field) -> ('o, 'b) field
43
-
val return : 'a -> ('o, 'a) field
44
-
val finish : ('o, 'o) field -> 'o t
45
-
val required : int -> ('o -> 'a) -> 'a t -> ('o, 'a) field
46
-
val optional : int -> ('o -> 'a option) -> 'a t -> ('o, 'a option) field
47
-
val repeated : int -> ('o -> 'a list) -> 'a t -> ('o, 'a list) field
48
-
val packed : int -> ('o -> 'a list) -> 'a t -> ('o, 'a list) field
55
+
val repeated :
56
+
int ->
57
+
'a t ->
58
+
enc:('o -> 'a list) ->
59
+
('o, 'a list -> 'dec) t_ ->
60
+
('o, 'dec) t_
61
+
62
+
val packed :
63
+
int ->
64
+
'a t ->
65
+
enc:('o -> 'a list) ->
66
+
('o, 'a list -> 'dec) t_ ->
67
+
('o, 'dec) t_
49
68
50
69
val map :
51
-
int -> ('o -> ('k * 'v) list) -> 'k t -> 'v t -> ('o, ('k * 'v) list) field
70
+
int ->
71
+
'k t ->
72
+
'v t ->
73
+
enc:('o -> ('k * 'v) list) ->
74
+
('o, ('k * 'v) list -> 'dec) t_ ->
75
+
('o, 'dec) t_
52
76
53
77
type 'a case
54
78
55
79
val case :
56
80
int -> 'a t -> inject:('a -> 'b) -> extract:('b -> 'a option) -> 'b case
57
81
58
-
val oneof : default:'a -> ('o -> 'a) -> 'a case list -> ('o, 'a) field
82
+
val oneof :
83
+
default:'a ->
84
+
enc:('o -> 'a) ->
85
+
'a case list ->
86
+
('o, 'a -> 'dec) t_ ->
87
+
('o, 'dec) t_
59
88
end
60
89
61
90
val fix : default:'a -> ('a t -> 'a t) -> 'a t
+69
-41
lib/protobuf.mli
+69
-41
lib/protobuf.mli
···
2
2
3
3
A codec is a value of type ['a t] that knows how to both encode and decode
4
4
messages of type ['a]. Scalar codecs cover the 15 protobuf primitives;
5
-
{!message} builds composite codecs from field descriptors using a cbor /
6
-
jsont-style [let*] combinator pattern.
5
+
{!Message} builds composite codecs with a jsont-style pipeline: {!Message.v}
6
+
starts with a record constructor, each field step adds one member, and
7
+
{!Message.seal} closes the pipeline into an ['a t].
7
8
8
9
{2 Example}
9
10
···
12
13
13
14
let person : person Protobuf.t =
14
15
let open Protobuf.Message in
15
-
let* name = required 1 (fun p -> p.name) Protobuf.string in
16
-
let* age = required 2 (fun p -> p.age) Protobuf.int32 in
17
-
let* hobbies = repeated 3 (fun p -> p.hobbies) Protobuf.string in
18
-
return { name; age; hobbies } |> finish
16
+
v (fun name age hobbies -> { name; age; hobbies })
17
+
|> required 1 Protobuf.string ~enc:(fun p -> p.name)
18
+
|> required 2 Protobuf.int32 ~enc:(fun p -> p.age)
19
+
|> repeated 3 Protobuf.string ~enc:(fun p -> p.hobbies)
20
+
|> seal
19
21
20
22
let wire =
21
23
Protobuf.to_string person
···
104
106
(** {1 Messages} *)
105
107
106
108
module Message : sig
107
-
(** Build message codecs via a [let*] chain of field declarations.
109
+
(** Build message codecs with a pipeline of field declarations.
108
110
109
-
A [('o, 'a) field] is a partial codec: it describes how to encode and
110
-
decode a message of type ['o], building up to a value of type ['a] along
111
-
the way. The chain terminates with {!return} (producing the final ['o]
112
-
value) and {!finish} (sealing it into an ['o t]). *)
111
+
A [('o, 'dec) t_] is a message codec under construction: it targets a
112
+
message type ['o] and has a decoder constructor of type ['dec] that still
113
+
needs arguments filled in by later field steps. The pipeline starts with
114
+
{!v} wrapping a record constructor and terminates with {!seal}. *)
113
115
114
-
type ('o, 'a) field
116
+
type ('o, 'dec) t_
117
+
(** An in-progress message codec for type ['o], with ['dec] tracking the
118
+
arguments still to be applied to the record constructor. *)
115
119
116
-
val ( let* ) : ('o, 'a) field -> ('a -> ('o, 'b) field) -> ('o, 'b) field
117
-
(** Monadic bind for sequencing field declarations. *)
120
+
val v : 'dec -> ('o, 'dec) t_
121
+
(** [v ctor] starts a pipeline with [ctor] as the record constructor. Each
122
+
subsequent field step applies one argument to [ctor]. *)
118
123
119
-
val return : 'a -> ('o, 'a) field
120
-
(** [return v] produces the final value of the record. *)
121
-
122
-
val finish : ('o, 'o) field -> 'o t
123
-
(** [finish spec] seals a message specification into a codec. *)
124
+
val seal : ('o, 'o) t_ -> 'o t
125
+
(** [seal builder] closes the pipeline into a message codec. *)
124
126
125
127
(** {2 Field declarations} *)
126
128
127
-
val required : int -> ('o -> 'a) -> 'a t -> ('o, 'a) field
128
-
(** [required tag get c] declares a field at the given tag. Proto3 omits it on
129
-
the wire if equal to the scalar default, but decoders accept either
130
-
presence. *)
129
+
val required :
130
+
int -> 'a t -> enc:('o -> 'a) -> ('o, 'a -> 'dec) t_ -> ('o, 'dec) t_
131
+
(** [required tag codec ~enc] declares a field at [tag]. [enc] projects the
132
+
value out of the record for encoding. Proto3 omits the field on the wire
133
+
when it equals the codec's default; decoders accept either presence. *)
131
134
132
-
val optional : int -> ('o -> 'a option) -> 'a t -> ('o, 'a option) field
133
-
(** [optional tag get c] declares a field as [None] if absent, [Some v]
134
-
otherwise. On encode, [None] skips the field entirely. *)
135
+
val optional :
136
+
int ->
137
+
'a t ->
138
+
enc:('o -> 'a option) ->
139
+
('o, 'a option -> 'dec) t_ ->
140
+
('o, 'dec) t_
141
+
(** [optional tag codec ~enc] declares a field that decodes to [None] when
142
+
absent and [Some v] otherwise. On encode, [None] skips the field. *)
135
143
136
-
val repeated : int -> ('o -> 'a list) -> 'a t -> ('o, 'a list) field
137
-
(** [repeated tag get c] declares a non-packed repeated field: each element is
138
-
written as a separate (tag, value) pair, and decode concatenates all
139
-
occurrences of [tag] in wire order. *)
144
+
val repeated :
145
+
int ->
146
+
'a t ->
147
+
enc:('o -> 'a list) ->
148
+
('o, 'a list -> 'dec) t_ ->
149
+
('o, 'dec) t_
150
+
(** [repeated tag codec ~enc] declares a non-packed repeated field: each
151
+
element is written as a separate [(tag, value)] pair, and decode
152
+
concatenates all occurrences of [tag] in wire order. *)
140
153
141
-
val packed : int -> ('o -> 'a list) -> 'a t -> ('o, 'a list) field
142
-
(** [packed tag get c] declares a packed repeated field: all elements are
143
-
concatenated into a single length-delimited blob. Only valid for varint
144
-
and fixed-width codecs; strings and messages cannot be packed.
154
+
val packed :
155
+
int ->
156
+
'a t ->
157
+
enc:('o -> 'a list) ->
158
+
('o, 'a list -> 'dec) t_ ->
159
+
('o, 'dec) t_
160
+
(** [packed tag codec ~enc] declares a packed repeated field: all elements are
161
+
concatenated into one length-delimited blob. Only valid for varint and
162
+
fixed-width codecs; strings and messages cannot be packed.
145
163
146
164
The decoder accepts both packed and non-packed wire forms for the same tag
147
165
(required by the protobuf spec for compatibility). *)
148
166
149
167
val map :
150
-
int -> ('o -> ('k * 'v) list) -> 'k t -> 'v t -> ('o, ('k * 'v) list) field
151
-
(** [map tag get key_codec value_codec] declares a [map<K, V>] field. On the
168
+
int ->
169
+
'k t ->
170
+
'v t ->
171
+
enc:('o -> ('k * 'v) list) ->
172
+
('o, ('k * 'v) list -> 'dec) t_ ->
173
+
('o, 'dec) t_
174
+
(** [map tag key_codec value_codec ~enc] declares a [map<K, V>] field. On the
152
175
wire this is sugar for a repeated nested message with two fields: [key] at
153
176
tag 1 (encoded by [key_codec]) and [value] at tag 2 (encoded by
154
177
[value_codec]). Proto3 map ordering is unspecified on the wire; the
···
169
192
type; [extract] is its inverse, returning [Some] when the oneof value
170
193
matches this case, [None] otherwise. *)
171
194
172
-
val oneof : default:'a -> ('o -> 'a) -> 'a case list -> ('o, 'a) field
173
-
(** [oneof ~default get cases] declares a oneof group: at most one of the
195
+
val oneof :
196
+
default:'a ->
197
+
enc:('o -> 'a) ->
198
+
'a case list ->
199
+
('o, 'a -> 'dec) t_ ->
200
+
('o, 'dec) t_
201
+
(** [oneof ~default ~enc cases] declares a oneof group: at most one of the
174
202
listed cases may be set on the wire.
175
203
176
-
- Encoding: [get o] is called to obtain the current oneof value; the first
177
-
[case] whose [extract] returns [Some x] is emitted. If every [extract]
178
-
returns [None], no tag is written.
204
+
- Encoding: [enc o] obtains the current oneof value; the first [case]
205
+
whose [extract] returns [Some x] is emitted. If every [extract] returns
206
+
[None], no tag is written.
179
207
- Decoding: the case with the highest wire position wins (protobuf "last
180
208
one on the wire" rule for oneofs). If no case appears on the wire,
181
209
[~default] is used. *)
+1
protobuf.opam
+1
protobuf.opam
+67
-48
test/interop/protoc/test.ml
+67
-48
test/interop/protoc/test.ml
···
26
26
27
27
let test1_codec : test1 Protobuf.t =
28
28
let open Protobuf.Message in
29
-
finish
30
-
(let* a = required 1 (fun r -> r.a) Protobuf.int32 in
31
-
return { a })
29
+
v (fun a -> { a }) |> required 1 Protobuf.int32 ~enc:(fun r -> r.a) |> seal
32
30
33
31
type test1_row = { name : string; a : int32; wire_hex : string }
34
32
···
69
67
70
68
let inner_codec : inner Protobuf.t =
71
69
let open Protobuf.Message in
72
-
finish
73
-
(let* inner_x = required 1 (fun r -> r.inner_x) Protobuf.int32 in
74
-
return { inner_x })
70
+
v (fun inner_x -> { inner_x })
71
+
|> required 1 Protobuf.int32 ~enc:(fun r -> r.inner_x)
72
+
|> seal
75
73
76
74
type everything = {
77
75
f_int32 : int32;
···
97
95
98
96
let everything_codec : everything Protobuf.t =
99
97
let open Protobuf.Message in
100
-
finish
101
-
(let* f_int32 = required 1 (fun r -> r.f_int32) Protobuf.int32 in
102
-
let* f_int64 = required 2 (fun r -> r.f_int64) Protobuf.int64 in
103
-
let* f_uint32 = required 3 (fun r -> r.f_uint32) Protobuf.uint32 in
104
-
let* f_uint64 = required 4 (fun r -> r.f_uint64) Protobuf.uint64 in
105
-
let* f_sint32 = required 5 (fun r -> r.f_sint32) Protobuf.sint32 in
106
-
let* f_sint64 = required 6 (fun r -> r.f_sint64) Protobuf.sint64 in
107
-
let* f_fixed32 = required 7 (fun r -> r.f_fixed32) Protobuf.fixed32 in
108
-
let* f_fixed64 = required 8 (fun r -> r.f_fixed64) Protobuf.fixed64 in
109
-
let* f_sfixed32 = required 9 (fun r -> r.f_sfixed32) Protobuf.sfixed32 in
110
-
let* f_sfixed64 = required 10 (fun r -> r.f_sfixed64) Protobuf.sfixed64 in
111
-
let* f_float = required 11 (fun r -> r.f_float) Protobuf.float in
112
-
let* f_double = required 12 (fun r -> r.f_double) Protobuf.double in
113
-
let* f_bool = required 13 (fun r -> r.f_bool) Protobuf.bool in
114
-
let* f_string = required 14 (fun r -> r.f_string) Protobuf.string in
115
-
let* f_bytes = required 15 (fun r -> r.f_bytes) Protobuf.bytes in
116
-
let* opt_name = optional 16 (fun r -> r.opt_name) Protobuf.string in
117
-
let* tags = repeated 17 (fun r -> r.tags) Protobuf.string in
118
-
let* nums = packed 18 (fun r -> r.nums) Protobuf.int32 in
119
-
let* inner = required 19 (fun r -> r.inner) inner_codec in
120
-
return
121
-
{
122
-
f_int32;
123
-
f_int64;
124
-
f_uint32;
125
-
f_uint64;
126
-
f_sint32;
127
-
f_sint64;
128
-
f_fixed32;
129
-
f_fixed64;
130
-
f_sfixed32;
131
-
f_sfixed64;
132
-
f_float;
133
-
f_double;
134
-
f_bool;
135
-
f_string;
136
-
f_bytes;
137
-
opt_name;
138
-
tags;
139
-
nums;
140
-
inner;
141
-
})
98
+
v
99
+
(fun
100
+
f_int32
101
+
f_int64
102
+
f_uint32
103
+
f_uint64
104
+
f_sint32
105
+
f_sint64
106
+
f_fixed32
107
+
f_fixed64
108
+
f_sfixed32
109
+
f_sfixed64
110
+
f_float
111
+
f_double
112
+
f_bool
113
+
f_string
114
+
f_bytes
115
+
opt_name
116
+
tags
117
+
nums
118
+
inner
119
+
->
120
+
{
121
+
f_int32;
122
+
f_int64;
123
+
f_uint32;
124
+
f_uint64;
125
+
f_sint32;
126
+
f_sint64;
127
+
f_fixed32;
128
+
f_fixed64;
129
+
f_sfixed32;
130
+
f_sfixed64;
131
+
f_float;
132
+
f_double;
133
+
f_bool;
134
+
f_string;
135
+
f_bytes;
136
+
opt_name;
137
+
tags;
138
+
nums;
139
+
inner;
140
+
})
141
+
|> required 1 Protobuf.int32 ~enc:(fun r -> r.f_int32)
142
+
|> required 2 Protobuf.int64 ~enc:(fun r -> r.f_int64)
143
+
|> required 3 Protobuf.uint32 ~enc:(fun r -> r.f_uint32)
144
+
|> required 4 Protobuf.uint64 ~enc:(fun r -> r.f_uint64)
145
+
|> required 5 Protobuf.sint32 ~enc:(fun r -> r.f_sint32)
146
+
|> required 6 Protobuf.sint64 ~enc:(fun r -> r.f_sint64)
147
+
|> required 7 Protobuf.fixed32 ~enc:(fun r -> r.f_fixed32)
148
+
|> required 8 Protobuf.fixed64 ~enc:(fun r -> r.f_fixed64)
149
+
|> required 9 Protobuf.sfixed32 ~enc:(fun r -> r.f_sfixed32)
150
+
|> required 10 Protobuf.sfixed64 ~enc:(fun r -> r.f_sfixed64)
151
+
|> required 11 Protobuf.float ~enc:(fun r -> r.f_float)
152
+
|> required 12 Protobuf.double ~enc:(fun r -> r.f_double)
153
+
|> required 13 Protobuf.bool ~enc:(fun r -> r.f_bool)
154
+
|> required 14 Protobuf.string ~enc:(fun r -> r.f_string)
155
+
|> required 15 Protobuf.bytes ~enc:(fun r -> r.f_bytes)
156
+
|> optional 16 Protobuf.string ~enc:(fun r -> r.opt_name)
157
+
|> repeated 17 Protobuf.string ~enc:(fun r -> r.tags)
158
+
|> packed 18 Protobuf.int32 ~enc:(fun r -> r.nums)
159
+
|> required 19 inner_codec ~enc:(fun r -> r.inner)
160
+
|> seal
142
161
143
162
type everything_row = { name : string; values_json : string; wire_hex : string }
144
163
+90
-112
test/test_protobuf.ml
+90
-112
test/test_protobuf.ml
···
14
14
15
15
let test1_codec : test1 Protobuf.t =
16
16
let open Protobuf.Message in
17
-
finish
18
-
(let* a = required 1 (fun r -> r.a) Protobuf.int32 in
19
-
return { a })
17
+
v (fun a -> { a }) |> required 1 Protobuf.int32 ~enc:(fun r -> r.a) |> seal
20
18
21
19
let test_spec_test1 () =
22
20
let wire = Protobuf.to_string test1_codec { a = 150l } in
···
31
29
32
30
let test2_codec : test2 Protobuf.t =
33
31
let open Protobuf.Message in
34
-
finish
35
-
(let* b = required 2 (fun r -> r.b) Protobuf.string in
36
-
return { b })
32
+
v (fun b -> { b }) |> required 2 Protobuf.string ~enc:(fun r -> r.b) |> seal
37
33
38
34
let test_spec_test2 () =
39
35
let wire = Protobuf.to_string test2_codec { b = "testing" } in
···
64
60
65
61
let all_scalars_codec : all_scalars Protobuf.t =
66
62
let open Protobuf.Message in
67
-
finish
68
-
(let* i32 = required 1 (fun r -> r.i32) Protobuf.int32 in
69
-
let* i64 = required 2 (fun r -> r.i64) Protobuf.int64 in
70
-
let* u32 = required 3 (fun r -> r.u32) Protobuf.uint32 in
71
-
let* u64 = required 4 (fun r -> r.u64) Protobuf.uint64 in
72
-
let* s32 = required 5 (fun r -> r.s32) Protobuf.sint32 in
73
-
let* s64 = required 6 (fun r -> r.s64) Protobuf.sint64 in
74
-
let* f32 = required 7 (fun r -> r.f32) Protobuf.fixed32 in
75
-
let* f64 = required 8 (fun r -> r.f64) Protobuf.fixed64 in
76
-
let* sf32 = required 9 (fun r -> r.sf32) Protobuf.sfixed32 in
77
-
let* sf64 = required 10 (fun r -> r.sf64) Protobuf.sfixed64 in
78
-
let* flt = required 11 (fun r -> r.flt) Protobuf.float in
79
-
let* dbl = required 12 (fun r -> r.dbl) Protobuf.double in
80
-
let* bl = required 13 (fun r -> r.bl) Protobuf.bool in
81
-
let* str = required 14 (fun r -> r.str) Protobuf.string in
82
-
let* byts = required 15 (fun r -> r.byts) Protobuf.bytes in
83
-
return
84
-
{
85
-
i32;
86
-
i64;
87
-
u32;
88
-
u64;
89
-
s32;
90
-
s64;
91
-
f32;
92
-
f64;
93
-
sf32;
94
-
sf64;
95
-
flt;
96
-
dbl;
97
-
bl;
98
-
str;
99
-
byts;
100
-
})
63
+
v (fun i32 i64 u32 u64 s32 s64 f32 f64 sf32 sf64 flt dbl bl str byts ->
64
+
{
65
+
i32;
66
+
i64;
67
+
u32;
68
+
u64;
69
+
s32;
70
+
s64;
71
+
f32;
72
+
f64;
73
+
sf32;
74
+
sf64;
75
+
flt;
76
+
dbl;
77
+
bl;
78
+
str;
79
+
byts;
80
+
})
81
+
|> required 1 Protobuf.int32 ~enc:(fun r -> r.i32)
82
+
|> required 2 Protobuf.int64 ~enc:(fun r -> r.i64)
83
+
|> required 3 Protobuf.uint32 ~enc:(fun r -> r.u32)
84
+
|> required 4 Protobuf.uint64 ~enc:(fun r -> r.u64)
85
+
|> required 5 Protobuf.sint32 ~enc:(fun r -> r.s32)
86
+
|> required 6 Protobuf.sint64 ~enc:(fun r -> r.s64)
87
+
|> required 7 Protobuf.fixed32 ~enc:(fun r -> r.f32)
88
+
|> required 8 Protobuf.fixed64 ~enc:(fun r -> r.f64)
89
+
|> required 9 Protobuf.sfixed32 ~enc:(fun r -> r.sf32)
90
+
|> required 10 Protobuf.sfixed64 ~enc:(fun r -> r.sf64)
91
+
|> required 11 Protobuf.float ~enc:(fun r -> r.flt)
92
+
|> required 12 Protobuf.double ~enc:(fun r -> r.dbl)
93
+
|> required 13 Protobuf.bool ~enc:(fun r -> r.bl)
94
+
|> required 14 Protobuf.string ~enc:(fun r -> r.str)
95
+
|> required 15 Protobuf.bytes ~enc:(fun r -> r.byts)
96
+
|> seal
101
97
102
98
let test_all_scalars_roundtrip () =
103
99
let v =
···
145
141
146
142
let opt_codec : opt_msg Protobuf.t =
147
143
let open Protobuf.Message in
148
-
finish
149
-
(let* name = optional 1 (fun r -> r.name) Protobuf.string in
150
-
let* age = optional 2 (fun r -> r.age) Protobuf.int32 in
151
-
return { name; age })
144
+
v (fun name age -> { name; age })
145
+
|> optional 1 Protobuf.string ~enc:(fun r -> r.name)
146
+
|> optional 2 Protobuf.int32 ~enc:(fun r -> r.age)
147
+
|> seal
152
148
153
149
let test_optional_both_present () =
154
150
let v = { name = Some "Ada"; age = Some 36l } in
···
184
180
185
181
let rep_str_codec : rep_str Protobuf.t =
186
182
let open Protobuf.Message in
187
-
finish
188
-
(let* tags = repeated 1 (fun r -> r.tags) Protobuf.string in
189
-
return { tags })
183
+
v (fun tags -> { tags })
184
+
|> repeated 1 Protobuf.string ~enc:(fun r -> r.tags)
185
+
|> seal
190
186
191
187
let test_repeated_strings () =
192
188
let v = { tags = [ "a"; "bb"; "ccc" ] } in
···
201
197
202
198
let packed_codec : packed_ints Protobuf.t =
203
199
let open Protobuf.Message in
204
-
finish
205
-
(let* nums = packed 1 (fun r -> r.nums) Protobuf.int32 in
206
-
return { nums })
200
+
v (fun nums -> { nums })
201
+
|> packed 1 Protobuf.int32 ~enc:(fun r -> r.nums)
202
+
|> seal
207
203
208
204
let test_packed_ints () =
209
205
let v = { nums = [ 1l; 2l; 3l; 150l ] } in
···
219
215
tag. Emit the non-packed form manually: tag 1 varint, 4 times. *)
220
216
let unpacked_codec : packed_ints Protobuf.t =
221
217
let open Protobuf.Message in
222
-
finish
223
-
(let* nums = repeated 1 (fun r -> r.nums) Protobuf.int32 in
224
-
return { nums })
218
+
v (fun nums -> { nums })
219
+
|> repeated 1 Protobuf.int32 ~enc:(fun r -> r.nums)
220
+
|> seal
225
221
in
226
222
let unpacked_wire =
227
223
Protobuf.to_string unpacked_codec { nums = [ 1l; 2l; 3l; 150l ] }
···
236
232
237
233
let inner_codec : inner Protobuf.t =
238
234
let open Protobuf.Message in
239
-
finish
240
-
(let* x = required 1 (fun r -> r.x) Protobuf.int32 in
241
-
return { x })
235
+
v (fun x -> { x }) |> required 1 Protobuf.int32 ~enc:(fun r -> r.x) |> seal
242
236
243
237
type outer = { inner : inner; label : string }
244
238
245
239
let outer_codec : outer Protobuf.t =
246
240
let open Protobuf.Message in
247
-
finish
248
-
(let* inner = required 1 (fun r -> r.inner) inner_codec in
249
-
let* label = required 2 (fun r -> r.label) Protobuf.string in
250
-
return { inner; label })
241
+
v (fun inner label -> { inner; label })
242
+
|> required 1 inner_codec ~enc:(fun r -> r.inner)
243
+
|> required 2 Protobuf.string ~enc:(fun r -> r.label)
244
+
|> seal
251
245
252
246
let test_nested () =
253
247
let v = { inner = { x = 42l }; label = "hi" } in
···
308
302
309
303
let dict_codec : dict Protobuf.t =
310
304
let open Protobuf.Message in
311
-
finish
312
-
(let* entries = map 1 (fun r -> r.entries) Protobuf.string Protobuf.int32 in
313
-
return { entries })
305
+
v (fun entries -> { entries })
306
+
|> map 1 Protobuf.string Protobuf.int32 ~enc:(fun r -> r.entries)
307
+
|> seal
314
308
315
309
let test_map_string_int32 () =
316
310
let v = { entries = [ ("alice", 30l); ("bob", 25l); ("", 0l) ] } in
···
327
321
328
322
let schema_v1 : schema_v1 Protobuf.t =
329
323
let open Protobuf.Message in
330
-
finish
331
-
(let* a = required 1 (fun r -> r.a) Protobuf.int32 in
332
-
return { a })
324
+
v (fun a -> { a }) |> required 1 Protobuf.int32 ~enc:(fun r -> r.a) |> seal
333
325
334
326
type schema_v2 = { a : int32; b : string; c : int32 list }
335
327
336
328
let schema_v2 : schema_v2 Protobuf.t =
337
329
let open Protobuf.Message in
338
-
finish
339
-
(let* a = required 1 (fun r -> r.a) Protobuf.int32 in
340
-
let* b = required 2 (fun r -> r.b) Protobuf.string in
341
-
let* c = packed 3 (fun r -> r.c) Protobuf.int32 in
342
-
return { a; b; c })
330
+
v (fun a b c -> { a; b; c })
331
+
|> required 1 Protobuf.int32 ~enc:(fun r -> r.a)
332
+
|> required 2 Protobuf.string ~enc:(fun r -> r.b)
333
+
|> packed 3 Protobuf.int32 ~enc:(fun r -> r.c)
334
+
|> seal
343
335
344
336
let test_unknown_fields_preserved () =
345
337
(* Encode v2, decode with v1 capturing unknowns, re-encode, assert
···
382
374
383
375
let msg_with_payload_codec : msg_with_payload Protobuf.t =
384
376
let open Protobuf.Message in
385
-
finish
386
-
(let* payload =
387
-
oneof ~default:`None
388
-
(fun r -> r.payload)
389
-
[
390
-
case 1 Protobuf.string
391
-
~inject:(fun s -> `Text s)
392
-
~extract:(function `Text s -> Some s | _ -> None);
393
-
case 2 Protobuf.int32
394
-
~inject:(fun n -> `Num n)
395
-
~extract:(function `Num n -> Some n | _ -> None);
396
-
case 3 Protobuf.bytes
397
-
~inject:(fun b -> `Blob b)
398
-
~extract:(function `Blob b -> Some b | _ -> None);
399
-
]
400
-
in
401
-
return { payload })
377
+
v (fun payload -> { payload })
378
+
|> oneof ~default:`None
379
+
~enc:(fun r -> r.payload)
380
+
[
381
+
case 1 Protobuf.string
382
+
~inject:(fun s -> `Text s)
383
+
~extract:(function `Text s -> Some s | _ -> None);
384
+
case 2 Protobuf.int32
385
+
~inject:(fun n -> `Num n)
386
+
~extract:(function `Num n -> Some n | _ -> None);
387
+
case 3 Protobuf.bytes
388
+
~inject:(fun b -> `Blob b)
389
+
~extract:(function `Blob b -> Some b | _ -> None);
390
+
]
391
+
|> seal
402
392
403
393
let test_oneof_text () =
404
394
let v = { payload = `Text "hello" } in
···
452
442
453
443
let empty_codec : empty_msg Protobuf.t =
454
444
let open Protobuf.Message in
455
-
finish (return ())
445
+
v () |> seal
456
446
457
447
(* =================================================================
458
448
CVE-2015-5237 (protobuf-c++, 2015): integer overflow in varint parser
···
552
542
let nest_codec : unit Protobuf.t =
553
543
Protobuf.fix ~default:() (fun self ->
554
544
let open Protobuf.Message in
555
-
finish
556
-
(let* () =
557
-
(* [optional 1] with payload type that is [self] (a message
558
-
codec). When absent, yields [None]; we collapse to unit
559
-
to keep the test type trivial. *)
560
-
optional 1 (fun () -> None) self |> fun f ->
561
-
let* _v = f in
562
-
return ()
563
-
in
564
-
return ()))
545
+
(* [optional 1] with payload type that is [self] (a message codec).
546
+
When absent, yields [None]; we collapse to unit to keep the test
547
+
type trivial. *)
548
+
v (fun _ -> ()) |> optional 1 self ~enc:(fun () -> None) |> seal)
565
549
in
566
550
let rec build_wire n =
567
551
if n = 0 then ""
···
606
590
let test_cve47554_packed_bad () =
607
591
let packed_codec =
608
592
let open Protobuf.Message in
609
-
finish
610
-
(let* nums =
611
-
Protobuf.Message.packed 1
612
-
(fun (nums : int32 list) -> nums)
613
-
Protobuf.int32
614
-
in
615
-
return nums)
593
+
v (fun (nums : int32 list) -> nums)
594
+
|> packed 1 Protobuf.int32 ~enc:(fun (nums : int32 list) -> nums)
595
+
|> seal
616
596
in
617
597
(* Tag 1, wire 2, length 2, then \x80\x80 (unterminated varint inside
618
598
the packed blob). *)
···
682
662
683
663
let with_str_codec : with_str Protobuf.t =
684
664
let open Protobuf.Message in
685
-
finish
686
-
(let* s = required 1 (fun r -> r.s) Protobuf.string in
687
-
return { s })
665
+
v (fun s -> { s }) |> required 1 Protobuf.string ~enc:(fun r -> r.s) |> seal
688
666
689
667
let test_non_utf8_string_accepted () =
690
668
let raw = "\xff\xfe\xfd" in
···
722
700
723
701
let rep_codec : rep Protobuf.t =
724
702
let open Protobuf.Message in
725
-
finish
726
-
(let* tags = repeated 1 (fun r -> r.tags) Protobuf.string in
727
-
return { tags })
703
+
v (fun tags -> { tags })
704
+
|> repeated 1 Protobuf.string ~enc:(fun r -> r.tags)
705
+
|> seal
728
706
729
707
let test_many_repeated () =
730
708
let n = 10_000 in