├── dune ├── dune-project ├── pkg └── pkg.ml ├── src_test ├── protoc_inner.ml ├── test_ppx_protobuf.ml ├── dune ├── protoc_outer.ml ├── test_protoc.ml ├── test_wire.ml └── test_syntax.ml ├── .gitignore ├── .npmignore ├── descr ├── dune-workspace.dev ├── bsconfig.json ├── src ├── dune ├── protobuf.mli ├── protobuf.ml └── ppx_deriving_protobuf.cppo.ml ├── Makefile ├── package.json ├── ppx_deriving_protobuf.opam ├── LICENSE.txt ├── CHANGELOG.md └── README.md /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags -w -9))) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name ppx_deriving_protobuf) 3 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #use "topfind" 2 | #require "topkg-jbuilder.auto" 3 | -------------------------------------------------------------------------------- /src_test/protoc_inner.ml: -------------------------------------------------------------------------------- 1 | type foo = int 2 | [@@deriving protobuf { protoc }] 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.native 2 | *.byte 3 | *.docdir 4 | _build 5 | *.install 6 | pkg/META 7 | .merlin 8 | -------------------------------------------------------------------------------- /.npmignore: -------------------------------------------------------------------------------- 1 | pkg 2 | src_test 3 | ppx_deriving_protobuf.opam 4 | jbuild-workspace.dev 5 | descr 6 | myocamlbuild.ml 7 | .travis.yml 8 | Makefile 9 | -------------------------------------------------------------------------------- /descr: -------------------------------------------------------------------------------- 1 | Protocol Buffers codec generator for OCaml 2 | 3 | ppx_deriving_protobuf is a ppx_deriving plugin that provides 4 | a Protocol Buffers codec generator. 5 | -------------------------------------------------------------------------------- /src_test/test_ppx_protobuf.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let suite = "Test ppx_protobuf" >::: [ 4 | Test_wire.suite; 5 | Test_syntax.suite; 6 | Test_protoc.suite; 7 | ] 8 | 9 | let _ = 10 | run_test_tt_main suite 11 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | ;; This file is used by `make all-supported-ocaml-versions` 3 | (context (opam (switch 4.04.2))) 4 | (context (opam (switch 4.05.0))) 5 | (context (opam (switch 4.06.1))) 6 | (context (opam (switch 4.07.1))) 7 | -------------------------------------------------------------------------------- /bsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "bs-ppx_deriving_protobuf", 3 | "sources": { 4 | "dir": "src", 5 | "public": ["Protobuf"], 6 | "files": [ 7 | "protobuf.mli", 8 | "protobuf.ml" 9 | ] 10 | }, 11 | "generate-merlin": false 12 | } 13 | -------------------------------------------------------------------------------- /src_test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_ppx_protobuf) 3 | (libraries str uint ounit2) 4 | (preprocess 5 | (pps ppx_deriving_protobuf))) 6 | 7 | (alias 8 | (name runtest) 9 | (deps 10 | (:< test_ppx_protobuf.exe)) 11 | (action 12 | (run %{<}))) 13 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (deps 3 | (:< ppx_deriving_protobuf.cppo.ml)) 4 | (targets ppx_deriving_protobuf.ml) 5 | (action 6 | (run %{bin:cppo} -V OCAML:%{ocaml_version} %{<} -o %{targets}))) 7 | 8 | (library 9 | (name protobuf) 10 | (public_name ppx_deriving_protobuf.runtime) 11 | (synopsis "Low-level Protocol Buffers codec") 12 | (modules protobuf)) 13 | 14 | (library 15 | (name ppx_deriving_protobuf) 16 | (public_name ppx_deriving_protobuf) 17 | (synopsis "[@@deriving protobuf]") 18 | (libraries ppxlib ppx_deriving.api) 19 | (preprocess (pps ppxlib.metaquot)) 20 | (ppx_runtime_libraries ppx_deriving_protobuf.runtime) 21 | (modules ppx_deriving_protobuf) 22 | (kind ppx_deriver)) 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | dune build 3 | 4 | test: 5 | dune runtest 6 | 7 | doc: 8 | dune build @doc 9 | 10 | clean: 11 | dune clean 12 | 13 | .PHONY: build test doc clean 14 | 15 | VERSION := $$(opam query --version) 16 | NAME_VERSION := $$(opam query --name-version) 17 | ARCHIVE := $$(opam query --archive) 18 | 19 | release: 20 | git tag -a v$(VERSION) -m "Version $(VERSION)." 21 | git push origin v$(VERSION) 22 | opam publish prepare $(NAME_VERSION) $(ARCHIVE) 23 | opam publish submit $(NAME_VERSION) 24 | rm -rf $(NAME_VERSION) 25 | 26 | .PHONY: gh-pages release all-supported-ocaml-versions 27 | 28 | all-supported-ocaml-versions: 29 | dune build @install @runtest --workspace dune-workspace 30 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "bs-ppx_deriving_protobuf", 3 | "version": "2.6.0", 4 | "description": "A Protocol Buffers codec generator for OCaml >=4.02", 5 | "keywords": ["protobuf", "serialization", "syntax", "bucklescript"], 6 | "homepage": "https://github.com/whitequark/ppx_deriving_protobuf", 7 | "bugs": "https://github.com/whitequark/ppx_deriving_protobuf/issues", 8 | "license": "MIT", 9 | "author": " whitequark ", 10 | "main": "lib/src/protobuf.js", 11 | "repository" : { 12 | "type": "git", 13 | "url": "https://github.com/whitequark/ppx_deriving_protobuf" 14 | }, 15 | "devDependencies": { 16 | "bs-platform": "^1.5.0" 17 | }, 18 | 19 | "peerDependencies": { 20 | "bs-platform": "^1.5.0" 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /ppx_deriving_protobuf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "3.0.0" 3 | maintainer: "whitequark " 4 | authors: [ "whitequark " ] 5 | license: "MIT" 6 | homepage: "https://github.com/ocaml-ppx/ppx_deriving_protobuf" 7 | doc: "https://ocaml-ppx.github.io/ppx_deriving_protobuf" 8 | bug-reports: "https://github.com/ocaml-ppx/ppx_deriving_protobuf/issues" 9 | dev-repo: "git+https://github.com/ocaml-ppx/ppx_deriving_protobuf.git" 10 | tags: [ "syntax" ] 11 | build: [ 12 | ["dune" "subst"] {dev} 13 | ["dune" "build" "-p" name "-j" jobs] 14 | ] 15 | run-test: [ 16 | ["dune" "runtest" "-p" name "-j" jobs] 17 | ] 18 | depends: [ 19 | "ocaml" {>= "4.05"} 20 | "dune" {>= "1.0"} 21 | "cppo" {build} 22 | "ppx_deriving" {>= "5.2.1"} 23 | "ppxlib" {>= "0.20.0"} 24 | "ounit2" {with-test} 25 | "uint" {with-test} 26 | ] 27 | synopsis: "A Protocol Buffers codec generator for OCaml" 28 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 whitequark 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 3.0.0 2 | ----- 3 | 4 | * Add support for OCaml 4.11 (#36) 5 | (Thierry Martinez, review by Gabriel Scherer) 6 | * Add support for OCaml 4.12 (#39) 7 | (Kate Deplaix, review by Gabriel Scherer) 8 | * Port to ppx_deriving 5.0 and ppxlib (#39) 9 | (Kate Deplaix, review by Gabriel Scherer) 10 | * Upgrade the tests from ounit to ounit2 (#39) 11 | (Kate Deplaix, review by Gabriel Scherer) 12 | 13 | 2.7 14 | --- 15 | 16 | * port to dune 17 | (whitequark) 18 | * support for OCaml 4.08 (#26) 19 | (Anton Kochkov, review by Gabriel Scherer) 20 | 21 | 2.6 22 | --- 23 | 24 | * Support for NPM packaging (#17) 25 | (Maxime Rasan) 26 | * Fix `varint` decoding (#18) 27 | (There was a decoding bug for integers between 2^56 and 2^63) 28 | (Maxime Rasan) 29 | * Support for OCaml 4.06 (#19) 30 | (Gabriel Scherer) 31 | 32 | The homepage for the project has now moved to: 33 | 34 | 35 | 2.5 36 | --- 37 | * Compatibility with statically linked ppx drivers. 38 | 39 | 2.4 40 | --- 41 | 42 | * OCaml 4.03.0 compatibility. 43 | 44 | 2.3 45 | --- 46 | 47 | * Add support for exporting `.protoc` files. 48 | * Add support for hygiene. 49 | * Fix several bugs related to edge cases in serializing and deserializing 50 | integers. 51 | 52 | 2.2 53 | --- 54 | 55 | * Update to accomodate syntactic changes in OCaml 4.02.2. 56 | 57 | 2.1 58 | --- 59 | 60 | * Update for _ppx_deriving_ 2.0. 61 | 62 | 2.0 63 | --- 64 | 65 | * Update to accomodate syntactic changes in _ppx_deriving_ 1.0. 66 | 67 | 1.0.0 68 | ----- 69 | 70 | * First stable release and initial release as _ppx_deriving_protobuf_. 71 | -------------------------------------------------------------------------------- /src_test/protoc_outer.ml: -------------------------------------------------------------------------------- 1 | let () = Protobuf.(()) (* ocamldep *) 2 | 3 | type m1 = { 4 | f1: bool [@key 1] ; 5 | f2: int [@key 2] [@encoding `varint]; 6 | f3: int [@key 3] [@encoding `zigzag]; 7 | f4: int [@key 4] [@encoding `bits32]; 8 | f5: int [@key 5] [@encoding `bits64]; 9 | f6: Int32.t [@key 6] [@encoding `varint]; 10 | f7: Int32.t [@key 7] [@encoding `zigzag]; 11 | f8: Int32.t [@key 8] [@encoding `bits32]; 12 | f9: Int32.t [@key 9] [@encoding `bits64]; 13 | f10: Int64.t [@key 10] [@encoding `varint]; 14 | f11: Int64.t [@key 11] [@encoding `zigzag]; 15 | f12: Int64.t [@key 12] [@encoding `bits32]; 16 | f13: Int64.t [@key 13] [@encoding `bits64]; 17 | f14: Uint32.t [@key 14] [@encoding `varint]; 18 | f15: Uint32.t [@key 15] [@encoding `zigzag]; 19 | f16: Uint32.t [@key 16] [@encoding `bits32]; 20 | f17: Uint32.t [@key 17] [@encoding `bits64]; 21 | f18: Uint64.t [@key 18] [@encoding `varint]; 22 | f19: Uint64.t [@key 19] [@encoding `zigzag]; 23 | f20: Uint64.t [@key 20] [@encoding `bits32]; 24 | f21: Uint64.t [@key 21] [@encoding `bits64]; 25 | f22: float [@key 22] [@encoding `bits32]; 26 | f23: float [@key 23] [@encoding `bits64]; 27 | f24: string [@key 24] ; 28 | f25: bytes [@key 25] ; 29 | f26: int option [@key 26] ; 30 | f27: int list [@key 27] ; 31 | f28: int array [@key 28] [@packed]; 32 | } 33 | [@@deriving protobuf { protoc }] 34 | 35 | type m2 = 36 | | A [@key 1] 37 | | B of int [@key 2] 38 | | C of (int * int) [@key 3] 39 | [@@deriving protobuf { protoc }] 40 | 41 | type m3 = 42 | | D [@key 1] 43 | | E [@key 2] 44 | [@@deriving protobuf { protoc }] 45 | 46 | type m4 = { 47 | f1: m3 [@key 1] ; 48 | f2: m3 [@key 2] [@bare]; 49 | f3: [`A [@key 1]] [@key 3] ; 50 | f4: [`A [@key 1]] [@key 4] [@bare]; 51 | } 52 | [@@deriving protobuf { protoc }] 53 | 54 | type m5 = { 55 | f1: bool [@key 1] [@default true]; 56 | f2: bool [@key 2] [@default false]; 57 | f3: int [@key 3] [@default 42]; 58 | f4: string [@key 4] [@default "foo\"\nй"]; 59 | f5: bytes [@key 5] [@default Bytes.of_string "foo\"\nй"]; 60 | f6: [`A [@key 1]] [@key 6] [@default `A] [@bare]; 61 | f7: m3 [@key 7] [@default D] [@bare]; 62 | } 63 | [@@deriving protobuf { protoc }] 64 | 65 | type m6 = Protoc_inner.foo 66 | [@@deriving protobuf { protoc }] 67 | 68 | module Mod = struct 69 | type foo = int [@@deriving protobuf { protoc }] 70 | end 71 | 72 | type m7 = Mod.foo 73 | [@@deriving protobuf { protoc; protoc_import = ["Protoc_outer.Mod.protoc"] }] 74 | 75 | 76 | -------------------------------------------------------------------------------- /src_test/test_protoc.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let () = Protoc_outer.(()) 4 | 5 | let test_protoc ctxt = 6 | let read filename = 7 | let path = Filename.concat (Filename.dirname Sys.executable_name) filename in 8 | let file = open_in path in 9 | let contents = really_input_string file (in_channel_length file) in 10 | close_in file; 11 | Str.global_replace (Str.regexp " +$") "" contents 12 | in 13 | let actual_protoc_outer = read "Protoc_outer.protoc" 14 | and actual_protoc_outer_mod = read "Protoc_outer.Mod.protoc" 15 | and actual_protoc_inner = read "Protoc_inner.protoc" 16 | in 17 | let expected_protoc_outer = 18 | {|// protoc file autogenerated from OCaml type definitions 19 | package Protoc_outer; 20 | 21 | // src_test/protoc_outer.ml:3 22 | message m1 { 23 | required bool f1 = 1; 24 | required int64 f2 = 2; 25 | required sint64 f3 = 3; 26 | required sfixed32 f4 = 4; 27 | required sfixed64 f5 = 5; 28 | required int32 f6 = 6; 29 | required sint32 f7 = 7; 30 | required sfixed32 f8 = 8; 31 | required sfixed64 f9 = 9; 32 | required int64 f10 = 10; 33 | required sint64 f11 = 11; 34 | required sfixed32 f12 = 12; 35 | required sfixed64 f13 = 13; 36 | required uint32 f14 = 14; 37 | required sint32 f15 = 15; 38 | required sfixed32 f16 = 16; 39 | required sfixed64 f17 = 17; 40 | required uint64 f18 = 18; 41 | required sint64 f19 = 19; 42 | required sfixed32 f20 = 20; 43 | required sfixed64 f21 = 21; 44 | required float f22 = 22; 45 | required double f23 = 23; 46 | required string f24 = 24; 47 | required bytes f25 = 25; 48 | optional int64 f26 = 26; 49 | repeated int64 f27 = 27; 50 | repeated int64 f28 = 28 [packed=true]; 51 | } 52 | 53 | // src_test/protoc_outer.ml:35 54 | message m2 { 55 | enum _tag { 56 | A_tag = 1; 57 | B_tag = 2; 58 | C_tag = 3; 59 | } 60 | 61 | // src_test/protoc_outer.ml:39 62 | message _C { 63 | required int64 _0 = 1; 64 | required int64 _1 = 2; 65 | } 66 | 67 | required _tag tag = 1; 68 | oneof value { 69 | int64 B = 3; 70 | _C C = 4; 71 | } 72 | } 73 | 74 | // src_test/protoc_outer.ml:41 75 | message m3 { 76 | enum _tag { 77 | D_tag = 1; 78 | E_tag = 2; 79 | } 80 | 81 | required _tag tag = 1; 82 | } 83 | 84 | // src_test/protoc_outer.ml:46 85 | message m4 { 86 | // src_test/protoc_outer.ml:52 87 | message _f3 { 88 | enum _tag { 89 | A_tag = 1; 90 | } 91 | 92 | required _tag tag = 1; 93 | } 94 | 95 | // src_test/protoc_outer.ml:52 96 | message _f4 { 97 | enum _tag { 98 | A_tag = 1; 99 | } 100 | 101 | required _tag tag = 1; 102 | } 103 | 104 | required m3 f1 = 1; 105 | required m3._tag f2 = 2; 106 | required _f3 f3 = 3; 107 | required _f4._tag f4 = 4; 108 | } 109 | 110 | // src_test/protoc_outer.ml:54 111 | message m5 { 112 | // src_test/protoc_outer.ml:63 113 | message _f6 { 114 | enum _tag { 115 | A_tag = 1; 116 | } 117 | 118 | required _tag tag = 1; 119 | } 120 | 121 | required bool f1 = 1 [default=true]; 122 | required bool f2 = 2 [default=false]; 123 | required int64 f3 = 3 [default=42]; 124 | required string f4 = 4 [default="foo\"\x0aй"]; 125 | required bytes f5 = 5 [default="foo\"\x0a\xd0\xb9"]; 126 | required _f6._tag f6 = 6 [default=A_tag]; 127 | required m3._tag f7 = 7 [default=D_tag]; 128 | } 129 | 130 | // src_test/protoc_outer.ml:65 131 | import "Protoc_inner.protoc"; 132 | message m6 { 133 | required Protoc_inner.foo _ = 1; 134 | } 135 | 136 | // src_test/protoc_outer.ml:72 137 | import "Protoc_outer.Mod.protoc"; 138 | message m7 { 139 | required Mod.foo _ = 1; 140 | } 141 | |} 142 | and expected_protoc_outer_mod = 143 | {|// protoc file autogenerated from OCaml type definitions 144 | package Protoc_outer.Mod; 145 | 146 | // src_test/protoc_outer.ml:69 147 | message foo { 148 | required int64 _ = 1; 149 | } 150 | |} 151 | and expected_protoc_inner = 152 | {|// protoc file autogenerated from OCaml type definitions 153 | package Protoc_inner; 154 | 155 | // src_test/protoc_inner.ml:1 156 | message foo { 157 | required int64 _ = 1; 158 | } 159 | |} 160 | in 161 | assert_equal ~printer:(fun s -> s) actual_protoc_outer expected_protoc_outer; 162 | assert_equal ~printer:(fun s -> s) actual_protoc_outer_mod expected_protoc_outer_mod; 163 | assert_equal ~printer:(fun s -> s) actual_protoc_inner expected_protoc_inner 164 | 165 | let suite = "Test protoc" >:: test_protoc 166 | -------------------------------------------------------------------------------- /src_test/test_wire.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Protobuf 3 | 4 | let test_decoder ctxt = 5 | let d = Decoder.of_bytes (Bytes.of_string "\x01") in 6 | assert_equal ~printer:Int64.to_string 1L (Decoder.varint d); 7 | let d = Decoder.of_string "\xac\x02" in 8 | assert_equal ~printer:Int64.to_string 300L (Decoder.varint d); 9 | let d = Decoder.of_string "\x01\x02\x03\x04" in 10 | assert_equal ~printer:Int32.to_string 0x04030201l (Decoder.bits32 d); 11 | let d = Decoder.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" in 12 | assert_equal ~printer:Int64.to_string 0x0807060504030201L (Decoder.bits64 d); 13 | let d = Decoder.of_string "\x03abc" in 14 | assert_equal ~printer:(fun x -> Bytes.to_string x) 15 | (Bytes.of_string "abc") (Decoder.bytes d); 16 | assert_raises Decoder.(Failure Incomplete) (fun () -> Decoder.varint d); 17 | let d = Decoder.of_string "\x02\xac\x02" in 18 | let d' = Decoder.nested d in 19 | assert_equal ~printer:Int64.to_string 300L (Decoder.varint d'); 20 | assert_raises Decoder.(Failure Incomplete) (fun () -> Decoder.varint d'); 21 | assert_raises Decoder.(Failure Incomplete) (fun () -> Decoder.varint d); 22 | let d = Decoder.of_string "\x08\x11\x1a\x25" in 23 | assert_equal (Some (1, Varint)) (Decoder.key d); 24 | assert_equal (Some (2, Bits64)) (Decoder.key d); 25 | assert_equal (Some (3, Bytes)) (Decoder.key d); 26 | assert_equal (Some (4, Bits32)) (Decoder.key d); 27 | assert_equal None (Decoder.key d); 28 | let d = Decoder.of_string "\x15\x00\x00\xC0\x3f\x01" in 29 | assert_equal (Some (2, Bits32)) (Decoder.key d); 30 | Decoder.skip d Bits32; 31 | assert_equal ~printer:Int64.to_string 1L (Decoder.varint d); 32 | let d = Decoder.of_string "\x00" in 33 | assert_equal ~printer:Int64.to_string 0L (Decoder.zigzag d); 34 | let d = Decoder.of_string "\x01" in 35 | assert_equal ~printer:Int64.to_string (-1L) (Decoder.zigzag d); 36 | let d = Decoder.of_string "\x02" in 37 | assert_equal ~printer:Int64.to_string 1L (Decoder.zigzag d); 38 | let d = Decoder.of_string "\x03" in 39 | assert_equal ~printer:Int64.to_string (-2L) (Decoder.zigzag d); 40 | let d = Decoder.of_string "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01" in 41 | assert_equal ~printer:Int64.to_string 0xffffffffffffffffL (Decoder.varint d); 42 | let d = Decoder.of_string "\x80\x80\x80\x80\x80\x80\x80\x80\x03" in 43 | assert_equal ~printer:Int64.to_string Int64.(shift_left 3L 56) (Decoder.varint d); 44 | let d = Decoder.of_string "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02" in 45 | assert_raises (Decoder.Failure Decoder.Overlong_varint) 46 | (fun () -> Decoder.varint d); 47 | () 48 | 49 | let test_encoder ctxt = 50 | let printer s = Printf.sprintf "%S" s in 51 | let e = Encoder.create () in 52 | Encoder.varint 1L e; 53 | assert_equal ~printer "\x01" (Bytes.to_string (Encoder.to_bytes e)); 54 | let e = Encoder.create () in 55 | Encoder.varint 300L e; 56 | assert_equal ~printer "\xac\x02" (Encoder.to_string e); 57 | let e = Encoder.create () in 58 | Encoder.bits32 0x04030201l e; 59 | assert_equal ~printer "\x01\x02\x03\x04" (Encoder.to_string e); 60 | let e = Encoder.create () in 61 | Encoder.bits64 0x0807060504030201L e; 62 | assert_equal ~printer "\x01\x02\x03\x04\x05\x06\x07\x08" (Encoder.to_string e); 63 | let e = Encoder.create () in 64 | Encoder.bytes (Bytes.of_string "abc") e; 65 | assert_equal ~printer "\x03abc" (Encoder.to_string e); 66 | let e = Encoder.create () in 67 | Encoder.nested (Encoder.varint 300L) e; 68 | assert_equal ~printer "\x02\xac\x02" (Encoder.to_string e); 69 | let e = Encoder.create () in 70 | Encoder.key (1, Varint) e; 71 | Encoder.key (2, Bits64) e; 72 | Encoder.key (3, Bytes) e; 73 | Encoder.key (4, Bits32) e; 74 | assert_equal ~printer "\x08\x11\x1a\x25" (Encoder.to_string e); 75 | let e = Encoder.create () in 76 | Encoder.zigzag 0L e; 77 | assert_equal ~printer "\x00" (Encoder.to_string e); 78 | let e = Encoder.create () in 79 | Encoder.zigzag (-1L) e; 80 | assert_equal ~printer "\x01" (Encoder.to_string e); 81 | let e = Encoder.create () in 82 | Encoder.zigzag 1L e; 83 | assert_equal ~printer "\x02" (Encoder.to_string e); 84 | let e = Encoder.create () in 85 | Encoder.zigzag (-2L) e; 86 | assert_equal ~printer "\x03" (Encoder.to_string e); 87 | let e = Encoder.create () in 88 | Encoder.varint 0xffffffffffffffffL e; 89 | assert_equal ~printer "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01" (Encoder.to_string e); 90 | () 91 | 92 | let test_overflow ctxt = 93 | if Sys.word_size = 32 then 94 | assert_raises Decoder.(Failure (Overflow "")) 95 | (fun () -> Decoder.int_of_int32 "" 0x7fffffffl) 96 | else 97 | assert_equal (-1) (Decoder.int_of_int32 "" 0xffffffffl); 98 | assert_raises Decoder.(Failure (Overflow "")) 99 | (fun () -> Decoder.int_of_int64 "" 0x7fffffffffffffffL); 100 | assert_raises Decoder.(Failure (Overflow "")) 101 | (fun () -> Decoder.int32_of_int64 "" 0x1ffffffffL); 102 | assert_raises Decoder.(Failure (Overflow "")) 103 | (fun () -> Decoder.bool_of_int64 "" 2L); 104 | if Sys.word_size = 64 then 105 | assert_raises Encoder.(Failure (Overflow "")) 106 | (fun () -> Encoder.int32_of_int "" (2 lsl 33)); 107 | assert_raises Encoder.(Failure (Overflow "")) 108 | (fun () -> Encoder.int32_of_int64 "" 0x1ffffffffL); 109 | () 110 | 111 | let test_truncate ctxt = 112 | assert_equal (-1) (Decoder.int_of_int64 "" (-1L)) 113 | 114 | let suite = "Test wire format" >::: [ 115 | "test_decoder" >:: test_decoder; 116 | "test_encoder" >:: test_encoder; 117 | "test_overflow" >:: test_overflow; 118 | "test_truncate" >:: test_truncate; 119 | ] 120 | -------------------------------------------------------------------------------- /src/protobuf.mli: -------------------------------------------------------------------------------- 1 | (** Low-level Protobuf codec *) 2 | 3 | (** Type of wire format payload kinds. *) 4 | type payload_kind = 5 | | Varint 6 | | Bits32 7 | | Bits64 8 | | Bytes 9 | 10 | module Decoder : sig 11 | (** Type of failures possible while decoding. *) 12 | type error = 13 | | Incomplete 14 | | Overlong_varint 15 | | Malformed_field 16 | | Overflow of string 17 | | Unexpected_payload of string * payload_kind 18 | | Missing_field of string 19 | | Malformed_variant of string 20 | 21 | (** [error_to_string e] converts error [e] to its string representation. *) 22 | val error_to_string : error -> string 23 | 24 | exception Failure of error 25 | 26 | (** Type of wire format decoders. *) 27 | type t 28 | 29 | (** [of_bytes b] creates a decoder positioned at start of bytes [b]. *) 30 | val of_bytes : bytes -> t 31 | 32 | (** [of_string s] creates a decoder positioned at start of string [s]. *) 33 | val of_string : string -> t 34 | 35 | (** [at_end d] returns [true] if [d] has exhausted its input, and [false] 36 | otherwise. *) 37 | val at_end : t -> bool 38 | 39 | (** [skip d pk] skips the next value of kind [pk] in [d]. 40 | If skipping the value would exhaust input of [d], raises 41 | [Encoding_error Incomplete]. *) 42 | val skip : t -> payload_kind -> unit 43 | 44 | (** [varint d] reads a varint from [d]. 45 | If [d] has exhausted its input, raises [Failure Incomplete]. *) 46 | val varint : t -> int64 47 | 48 | (** [zigzag d] reads a varint from [d] and zigzag-decodes it. 49 | If [d] has exhausted its input, raises [Failure Incomplete]. *) 50 | val zigzag : t -> int64 51 | 52 | (** [bits32 d] reads four bytes from [d]. 53 | If [d] has exhausted its input, raises [Failure Incomplete]. *) 54 | val bits32 : t -> int32 55 | 56 | (** [bits64 d] reads eight bytes from [d]. 57 | If [d] has exhausted its input, raises [Failure Incomplete]. *) 58 | val bits64 : t -> int64 59 | 60 | (** [bytes d] reads a varint indicating length and then that much 61 | bytes from [d]. 62 | If [d] has exhausted its input, raises [Failure Incomplete]. *) 63 | val bytes : t -> bytes 64 | 65 | (** [nested d] returns a decoder for a message nested in [d]. 66 | If reading the message would exhaust input of [d], raises 67 | [Failure Incomplete]. *) 68 | val nested : t -> t 69 | 70 | (** [key d] reads a key and a payload kind from [d]. 71 | If [d] has exhausted its input when the function is called, returns [None]. 72 | If [d] has exhausted its input while reading, raises 73 | [Failure Incomplete]. 74 | If the payload kind is unknown, raises [Failure Malformed_field]. *) 75 | val key : t -> (int * payload_kind) option 76 | 77 | (** [decode_exn f b] ≡ [f (create b)]. *) 78 | val decode_exn : (t -> 'a) -> bytes -> 'a 79 | 80 | (** [decode f b] ≡ [try Some (decode_exn f b) with Failure _ -> None] *) 81 | val decode : (t -> 'a) -> bytes -> 'a option 82 | 83 | (** [int_of_int32 fld v] returns [v] truncated to [int]. 84 | If the value doesn't fit in the range of [int], raises 85 | [Failure (Overflow fld)]. *) 86 | val int_of_int32 : string -> int32 -> int 87 | 88 | (** [int_of_int64 fld v] returns [v] truncated to [int]. 89 | If the value doesn't fit in the range of [int], raises 90 | [Failure (Overflow fld)]. *) 91 | val int_of_int64 : string -> int64 -> int 92 | 93 | (** [int32_of_int64 fld v] returns [v] truncated to [int32]. 94 | If the value doesn't fit in the range of [int32], raises 95 | [Failure (Overflow fld)]. *) 96 | val int32_of_int64 : string -> int64 -> int32 97 | 98 | (** [bool_of_int64 fld v] returns [v] truncated to [bool]. 99 | If the value doesn't fit in the range of [bool], raises 100 | [Failure (Overflow fld)]. *) 101 | val bool_of_int64 : string -> int64 -> bool 102 | end 103 | 104 | module Encoder : sig 105 | (** Type of failures possible while encoding. *) 106 | type error = 107 | | Overflow of string 108 | 109 | (** [error_to_string e] converts error [e] to its string representation. *) 110 | val error_to_string : error -> string 111 | 112 | exception Failure of error 113 | 114 | (** Type of wire format encoders. *) 115 | type t 116 | 117 | (** [create ()] creates a new encoder. *) 118 | val create : unit -> t 119 | 120 | (** [to_string e] converts the message assembled in [e] to a string. *) 121 | val to_string : t -> string 122 | 123 | (** [to_bytes e] converts the message assembled in [e] to bytes. *) 124 | val to_bytes : t -> bytes 125 | 126 | (** [varint i e] writes a varint [i] to [e]. *) 127 | val varint : int64 -> t -> unit 128 | 129 | (** [zigzag i e] zigzag-encodes a varint [i] and writes it to [e]. *) 130 | val zigzag : int64 -> t -> unit 131 | 132 | (** [bits32 i e] writes four bytes of [i] to [e]. *) 133 | val bits32 : int32 -> t -> unit 134 | 135 | (** [bits64 i e] writes eight bytes of [i] to [e]. *) 136 | val bits64 : int64 -> t -> unit 137 | 138 | (** [bytes b e] writes a varint indicating length of [b] and then 139 | [b] to [e]. *) 140 | val bytes : bytes -> t -> unit 141 | 142 | (** [nested f e] applies [f] to an encoder for a message nested in [e]. *) 143 | val nested : (t -> unit) -> t -> unit 144 | 145 | (** [key (k, pk) e] writes a key and a payload kind to [e]. *) 146 | val key : (int * payload_kind) -> t -> unit 147 | 148 | (** [encode_exn f x] ≡ [let e = create () in f x e; to_bytes f]. *) 149 | val encode_exn : ('a -> t -> unit) -> 'a -> bytes 150 | 151 | (** [encode f x] ≡ [try Some (encode_exn f x) with Failure _ -> None]. *) 152 | val encode : ('a -> t -> unit) -> 'a -> bytes option 153 | 154 | (** [int32_of_int fld v] returns [v] truncated to [int32]. 155 | If the value doesn't fit in the range of [int32], raises 156 | [Failure (Overflow fld)]. *) 157 | val int32_of_int : string -> int -> int32 158 | 159 | (** [int32_of_int64 fld v] returns [v] truncated to [int32]. 160 | If the value doesn't fit in the range of [int32], raises 161 | [Failure (Overflow fld)]. *) 162 | val int32_of_int64 : string -> int64 -> int32 163 | end 164 | -------------------------------------------------------------------------------- /src/protobuf.ml: -------------------------------------------------------------------------------- 1 | type payload_kind = 2 | | Varint 3 | | Bits32 4 | | Bits64 5 | | Bytes 6 | 7 | let min_int_as_int32, max_int_as_int32 = Int32.of_int min_int, Int32.of_int max_int 8 | let min_int_as_int64, max_int_as_int64 = Int64.of_int min_int, Int64.of_int max_int 9 | let min_int32_as_int64, max_int32_as_int64 = 10 | Int64.of_int32 Int32.min_int, Int64.of_int32 Int32.max_int 11 | let min_int32_as_int, max_int32_as_int = 12 | if Sys.word_size = 64 then Int32.to_int Int32.min_int, Int32.to_int Int32.max_int 13 | else 0, 0 14 | 15 | module Decoder = struct 16 | type error = 17 | | Incomplete 18 | | Overlong_varint 19 | | Malformed_field 20 | | Overflow of string 21 | | Unexpected_payload of string * payload_kind 22 | | Missing_field of string 23 | | Malformed_variant of string 24 | 25 | let error_to_string e = 26 | match e with 27 | | Incomplete -> "Incomplete" 28 | | Overlong_varint -> "Overlong_varint" 29 | | Malformed_field -> "Malformed_field" 30 | | Overflow fld -> 31 | Printf.sprintf "Overflow(%S)" fld 32 | | Unexpected_payload (field, kind) -> 33 | let kind' = 34 | match kind with 35 | | Varint -> "Varint" 36 | | Bits32 -> "Bits32" 37 | | Bits64 -> "Bits64" 38 | | Bytes -> "Bytes" 39 | in 40 | Printf.sprintf "Unexpected_payload(%S, %s)" field kind' 41 | | Missing_field field -> 42 | Printf.sprintf "Missing_field(%S)" field 43 | | Malformed_variant name -> 44 | Printf.sprintf "Malformed_variant(%S)" name 45 | 46 | exception Failure of error 47 | 48 | let () = 49 | Printexc.register_printer (fun exn -> 50 | match exn with 51 | | Failure e -> Some (Printf.sprintf "Protobuf.Decoder.Failure(%s)" (error_to_string e)) 52 | | _ -> None) 53 | 54 | let int_of_int32 fld v = 55 | if Sys.word_size = 32 && (v < min_int_as_int32 || v > max_int_as_int32) then 56 | raise (Failure (Overflow fld)); 57 | Int32.to_int v 58 | 59 | let int_of_int64 fld v = 60 | if (v < min_int_as_int64 || v > max_int_as_int64) then 61 | raise (Failure (Overflow fld)); 62 | Int64.to_int v 63 | 64 | let int32_of_int64 fld v = 65 | if (v < min_int32_as_int64 || v > max_int32_as_int64) then 66 | raise (Failure (Overflow fld)); 67 | Int64.to_int32 v 68 | 69 | let bool_of_int64 fld v = 70 | if v = Int64.zero then false 71 | else if v = Int64.one then true 72 | else raise (Failure (Overflow fld)) 73 | 74 | type t = { 75 | source : bytes; 76 | limit : int; 77 | mutable offset : int; 78 | } 79 | 80 | let of_bytes source = 81 | { source; 82 | offset = 0; 83 | limit = Bytes.length source; } 84 | 85 | let of_string source = 86 | { source = Bytes.of_string source; 87 | offset = 0; 88 | limit = String.length source; } 89 | 90 | let decode_exn f source = 91 | f (of_bytes source) 92 | 93 | let decode f source = 94 | try Some (decode_exn f source) with Failure _ -> None 95 | 96 | let at_end d = 97 | d.limit = d.offset 98 | 99 | let byte d = 100 | if d.offset >= d.limit then 101 | raise (Failure Incomplete); 102 | let byte = int_of_char (Bytes.get d.source d.offset) in 103 | d.offset <- d.offset + 1; 104 | byte 105 | 106 | let varint d = 107 | let rec read s = 108 | let b = byte d in 109 | if b land 0x80 <> 0 then 110 | Int64.(logor (shift_left (logand (of_int b) 0x7fL) s) (read (s + 7))) 111 | else if s < 63 || (b land 0x7f) <= 1 then 112 | Int64.(shift_left (of_int b) s) 113 | else 114 | raise (Failure Overlong_varint) 115 | in 116 | read 0 117 | 118 | let zigzag d = 119 | let v = varint d in 120 | Int64.(logxor (shift_right v 1) (neg (logand v Int64.one))) 121 | 122 | let bits32 d = 123 | let b1 = byte d in 124 | let b2 = byte d in 125 | let b3 = byte d in 126 | let b4 = byte d in 127 | Int32.(add (shift_left (of_int b4) 24) 128 | (add (shift_left (of_int b3) 16) 129 | (add (shift_left (of_int b2) 8) 130 | (of_int b1)))) 131 | 132 | let bits64 d = 133 | let b1 = byte d in 134 | let b2 = byte d in 135 | let b3 = byte d in 136 | let b4 = byte d in 137 | let b5 = byte d in 138 | let b6 = byte d in 139 | let b7 = byte d in 140 | let b8 = byte d in 141 | Int64.(add (shift_left (of_int b8) 56) 142 | (add (shift_left (of_int b7) 48) 143 | (add (shift_left (of_int b6) 40) 144 | (add (shift_left (of_int b5) 32) 145 | (add (shift_left (of_int b4) 24) 146 | (add (shift_left (of_int b3) 16) 147 | (add (shift_left (of_int b2) 8) 148 | (of_int b1)))))))) 149 | 150 | let bytes d = 151 | (* strings are always shorter than range of int *) 152 | let len = Int64.to_int (varint d) in 153 | if d.offset + len > d.limit then 154 | raise (Failure Incomplete); 155 | let str = Bytes.sub d.source d.offset len in 156 | d.offset <- d.offset + len; 157 | str 158 | 159 | let nested d = 160 | (* strings are always shorter than range of int *) 161 | let len = Int64.to_int (varint d) in 162 | if d.offset + len > d.limit then 163 | raise (Failure Incomplete); 164 | let d' = { d with limit = d.offset + len; } in 165 | d.offset <- d.offset + len; 166 | d' 167 | 168 | let key d = 169 | if d.offset = d.limit 170 | then None 171 | else 172 | (* keys are always in the range of int, but prefix might only fit into int32 *) 173 | let prefix = varint d in 174 | let key, ty = Int64.(to_int (shift_right prefix 3)), Int64.logand 0x7L prefix in 175 | match ty with 176 | | 0L -> Some (key, Varint) 177 | | 1L -> Some (key, Bits64) 178 | | 2L -> Some (key, Bytes) 179 | | 5L -> Some (key, Bits32) 180 | | _ -> raise (Failure Malformed_field) 181 | 182 | let skip d kind = 183 | let skip_len n = 184 | if d.offset + n > d.limit then 185 | raise (Failure Incomplete); 186 | d.offset <- d.offset + n 187 | in 188 | let rec skip_varint () = 189 | let b = byte d in 190 | if b land 0x80 <> 0 then skip_varint () else () 191 | in 192 | match kind with 193 | | Bits32 -> skip_len 4 194 | | Bits64 -> skip_len 8 195 | (* strings are always shorter than range of int *) 196 | | Bytes -> skip_len (Int64.to_int (varint d)) 197 | | Varint -> skip_varint () 198 | end 199 | 200 | module Encoder = struct 201 | type error = 202 | | Overflow of string 203 | 204 | let error_to_string e = 205 | match e with 206 | | Overflow fld -> Printf.sprintf "Overflow(%S)" fld 207 | 208 | exception Failure of error 209 | 210 | let () = 211 | Printexc.register_printer (fun exn -> 212 | match exn with 213 | | Failure e -> Some (Printf.sprintf "Protobuf.Encoder.Failure(%s)" (error_to_string e)) 214 | | _ -> None) 215 | 216 | type t = Buffer.t 217 | 218 | let create () = 219 | Buffer.create 16 220 | 221 | let to_string = Buffer.contents 222 | 223 | let to_bytes = Buffer.to_bytes 224 | 225 | let encode_exn f x = 226 | let e = create () in f x e; to_bytes e 227 | 228 | let encode f x = 229 | try Some (encode_exn f x) with Failure _ -> None 230 | 231 | let varint i e = 232 | let rec write i = 233 | if Int64.(logand i (lognot 0x7fL)) = Int64.zero then 234 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0x7fL i))) 235 | else begin 236 | Buffer.add_char e (char_of_int Int64.(to_int (logor 0x80L (logand 0x7fL i)))); 237 | write (Int64.shift_right_logical i 7) 238 | end 239 | in 240 | write i 241 | 242 | let smallint i e = 243 | varint (Int64.of_int i) e 244 | 245 | let zigzag i e = 246 | varint Int64.(logxor (shift_left i 1) (shift_right i 63)) e 247 | 248 | let bits32 i e = 249 | Buffer.add_char e (char_of_int Int32.(to_int (logand 0xffl i))); 250 | Buffer.add_char e (char_of_int Int32.(to_int (logand 0xffl (shift_right i 8)))); 251 | Buffer.add_char e (char_of_int Int32.(to_int (logand 0xffl (shift_right i 16)))); 252 | Buffer.add_char e (char_of_int Int32.(to_int (logand 0xffl (shift_right i 24)))) 253 | 254 | let bits64 i e = 255 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL i))); 256 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 8)))); 257 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 16)))); 258 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 24)))); 259 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 32)))); 260 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 40)))); 261 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 48)))); 262 | Buffer.add_char e (char_of_int Int64.(to_int (logand 0xffL (shift_right i 56)))) 263 | 264 | let bytes b e = 265 | smallint (Bytes.length b) e; 266 | Buffer.add_bytes e b 267 | 268 | let nested f e = 269 | let e' = Buffer.create 16 in 270 | f e'; 271 | smallint (Buffer.length e') e; 272 | Buffer.add_buffer e e' 273 | 274 | let key (k, pk) e = 275 | let pk' = 276 | match pk with 277 | | Varint -> 0 278 | | Bits64 -> 1 279 | | Bytes -> 2 280 | | Bits32 -> 5 281 | in 282 | smallint (pk' lor (k lsl 3)) e 283 | 284 | let int32_of_int64 fld v = 285 | if (v < min_int32_as_int64 || v > max_int32_as_int64) then 286 | raise (Failure (Overflow fld)); 287 | Int64.to_int32 v 288 | 289 | let int32_of_int fld v = 290 | if Sys.word_size = 64 && (v < min_int32_as_int || v > max_int32_as_int) then 291 | raise (Failure (Overflow fld)); 292 | Int32.of_int v 293 | end 294 | -------------------------------------------------------------------------------- /src_test/test_syntax.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | type uint32 = Uint32.t 4 | type uint64 = Uint64.t 5 | 6 | let assert_roundtrip printer encoder decoder str value = 7 | (* encode *) 8 | let e = Protobuf.Encoder.create () in 9 | encoder value e; 10 | assert_equal ~printer:(Printf.sprintf "%S") str (Protobuf.Encoder.to_string e); 11 | (* decode *) 12 | let d = Protobuf.Decoder.of_string str in 13 | assert_equal ~printer value (decoder d) 14 | 15 | type b = bool [@@deriving protobuf] 16 | let test_bool ctxt = 17 | assert_roundtrip string_of_bool b_to_protobuf b_from_protobuf 18 | "\x08\x01" true 19 | 20 | type i1 = int [@@deriving protobuf] 21 | type i2 = int [@encoding `zigzag] [@@deriving protobuf] 22 | type i3 = int [@encoding `bits32] [@@deriving protobuf] 23 | type i4 = int [@encoding `bits64] [@@deriving protobuf] 24 | type il1 = int32 [@encoding `varint] [@@deriving protobuf] 25 | type il2 = int32 [@encoding `zigzag] [@@deriving protobuf] 26 | type il3 = Int32.t [@@deriving protobuf] 27 | type il4 = int32 [@encoding `bits64] [@@deriving protobuf] 28 | type iL1 = int64 [@encoding `varint] [@@deriving protobuf] 29 | type iL2 = int64 [@encoding `zigzag] [@@deriving protobuf] 30 | type iL3 = int64 [@encoding `bits32] [@@deriving protobuf] 31 | type iL4 = Int64.t [@@deriving protobuf] 32 | let test_ints ctxt = 33 | assert_roundtrip string_of_int i1_to_protobuf i1_from_protobuf 34 | "\x08\xac\x02" 300; 35 | assert_roundtrip string_of_int i2_to_protobuf i2_from_protobuf 36 | "\x08\xac\x02" 150; 37 | assert_roundtrip string_of_int i3_to_protobuf i3_from_protobuf 38 | "\x0d\x2c\x01\x00\x00" 300; 39 | assert_roundtrip string_of_int i4_to_protobuf i4_from_protobuf 40 | "\x09\x2c\x01\x00\x00\x00\x00\x00\x00" 300; 41 | 42 | assert_roundtrip Int32.to_string il1_to_protobuf il1_from_protobuf 43 | "\x08\xac\x02" 300l; 44 | assert_roundtrip Int32.to_string il2_to_protobuf il2_from_protobuf 45 | "\x08\xac\x02" 150l; 46 | assert_roundtrip Int32.to_string il3_to_protobuf il3_from_protobuf 47 | "\x0d\x2c\x01\x00\x00" 300l; 48 | assert_roundtrip Int32.to_string il4_to_protobuf il4_from_protobuf 49 | "\x09\x2c\x01\x00\x00\x00\x00\x00\x00" 300l; 50 | 51 | assert_roundtrip Int64.to_string iL1_to_protobuf iL1_from_protobuf 52 | "\x08\xac\x02" 300L; 53 | assert_roundtrip Int64.to_string iL2_to_protobuf iL2_from_protobuf 54 | "\x08\xac\x02" 150L; 55 | assert_roundtrip Int64.to_string iL3_to_protobuf iL3_from_protobuf 56 | "\x0d\x2c\x01\x00\x00" 300L; 57 | assert_roundtrip Int64.to_string iL4_to_protobuf iL4_from_protobuf 58 | "\x09\x2c\x01\x00\x00\x00\x00\x00\x00" 300L 59 | 60 | type ul1 = uint32 [@encoding `varint] [@@deriving protobuf] 61 | type ul2 = uint32 [@encoding `zigzag] [@@deriving protobuf] 62 | type ul3 = Uint32.t [@@deriving protobuf] 63 | type ul4 = uint32 [@encoding `bits64] [@@deriving protobuf] 64 | type uL1 = uint64 [@encoding `varint] [@@deriving protobuf] 65 | type uL2 = uint64 [@encoding `zigzag] [@@deriving protobuf] 66 | type uL3 = uint64 [@encoding `bits32] [@@deriving protobuf] 67 | type uL4 = Uint64.t [@@deriving protobuf] 68 | let test_uints ctxt = 69 | assert_roundtrip Uint32.to_string ul1_to_protobuf ul1_from_protobuf 70 | "\x08\xac\x02" (Uint32.of_int 300); 71 | assert_roundtrip Uint32.to_string ul2_to_protobuf ul2_from_protobuf 72 | "\x08\xac\x02" (Uint32.of_int 150); 73 | assert_roundtrip Uint32.to_string ul3_to_protobuf ul3_from_protobuf 74 | "\x0d\x2c\x01\x00\x00" (Uint32.of_int 300); 75 | assert_roundtrip Uint32.to_string ul4_to_protobuf ul4_from_protobuf 76 | "\x09\x2c\x01\x00\x00\x00\x00\x00\x00" (Uint32.of_int 300); 77 | 78 | assert_roundtrip Uint64.to_string uL1_to_protobuf uL1_from_protobuf 79 | "\x08\xac\x02" (Uint64.of_int 300); 80 | assert_roundtrip Uint64.to_string uL2_to_protobuf uL2_from_protobuf 81 | "\x08\xac\x02" (Uint64.of_int 150); 82 | assert_roundtrip Uint64.to_string uL3_to_protobuf uL3_from_protobuf 83 | "\x0d\x2c\x01\x00\x00" (Uint64.of_int 300); 84 | assert_roundtrip Uint64.to_string uL4_to_protobuf uL4_from_protobuf 85 | "\x09\x2c\x01\x00\x00\x00\x00\x00\x00" (Uint64.of_int 300) 86 | 87 | type f1 = float [@encoding `bits32] [@@deriving protobuf] 88 | type f2 = float [@@deriving protobuf] 89 | let test_floats ctxt = 90 | assert_roundtrip string_of_float f1_to_protobuf f1_from_protobuf 91 | "\x0d\x00\x00\xC0\x3f" 1.5; 92 | assert_roundtrip string_of_float f2_to_protobuf f2_from_protobuf 93 | "\x09\x00\x00\x00\x00\x00\x00\xF8\x3f" 1.5 94 | 95 | type s = string [@@deriving protobuf] 96 | let test_string ctxt = 97 | assert_roundtrip (fun x -> x) s_to_protobuf s_from_protobuf 98 | "\x0a\x03abc" "abc" 99 | 100 | type by = bytes [@@deriving protobuf] 101 | let test_string ctxt = 102 | assert_roundtrip (fun x -> Bytes.to_string x) by_to_protobuf by_from_protobuf 103 | "\x0a\x03abc" (Bytes.of_string "abc") 104 | 105 | type o = int option [@@deriving protobuf] 106 | let test_option ctxt = 107 | let printer x = match x with None -> "None" | Some v -> "Some " ^ (string_of_int v) in 108 | assert_roundtrip printer o_to_protobuf o_from_protobuf 109 | "" None; 110 | assert_roundtrip printer o_to_protobuf o_from_protobuf 111 | "\x08\xac\x02" (Some 300) 112 | 113 | type l = int list [@@deriving protobuf] 114 | let test_list ctxt = 115 | let printer x = x |> List.map string_of_int |> String.concat ", " in 116 | assert_roundtrip printer l_to_protobuf l_from_protobuf 117 | "" [] ; 118 | assert_roundtrip printer l_to_protobuf l_from_protobuf 119 | "\x08\xac\x02\x08\x2a" [300; 42] 120 | 121 | type a = int array [@@deriving protobuf] 122 | let test_array ctxt = 123 | let printer x = Array.to_list x |> List.map string_of_int |> String.concat ", " in 124 | assert_roundtrip printer a_to_protobuf a_from_protobuf 125 | "" [||]; 126 | assert_roundtrip printer a_to_protobuf a_from_protobuf 127 | "\x08\xac\x02\x08\x2a" [|300; 42|] 128 | 129 | type ts = int * string [@@deriving protobuf] 130 | let test_tuple ctxt = 131 | let printer (x, y) = Printf.sprintf "%d, %s" x y in 132 | assert_roundtrip printer ts_to_protobuf ts_from_protobuf 133 | "\x08\xac\x02\x12\x08spartans" (300, "spartans") 134 | 135 | type r1 = { 136 | r1a : int [@key 1]; 137 | r1b : string [@key 2]; 138 | } [@@deriving protobuf] 139 | let test_record ctxt = 140 | let printer r = Printf.sprintf "{ r1a = %d, r1b = %s }" r.r1a r.r1b in 141 | assert_roundtrip printer r1_to_protobuf r1_from_protobuf 142 | "\x08\xac\x02\x12\x08spartans" 143 | { r1a = 300; r1b = "spartans" } 144 | 145 | type r2 = { 146 | r2a : r1 [@key 1]; 147 | } [@@deriving protobuf] 148 | let test_nested ctxt = 149 | let printer r = Printf.sprintf "{ r2a = { r1a = %d, r1b = %s } }" r.r2a.r1a r.r2a.r1b in 150 | assert_roundtrip printer r2_to_protobuf r2_from_protobuf 151 | "\x0a\x0d\x08\xac\x02\x12\x08spartans" 152 | { r2a = { r1a = 300; r1b = "spartans" } } 153 | 154 | type r3 = { 155 | r3a : (int [@encoding `bits32]) * string [@key 1]; 156 | } [@@deriving protobuf] 157 | let test_imm_tuple ctxt = 158 | let printer { r3a = a, b } = Printf.sprintf "{ r3a = %d, %s } }" a b in 159 | assert_roundtrip printer r3_to_protobuf r3_from_protobuf 160 | "\x0a\x0f\x0d\x2c\x01\x00\x00\x12\x08spartans" 161 | { r3a = 300, "spartans" } 162 | 163 | type v1 = 164 | | V1A [@key 1] 165 | | V1B [@key 2] 166 | | V1C of int [@key 3] 167 | | V1D of string * string [@key 4] 168 | [@@deriving protobuf] 169 | let test_variant ctxt = 170 | let printer v = 171 | match v with 172 | | V1A -> "V1A" 173 | | V1B -> "V1B" 174 | | V1C i -> Printf.sprintf "V1C(%d)" i 175 | | V1D (s1,s2) -> Printf.sprintf "V1D(%S, %S)" s1 s2 176 | in 177 | assert_roundtrip printer v1_to_protobuf v1_from_protobuf 178 | "\x08\x02" V1B; 179 | assert_roundtrip printer v1_to_protobuf v1_from_protobuf 180 | "\x08\x03\x20\x2a" (V1C 42); 181 | assert_roundtrip printer v1_to_protobuf v1_from_protobuf 182 | "\x08\x04\x2a\x0a\x0a\x03foo\x12\x03bar" (V1D ("foo", "bar")) 183 | 184 | type v2 = 185 | | V2A [@key 1] 186 | | V2B [@key 2] 187 | and r4 = { 188 | r4a : v2 [@key 1] [@bare] 189 | } [@@deriving protobuf] 190 | let test_variant_bare ctxt = 191 | let printer { r4a } = 192 | match r4a with V2A -> "{ r4a = V2A }" | V2B -> "{ r4a = V2B }" 193 | in 194 | assert_roundtrip printer r4_to_protobuf r4_from_protobuf 195 | "\x08\x02" { r4a = V2B } 196 | 197 | 198 | type 'a r5 = { 199 | r5a: 'a [@key 1] 200 | } [@@deriving protobuf] 201 | let test_tvar ctxt = 202 | let printer f { r5a } = Printf.sprintf "{ r5a = %s }" (f r5a) in 203 | assert_roundtrip (printer string_of_int) 204 | (r5_to_protobuf i1_to_protobuf) 205 | (r5_from_protobuf i1_from_protobuf) 206 | "\x0a\x02\x08\x01" { r5a = 1 } 207 | 208 | type 'a mylist = 209 | | Nil [@key 1] 210 | | Cons of 'a * 'a mylist [@key 2] 211 | [@@deriving protobuf] 212 | let test_mylist ctxt = 213 | let rec printer f v = 214 | match v with 215 | | Nil -> "Nil" 216 | | Cons (a, r) -> Printf.sprintf "Cons (%s, %s)" (f a) (printer f r) 217 | in 218 | assert_roundtrip (printer string_of_int) 219 | (mylist_to_protobuf i1_to_protobuf) 220 | (mylist_from_protobuf i1_from_protobuf) 221 | ("\x08\x02\x1a\x1c\x0a\x02\x08\x01\x12\x16\x08\x02" ^ 222 | "\x1a\x12\x0a\x02\x08\x02\x12\x0c\x08\x02\x1a\x08" ^ 223 | "\x0a\x02\x08\x03\x12\x02\x08\x01") 224 | (Cons (1, (Cons (2, (Cons (3, Nil)))))) 225 | 226 | type v3 = [ 227 | `V3A [@key 1] 228 | | `V3B of int [@key 2] 229 | | `V3C of string * string [@key 3] 230 | ] 231 | [@@deriving protobuf] 232 | let test_poly_variant ctxt = 233 | let printer v = 234 | match v with 235 | | `V3A -> "`V3A" 236 | | `V3B i -> Printf.sprintf "`V3B(%d)" i 237 | | `V3C (s1,s2) -> Printf.sprintf "`V3C(%S, %S)" s1 s2 238 | in 239 | assert_roundtrip printer v3_to_protobuf v3_from_protobuf 240 | "\x08\x01" `V3A; 241 | assert_roundtrip printer v3_to_protobuf v3_from_protobuf 242 | "\x08\x02\x18\x2a" (`V3B 42); 243 | assert_roundtrip printer v3_to_protobuf v3_from_protobuf 244 | "\x08\x03\x22\x0a\x0a\x03abc\x12\x03def" (`V3C ("abc", "def")) 245 | 246 | type r6 = { 247 | r6a : [ `R6A [@key 1] | `R6B [@key 2] ] [@key 1]; 248 | } [@@deriving protobuf] 249 | let test_imm_pvariant ctxt = 250 | let printer { r6a } = 251 | match r6a with `R6A -> "{ r6a = `R6A }" | `R6B -> "{ r6a = `R6B }" 252 | in 253 | assert_roundtrip printer r6_to_protobuf r6_from_protobuf 254 | "\x0a\x02\x08\x02" { r6a = `R6B } 255 | 256 | type v4 = [ `V4A [@key 1] | `V4B [@key 2] ] 257 | and r7 = { 258 | r7a : v4 [@key 1] [@bare] 259 | } [@@deriving protobuf] 260 | let test_pvariant_bare ctxt = 261 | let printer { r7a } = 262 | match r7a with `V4A -> "{ r7a = `V4A }" | `V4B -> "{ r7a = `V4B }" 263 | in 264 | assert_roundtrip printer r7_to_protobuf r7_from_protobuf 265 | "\x08\x01" { r7a = `V4A } 266 | 267 | type r8 = { 268 | r8a : [ `Request [@key 1] | `Reply [@key 2] ] [@key 1] [@bare]; 269 | r8b : int [@key 2]; 270 | } [@@deriving protobuf] 271 | let test_imm_pv_bare ctxt = 272 | let printer { r8a; r8b } = 273 | match r8a with 274 | | `Request -> Printf.sprintf "{ r8a = `Request; r8b = %d }" r8b 275 | | `Reply -> Printf.sprintf "{ r8a = `Reply; r8b = %d }" r8b 276 | in 277 | assert_roundtrip printer r8_to_protobuf r8_from_protobuf 278 | "\x08\x01\x10\x2a" { r8a = `Request; r8b = 42 } 279 | 280 | type v5 = 281 | | V5A of int option [@key 1] 282 | | V5B of string list [@key 2] 283 | | V5C of int array [@key 3] 284 | | V5D [@key 4] 285 | [@@deriving protobuf] 286 | let test_variant_optrep ctxt = 287 | let printer v5 = 288 | match v5 with 289 | | V5A io -> (match io with Some i -> Printf.sprintf "V5A %d" i | None -> "V5A None") 290 | | V5B sl -> Printf.sprintf "V5B [%s]" (String.concat "; " sl) 291 | | V5C ia -> Printf.sprintf "V5C [|%s|]" (String.concat "; " 292 | (List.map string_of_int (Array.to_list ia))) 293 | | V5D -> "V5D" 294 | in 295 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 296 | "\x08\x01\x10\x2a" (V5A (Some 42)); 297 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 298 | "\x08\x01" (V5A None); 299 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 300 | "\x08\x02\x1a\x0242\x1a\x0243" (V5B ["42"; "43"]); 301 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 302 | "\x08\x02" (V5B []); 303 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 304 | "\x08\x03\x20\x2a\x20\x2b" (V5C [|42; 43|]); 305 | assert_roundtrip printer v5_to_protobuf v5_from_protobuf 306 | "\x08\x03" (V5C [||]) 307 | 308 | type r9 = i1 r5 [@@deriving protobuf] 309 | let test_nonpoly ctxt = 310 | let printer { r5a } = Printf.sprintf "{ r5a = %d }" r5a in 311 | assert_roundtrip printer r9_to_protobuf r9_from_protobuf 312 | "\x0a\x04\x0a\x02\x08\x01" { r5a = 1 } 313 | 314 | type d = int [@default 42] [@@deriving protobuf] 315 | let test_default ctxt = 316 | assert_roundtrip string_of_int d_to_protobuf d_from_protobuf 317 | "" 42; 318 | assert_roundtrip string_of_int d_to_protobuf d_from_protobuf 319 | "\x08\x01" 1 320 | 321 | type p = int list [@packed] [@@deriving protobuf] 322 | let test_packed ctxt = 323 | let printer xs = Printf.sprintf "[%s]" (String.concat "; " (List.map string_of_int xs)) in 324 | assert_roundtrip printer p_to_protobuf p_from_protobuf 325 | "" []; 326 | assert_roundtrip printer p_to_protobuf p_from_protobuf 327 | "\x0a\x01\x01" [1]; 328 | assert_roundtrip printer p_to_protobuf p_from_protobuf 329 | "\x0a\x03\x01\x02\x03" [1; 2; 3]; 330 | let d = Protobuf.Decoder.of_string "\x0a\x01\x01\x0a\x02\x02\x03" in 331 | assert_equal ~printer [1; 2; 3] (p_from_protobuf d) 332 | 333 | let test_errors ctxt = 334 | (* scalars *) 335 | let d = Protobuf.Decoder.of_string "" in 336 | assert_raises Protobuf.Decoder.(Failure (Missing_field "Test_syntax.s")) 337 | (fun () -> s_from_protobuf d); 338 | let d = Protobuf.Decoder.of_string "\x0d\x00\x00\xC0\x3f" in 339 | assert_raises Protobuf.Decoder.(Failure (Unexpected_payload ("Test_syntax.s", Protobuf.Bits32))) 340 | (fun () -> s_from_protobuf d); 341 | (* records *) 342 | let d = Protobuf.Decoder.of_string "" in 343 | assert_raises Protobuf.Decoder.(Failure (Missing_field "Test_syntax.r1.r1b")) 344 | (fun () -> r1_from_protobuf d); 345 | (* tuples *) 346 | let d = Protobuf.Decoder.of_string "\x0a\x00" in 347 | assert_raises Protobuf.Decoder.(Failure (Missing_field "Test_syntax.r3.r3a.1")) 348 | (fun () -> r3_from_protobuf d); 349 | (* variants *) 350 | let d = Protobuf.Decoder.of_string "\x08\x03\x18\x1a" in 351 | assert_raises Protobuf.Decoder.(Failure (Malformed_variant "Test_syntax.v1")) 352 | (fun () -> v1_from_protobuf d) 353 | 354 | let test_skip ctxt = 355 | let d = Protobuf.Decoder.of_string "\x15\x00\x00\xC0\x3f" in 356 | assert_raises Protobuf.Decoder.(Failure (Missing_field "Test_syntax.s")) 357 | (fun () -> s_from_protobuf d) 358 | 359 | module type Elem = sig 360 | type t [@@deriving protobuf] 361 | end 362 | 363 | module Collection(Elem:Elem) = struct 364 | type t = Elem.t list [@@deriving protobuf] 365 | end 366 | 367 | let suite = "Test syntax" >::: [ 368 | "test_bool" >:: test_bool; 369 | "test_ints" >:: test_ints; 370 | "test_uints" >:: test_uints; 371 | "test_floats" >:: test_floats; 372 | "test_string" >:: test_string; 373 | "test_option" >:: test_option; 374 | "test_list" >:: test_list; 375 | "test_array" >:: test_array; 376 | "test_tuple" >:: test_tuple; 377 | "test_record" >:: test_record; 378 | "test_nested" >:: test_nested; 379 | "test_imm_tuple" >:: test_imm_tuple; 380 | "test_variant" >:: test_variant; 381 | "test_variant_bare" >:: test_variant_bare; 382 | "test_tvar" >:: test_tvar; 383 | "test_mylist" >:: test_mylist; 384 | "test_poly_variant" >:: test_poly_variant; 385 | "test_imm_pvariant" >:: test_imm_pvariant; 386 | "test_pvariant_bare" >:: test_pvariant_bare; 387 | "test_imm_pv_bare" >:: test_imm_pv_bare; 388 | "test_variant_optrep" >:: test_variant_optrep; 389 | "test_nonpoly" >:: test_nonpoly; 390 | "test_default" >:: test_default; 391 | "test_packed" >:: test_packed; 392 | "test_errors" >:: test_errors; 393 | "test_skip" >:: test_skip; 394 | ] 395 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [@@deriving protobuf] 2 | ===================== 3 | 4 | _deriving protobuf_ is a [ppx_deriving][pd] plugin that generates 5 | [Google Protocol Buffers][pb] serializers and deserializes 6 | from an OCaml type definition. 7 | 8 | Sponsored by [Evil Martians](http://evilmartians.com). 9 | _protoc_ export sponsored by [MaxProfitLab](http://maxprofitlab.com/). 10 | 11 | [pd]: https://github.com/ocaml-ppx/ppx_deriving 12 | [pb]: https://developers.google.com/protocol-buffers/ 13 | 14 | Installation 15 | ------------ 16 | 17 | _deriving protobuf_ can be installed via [OPAM](https://opam.ocaml.org): 18 | 19 | $ opam install ppx_deriving_protobuf 20 | 21 | Usage 22 | ----- 23 | 24 | In order to use _deriving protobuf_, require the package `ppx_deriving_protobuf`. 25 | 26 | Syntax 27 | ------ 28 | 29 | _deriving protobuf_ is not a replacement for _protoc_ and it does not attempt to generate 30 | code based on _protoc_ definitions. Instead, it generates code based on OCaml type 31 | definitions. It can also generate input files for _protoc_. 32 | 33 | _deriving protobuf_-generated serializers are derived from the structure of the type 34 | and several attributes: `@key`, `@encoding`, `@bare` and `@default`. Generation 35 | of the serializer is triggered by a `[@@deriving Protobuf]` attribute attached 36 | to the type definition. 37 | 38 | _deriving protobuf_ generates two functions per type: 39 | 40 | ``` ocaml 41 | type t = ... [@@deriving protobuf] 42 | val t_from_protobuf : Protobuf.Decoder.t -> t 43 | val t_to_protobuf : t -> Protobuf.Encoder.t -> unit 44 | ``` 45 | 46 | In order to deserialize a value of type `t` from bytes `message`, use: 47 | 48 | ``` ocaml 49 | let output = Protobuf.Decoder.decode_exn t_from_protobuf message in 50 | ... 51 | ``` 52 | 53 | In order to serialize a value `input` of type `t`, use: 54 | 55 | ``` ocaml 56 | let message = Protobuf.Encoder.encode_exn t_to_protobuf input in 57 | ... 58 | ``` 59 | 60 | ### Records 61 | 62 | A record is the most obvious counterpart for a Protobuf message. In a record, every 63 | field must have an explicitly defined key. For example, consider this _protoc_ 64 | definition and its _deriving protobuf_ equivalent: 65 | 66 | ``` protoc 67 | message SearchRequest { 68 | required string query = 1; 69 | optional int32 page_number = 2; 70 | optional int32 result_per_page = 3; 71 | } 72 | ``` 73 | 74 | ``` ocaml 75 | type search_request = { 76 | query : string [@key 1]; 77 | page_number : int option [@key 2]; 78 | result_per_page : int option [@key 3]; 79 | } [@@deriving protobuf] 80 | ``` 81 | 82 | _deriving protobuf_ recognizes and maps `option` to optional fields, and 83 | `list` and `array` to repeated fields. 84 | 85 | ### Optional and default fields 86 | 87 | A `[@default]` attribute attached to a required field converts it to an optional 88 | field; if the field is not present, its value is assumed to be the default one, 89 | and conversely, if the value of the field is same as the default value, it is 90 | not serialized: 91 | 92 | ``` protoc 93 | message Defaults { 94 | optional int32 results = 1 [default = 10]; 95 | } 96 | ``` 97 | 98 | ``` ocaml 99 | type defaults = { 100 | results : int [@key 1] [@default 10]; 101 | } 102 | ``` 103 | 104 | Note that _protoc_'s default behavior is to assign a type-specific default value 105 | to optional fields missing from message, i.e. `0` to integer fields, `""` to 106 | string fields, and so on. With _deriving protobuf_, optional fields are represented 107 | with the `option` type; it is possible to emulate _protoc_'s behavior by explicitly 108 | specifying `int [@default 0]`, etc. 109 | 110 | ### Integers 111 | 112 | Unlike _protoc_, _deriving protobuf_ allows a much more flexible mapping between 113 | wire representations of integral types and their counterparts in OCaml. 114 | Any combination of the known integral types (`int`, `int32`, `int64`, 115 | `Int32.t`, `Int64.t`, `Uint32.t` and `Uint64.t`) and wire representations 116 | (`varint`, `zigzag`, `bits32` and `bits64`) is valid. The wire representation 117 | is specified using the `@encoding` attribute. 118 | 119 | For example, consider this _protoc_ definition and a compatible _deriving protobuf_ one: 120 | 121 | ``` protoc 122 | message Integers { 123 | required int32 bar = 1; 124 | required fixed64 baz = 2; 125 | } 126 | ``` 127 | 128 | ``` ocaml 129 | type integers = { 130 | bar : Uint64.t [@key 1] [@encoding `varint]; 131 | baz : int [@key 2] [@encoding `bits64]; 132 | } 133 | ``` 134 | 135 | When parsing or serializing, the values will be appropriately extended or truncated. 136 | If a value does not fit into the narrower type used for serialization or deserialization, 137 | `Decoder.Error Decoder.Overflow` or `Encoder.Error Encoder.Overflow` is raised. 138 | 139 | The following table summarizes equivalence between integral types of _protoc_ 140 | and encodings of _deriving protobuf_: 141 | 142 | | Encoding | _protoc_ type | 143 | | -------- | ---------------------------- | 144 | | varint | int32, int64, uint32, uint64 | 145 | | zigzag | sint32, sint64 | 146 | | bits32 | fixed32, sfixed32 | 147 | | bits64 | fixed64, sfixed64 | 148 | 149 | By default, OCaml types use the following encoding: 150 | 151 | | OCaml type | Encoding | _protoc_ type | 152 | | ---------------- | -------- | -------------- | 153 | | int | varint | int32 or int64 | 154 | | int32 or Int32.t | bits32 | sfixed32 | 155 | | Uint32.t | bits32 | fixed32 | 156 | | int64 or Int64.t | bits64 | sfixed64 | 157 | | Uint64.t | bits64 | fixed64 | 158 | 159 | Note that no OCaml type maps to zigzag-encoded `sint32` or `sint64` by default. 160 | It is necessary to use [@encoding `zigzag] explicitly. 161 | 162 | ### Floats 163 | 164 | Similarly to integers, `float` maps to _protoc_'s `double` by default, 165 | but it is possible to specify the encoding explicitly: 166 | 167 | ``` protoc 168 | message Floats { 169 | required float foo = 1; 170 | required double bar = 2; 171 | } 172 | ``` 173 | 174 | ``` ocaml 175 | type floats = { 176 | foo : float [@key 1] [@encoding `bits32]; 177 | bar : float [@key 2]; 178 | } [@@deriving protobuf] 179 | ``` 180 | 181 | ### Booleans 182 | 183 | `bool` maps to _protoc_'s `bool` and is encoded on wire using `varint`: 184 | 185 | ``` protoc 186 | message Booleans { 187 | required bool bar = 1; 188 | } 189 | ``` 190 | 191 | ``` ocaml 192 | type booleans = { 193 | bar : bool [@key 1]; 194 | } [@@deriving protobuf] 195 | ``` 196 | 197 | ### Strings and bytes 198 | 199 | All of `string`, `String.t`, `bytes` and `Bytes.t` map to _protoc_'s `string` or 200 | `bytes` and are encoded on wire using `bytes`: 201 | 202 | Note that unlike _protoc_, which has an additional invariant that the contents of 203 | a `string` must be valid UTF-8 text, _deriving protobuf_ does not have this invariant. 204 | However, you still should observe it in your programs. 205 | 206 | ``` protoc 207 | message Strings { 208 | required string bar = 1; 209 | required bytes baz = 2; 210 | } 211 | ``` 212 | 213 | ``` ocaml 214 | type strings = { 215 | bar : string [@key 1]; 216 | baz : bytes [@key 2]; 217 | } [@@deriving protobuf] 218 | ``` 219 | 220 | ### Tuples 221 | 222 | A tuple is treated in exactly same way as a record, except that keys are derived 223 | automatically starting at 1. The definition of `search_request` above could be 224 | rewritten as: 225 | 226 | ``` ocaml 227 | type search_request' = string * int option * int option 228 | [@@deriving protobuf] 229 | ``` 230 | 231 | Additionally, a tuple can be used in any context where a scalar value is expected; 232 | in this case, it is equivalent to an anonymous inner message: 233 | 234 | ``` protoc 235 | message Nested { 236 | message StringFloatPair { 237 | required string str = 1; 238 | required float flo = 2; 239 | } 240 | required int32 foo = 1; 241 | optional StringFloatPair bar = 2; 242 | } 243 | ``` 244 | 245 | ``` ocaml 246 | type nested = { 247 | foo : int [@key 1]; 248 | bar : (string * float) option [@key 2]; 249 | } [@@deriving protobuf] 250 | ``` 251 | 252 | ### Variants 253 | 254 | An OCaml variant types is normally mapped to an entire Protobuf message by _deriving protobuf_, 255 | as opposed to _protoc_, which maps an `enum` to a simple `varint`. This is done because 256 | OCaml constructors can have arguments, but _protoc_'s `enum`s can not. 257 | 258 | Note that even if a type doesn't have any constructor with arguments, it is still mapped 259 | to a message, because it would not be possible to extend the type later with a constructor 260 | with arguments otherwise. 261 | 262 | Every constructor must have an explicitly specified key; if the constructor has one argument, 263 | it is mapped to an optional field with the key corresponding to the key of the constructor 264 | plus one. If there is more than one argument, they're treated like a tuple. 265 | 266 | Consider this example: 267 | 268 | ``` protoc 269 | message Variant { 270 | enum T { 271 | A = 1; 272 | B = 2; 273 | C = 3; 274 | D = 4; 275 | } 276 | message C { 277 | required string foo = 1; 278 | required string bar = 2; 279 | } 280 | message D { 281 | required string s1 = 1; 282 | required string s2 = 2; 283 | } 284 | required T t = 1; 285 | optional int32 b = 3; // (B = 2) + 1 286 | optional C c = 4; // (C = 3) + 1 287 | optional D d = 5; // (D = 4) + 1 288 | } 289 | ``` 290 | 291 | ``` ocaml 292 | type variant = 293 | | A [@key 1] 294 | | B of int [@key 2] 295 | | C of string * string [@key 3] 296 | | D of {s1: string ; s2: string} [@key 4] 297 | [@@deriving protobuf] 298 | ``` 299 | 300 | Note that decoder considers messages which contain more than one optional field 301 | invalid and rejects them. 302 | 303 | In order to achieve better compatibility with _protoc_, it is possible to embed 304 | a variant where no constructors have arguments without wrapping it in a message: 305 | 306 | ``` protoc 307 | enum BareVariant { 308 | A = 1; 309 | B = 2; 310 | } 311 | message Container { 312 | required T value = 1; 313 | } 314 | ``` 315 | 316 | ``` ocaml 317 | type bare_variant = 318 | | A [@key 1] 319 | | B [@key 2] 320 | and container = { 321 | value : bare_variant [@key 1] [@bare]; 322 | } [@@deriving protobuf] 323 | ``` 324 | 325 | In practice, if a variant has no constructors with arguments, additional two 326 | functions are generated with the following signatures: 327 | 328 | ``` ocaml 329 | type t = A | B | ... [@@deriving protobuf] 330 | val t_from_protobuf_bare : Protobuf.Decoder.t -> t 331 | val t_to_protobuf_bare : Protobuf.Encoder.t -> t -> unit 332 | ``` 333 | 334 | These functions do not expect additional framing; they just parse or serialize 335 | a single `varint`. 336 | 337 | ### Polymorphic variants 338 | 339 | Polymorphic variants are handled in exactly same way as regular variants. However, 340 | you can also embed them directly, like tuples, in which case the semantics is 341 | the same as defining an alias for the variant and then using that type. 342 | 343 | This feature can be combined with the `[@bare]` annotation to create a useful 344 | shorthand: 345 | 346 | ``` protoc 347 | message Packet { 348 | enum Type { 349 | REQUEST = 1; 350 | REPLY = 2; 351 | } 352 | required Type type = 1; 353 | required int32 value = 2; 354 | } 355 | ``` 356 | 357 | ``` ocaml 358 | type packet = { 359 | type : [ `Request [@key 1] | `Reply [@key 2] ] [@key 1] [@bare]; 360 | value : int [@key 2]; 361 | } [@@deriving protobuf] 362 | ``` 363 | 364 | ### Type aliases 365 | 366 | A type alias (statement of form `type a = b`) is treated by _deriving protobuf_ as 367 | a definition of a message with one field with key 1: 368 | 369 | ``` protoc 370 | message Alias { 371 | required int32 val = 1; 372 | } 373 | ``` 374 | 375 | ``` ocaml 376 | type alias = int [@@deriving protobuf] 377 | ``` 378 | 379 | ### Nested messages 380 | 381 | When _deriving protobuf_ encounters a non-scalar type, it generates a call to 382 | the serialization or deserialization function corresponding to the full path 383 | to the type. 384 | 385 | Consider this definition: 386 | 387 | ``` ocaml 388 | type foo = bar * Baz.Quux.t [@@deriving protobuf] 389 | ``` 390 | 391 | The generated deserializer code will refer to `bar_from_protobuf` and 392 | `Baz.Quux.t_from_protobuf`; the serializer code will call `bar_to_protobuf` 393 | and `Baz.Quux.t_to_protobuf`. 394 | 395 | ### Packed fields 396 | 397 | Types which are encoded as `varint`, `bits32` or `bits64`, that is, numeric 398 | fields or bare variants, can be declared as "packed" with the `[@packed]` attribute, 399 | in which case the serializer emits a more compact representation. Only _protoc_ newer 400 | than 2.3.0 will recognize this representation. Note that the deserializer 401 | understands it regardless of the presence of `[@packed]` attribute. 402 | 403 | ``` protoc 404 | message Packed { 405 | repeated int32 elem = 1 [packed=true]; 406 | } 407 | ``` 408 | 409 | ``` ocaml 410 | type packed = int list [@key 1] [@packed] [@@deriving protobuf] 411 | ``` 412 | 413 | ### Parametric polymorphism 414 | 415 | _deriving protobuf_ is able to handle polymorphic type definitions. In this case, 416 | the serializing or deserializing function will accept one additional argument 417 | for every type variable; correspondingly, the value of this argument will be 418 | passed to serializer or deserializer of any nested parametric type. 419 | 420 | Consider this example: 421 | 422 | ``` ocaml 423 | type 'a mylist = 424 | | Nil [@key 1] 425 | | Cons of 'a * 'a mylist [@key 2] 426 | [@@deriving protobuf] 427 | ``` 428 | 429 | Here, the following functions will be generated: 430 | 431 | ``` ocaml 432 | val mylist_from_protobuf : (Protobuf.Decoder.t -> 'a) -> Protobuf.Decoder.t -> 433 | 'a mylist 434 | val mylist_to_protobuf : (Protobuf.Decoder.t -> 'a -> unit) -> Protobuf.Decoder.t -> 435 | 'a mylist -> unit 436 | ``` 437 | 438 | An example usage would be: 439 | 440 | ``` ocaml 441 | type a = int [@@deriving protobuf] 442 | 443 | let get_ints message = 444 | let decoder = Protobuf.Decoder.of_bytes message in 445 | mylist_from_protobuf a_from_protobuf decoder 446 | ``` 447 | 448 | It's also possible to specify concrete types as parameters; in this case, _deriving protobuf_ 449 | will infer the serializer/deserializer functions automatically. For example: 450 | 451 | ``` ocaml 452 | (* Combining two samples above *) 453 | type b = a mylist [@@deriving protobuf] 454 | ``` 455 | 456 | Error handling 457 | -------------- 458 | 459 | Both serializers and deserializers rigorously verify their input data. The only 460 | possible exception that can be raised during serialization is 461 | `Protobuf.Encoder.Failure`, and during deserialization is `Protobuf.Decoder.Failure`. 462 | 463 | ### Decoder errors 464 | 465 | The decoder attempts to annotate its failures with useful location information, 466 | but only if that wouldn't cost too much in terms of performance and complexity. 467 | 468 | In general, as long as you're using the same protocol on both sides, deserialization 469 | or should never raise. The errors would mainly arise when interoperating 470 | with code generated by _protoc_ that doesn't observe OCaml-specific invariants, 471 | or when handling malicious input. 472 | 473 | It discerns these types of failure (represented with `Decoder.Failure` exception): 474 | 475 | * `Incomplete`: the message was truncated or using invalid wire format. Frame 476 | overruns are likely to produce this as well. 477 | * `Overlong_varint`: a `varint` greater than 2⁶⁴-1 was encountered. 478 | * `Malformed_field`: an invalid wire type was encountered. 479 | * `Overflow fld`: an integer field in the message contained a value outside 480 | the range of the corresponding type, e.g. a `varint` field corresponding 481 | to `int32` contained `0xffffffff`. 482 | * `Unexpected_payload (fld, kind)`: a key corresponding to field `fld` 483 | had a wire type incompatible with the specified encoding, e.g. 484 | a `varint` wire type for a nested message. 485 | * `Missing_field fld`: a required field `fld` was missing from the message. 486 | * `Malformed_variant fld`: a variant `fld` contained a key not corresponding 487 | to any defined constructor. 488 | 489 | The decoder errors refer to fields via so-called "paths"; a path corresponds 490 | to the OCaml syntax for referring to a type, field or constructor, but can 491 | contain additional `/` (e.g. `/0`) component for an immediate tuple. 492 | 493 | For example, the `string` field will have the path `Foo.r.ra/1`: 494 | 495 | ``` ocaml 496 | (* foo.ml *) 497 | type r = { 498 | ra: (int * string) option [@key 1]; 499 | } [@@deriving protobuf] 500 | ``` 501 | 502 | ### Encoder errors 503 | 504 | The encoder discerns these types of failure (represented with `Encoder.Failure` 505 | exception): 506 | 507 | * `Overflow fld`: an integer value was outside the range of its corresponding 508 | encoding, e.g. a `int64` containing `0xffffffffffff` was serialized to 509 | `bits32`. 510 | 511 | The encoder errors use the same "path" convention as decoder errors. 512 | 513 | Extending protocols 514 | ------------------- 515 | 516 | In real-world applications, implementations using multiple versions of the same 517 | protocol must coexist. Protocol Buffers offer an imperfect and sometimes 518 | complicated, but very powerful and practical solution to this problem. 519 | 520 | The wire protocol is designed in a way that allows to safely extend it if 521 | one follows a set of constraints. 522 | 523 | ### Always 524 | 525 | Any of the following changes may be applied to either the sender or receiver 526 | of the message without breaking protocol: 527 | 528 | * Adding an optional field to a record, or an optional element to a tuple, 529 | or an optional argument to a constructor **with multiple arguments**. 530 | * Converting an optional field, tuple element or constructor argument 531 | into a repeated one. 532 | * Converting an optional field, tuple element or constructor argument 533 | into a required field with a default value, or vice versa. 534 | * Converting a repeated field, tuple element or constructor argument 535 | into an optional one (this is not recommended, as it silently ignores 536 | some of input data). 537 | * Turning an alias into a record that has a field marked `[@key 1]`. 538 | * Turning an alias into a tuple where the first element is the former 539 | type of the alias (this is not recommended for reasons of code clarity). 540 | 541 | ### Never 542 | 543 | When communicating bidirectionally, violating any of the following constraints 544 | always results in exceptions or receiving garbage data: 545 | 546 | * Never change `[@key]` or `[@encoding]` annotations; never add or remove 547 | `[@bare]` annotation. 548 | * Never change primitive (i.e. excluding `list`, `option` or `array` qualifiers) 549 | types of existing fields, tuple elements or constructor arguments. 550 | * Never remove required fields, tuple elements or constructor arguments. 551 | * Never replace a primitive type of a field, tuple element or constructor argument 552 | with a tuple, even if the first element of the replacing tuple is 553 | the former primitive type. 554 | * Never add arguments to an argument-less variant constructor, or vice versa. 555 | 556 | The following sections list some exceptions to this rule when the communication 557 | is unidirectional. 558 | 559 | ### On sender 560 | 561 | Any of the following changes may be applied exclusively to the sender 562 | without breaking the existing receivers: 563 | 564 | * Adding a required field, tuple element, or argument to a constructor 565 | **with multiple arguments**. 566 | * Converting an optional or repeated field, tuple element or constructor 567 | argument into a required one. 568 | * Replacing an integer type with a narrower one while preserving 569 | the encoding (it's a good idea to add the `[@encoding]` annotation 570 | explicitly). 571 | * Adding a variant constructor, but never actually sending it. 572 | 573 | ### On receiver 574 | 575 | Any of the following changes may be applied exclusively to the receiver 576 | without losing the ability to decode messages from existing senders: 577 | 578 | * Removing a required field, tuple element, or argument to a constructor 579 | **with more than two arguments**. 580 | * Replacing an integer type with a wider one while preserving the encoding 581 | (it's a good idea to add the `[@encoding]` annotation explicitly). 582 | 583 | Protoc export 584 | ------------- 585 | 586 | _deriving protobuf_ can export message types in _proto2_ language, the format 587 | that _protoc_ accepts; _protoc_ version 2.6 or later is required. 588 | 589 | To enable _protoc_ export, pass a `protoc` option to _deriving protobuf_: 590 | 591 | ``` 592 | (* foo.ml *) 593 | type msg = ... [@@deriving protobuf { protoc }] 594 | ``` 595 | 596 | Compiling this file will create a file called `Foo.protoc` (note the capitalization) 597 | in a directory adjacent to `foo.ml`; if you are using ocamlbuild and `foo.ml` 598 | is located in directory `src/`, the file will be generated at `_build/src/Foo.protoc`. 599 | This can be customized by providing a path explicitly, e.g. 600 | `[@@deriving protobuf { protoc = "Bar.protoc" }]`; the path is interpreted 601 | relative to the source file. 602 | 603 | The mapping between OCaml types and _protoc_ messages is straightforward. 604 | 605 | OCaml modules become _protoc_ packages with the same name. 606 | A nested module, e.g. `module Bar` in our `foo.ml`, becomes a nested package, 607 | `Foo.Bar`; it will be emitted in a file `Foo.Bar.protoc`, placed adjacent to 608 | `Foo.protoc`, since _protoc_ requires every package to reside in its own file. 609 | 610 | OCaml records and their fields become _protoc_ messages and fields with 611 | the same name: 612 | 613 | ``` ocaml 614 | type msg = { 615 | name: string [@key 1]; 616 | value: int [@key 2]; 617 | } [@@deriving protobuf { protoc }] 618 | ``` 619 | 620 | ``` protoc 621 | message msg { 622 | required string name = 1; 623 | required int64 value = 2; 624 | } 625 | ``` 626 | 627 | OCaml variants and their constructors become _protoc_ messages and fields 628 | with the same name; additionally generated are a nested enum called 629 | `_tag` whose constants have the same name as constructors with `_tag` 630 | appended, and a field named `tag` with the type `_tag`: 631 | 632 | ``` ocaml 633 | type msg = 634 | | A [@key 1] 635 | | B of string [@key 2] 636 | [@@deriving protobuf { protoc }] 637 | ``` 638 | 639 | ``` protoc 640 | message msg { 641 | enum _tag { 642 | A_tag = 1; 643 | B_tag = 2; 644 | } 645 | 646 | required _tag tag = 1; 647 | oneof value { 648 | string B = 3; 649 | } 650 | } 651 | ``` 652 | 653 | OCaml tuples become _protoc_ messages with the same name whose fields 654 | are called `_N` with `N` being the field index: 655 | 656 | ``` ocaml 657 | type msg = int * string 658 | [@@deriving protobuf { protoc }] 659 | ``` 660 | 661 | ``` protoc 662 | message msg { 663 | required int64 _0 = 1; 664 | required string _1 = 2; 665 | } 666 | ``` 667 | 668 | OCaml aliases become _protoc_ messages with one field called `_`: 669 | 670 | ``` ocaml 671 | type msg = int 672 | [@@deriving protobuf { protoc }] 673 | ``` 674 | 675 | ``` protoc 676 | message msg { 677 | required int64 _ = 1; 678 | } 679 | ``` 680 | 681 | Sometimes, a single toplevel OCaml type definition has to be translated 682 | into several messages, e.g. when a field or a constructor contains a tuple 683 | or a polymorphic variant. In this case, such messages become nested messages 684 | whose name is the name of the field or constructor with `_` prepended: 685 | 686 | ``` ocaml 687 | type msg = { 688 | field: int * string [@key 1] 689 | } 690 | [@@deriving protobuf { protoc }] 691 | ``` 692 | 693 | ``` protoc 694 | message msg { 695 | message _field { 696 | required int64 _0 = 1; 697 | required string _1 = 2; 698 | } 699 | 700 | required _field field = 1; 701 | } 702 | ``` 703 | 704 | Normally, when a type from another module is referenced, _deriving protobuf_ 705 | automatically generates the corresponding _protoc_ `import` directive: 706 | 707 | ``` ocaml 708 | type imported = Other.msg 709 | [@@deriving protobuf { protoc }] 710 | ``` 711 | 712 | ``` protoc 713 | import "Other.protoc"; 714 | message imported { 715 | required Other.msg _ = 1; 716 | } 717 | ``` 718 | 719 | However, when a type is referenced that was defined in a module defined earlier 720 | in the same file, the produced `import` directive is incorrect. 721 | (_deriving protobuf_ does not have an accurate model of OCaml's module scoping.) 722 | In this case, the `protoc_import` option can help: 723 | 724 | ``` ocaml 725 | (* foo.ml *) 726 | module Bar = struct 727 | type msg = int [@@deriving protobuf { protoc }] 728 | end 729 | 730 | type alias = Bar.msg 731 | [@@deriving protobuf { protoc; protoc_import = ["Foo.Bar.protoc"] }] 732 | ``` 733 | 734 | ``` protoc 735 | // Foo.protoc 736 | package Foo; 737 | import "Foo.Bar.protoc"; 738 | message alias { 739 | required Bar.msg _ = 1; 740 | } 741 | ``` 742 | 743 | ``` protoc 744 | // Foo.Bar.protoc 745 | package Foo.Bar; 746 | message msg { 747 | required int64 _ = 1; 748 | } 749 | ``` 750 | 751 | Compatibility 752 | ------------- 753 | 754 | Protocol Buffers specification [suggests][optional] that if a message contains 755 | multiple instances of a `required` or `optional` nested message, those nested 756 | messages should be merged. However, there is no concept of "merging messages" 757 | accessible to _deriving protobuf_, and this feature can be considered harmful anyway: 758 | it is far too forgiving of invalid input. Thus, _deriving protobuf_ doesn't implement 759 | this merging. 760 | 761 | _deriving protobuf_ is more strict than _protoc_ with numeric types; it raises 762 | `Failure (Overflow fld)` rather than silently truncate values. It is thought 763 | that accidentally losing 32th or 64th bit with OCaml's `int` type would be 764 | a common error without this countermeasure. 765 | 766 | Everything else should be entirely compatible with _protoc_. 767 | 768 | [optional]: https://developers.google.com/protocol-buffers/docs/encoding#optional 769 | 770 | API Documentation 771 | ----------------- 772 | 773 | The documentation for internal API is available at 774 | [GitHub pages](http://ocaml-ppx.github.io/ppx_deriving_protobuf/). 775 | 776 | License 777 | ------- 778 | 779 | [MIT](LICENSE.txt) 780 | -------------------------------------------------------------------------------- /src/ppx_deriving_protobuf.cppo.ml: -------------------------------------------------------------------------------- 1 | #define Rtag_patt(label, attrs, has_empty, args) \ 2 | { \ 3 | prf_desc = Rtag({ txt = label }, has_empty, args); \ 4 | prf_attributes = attrs; \ 5 | } 6 | 7 | #define Attribute_patt(loc_, txt_, payload) {attr_name = \ 8 | {txt = txt_; loc = loc_}; \ 9 | attr_payload = payload; \ 10 | attr_loc = _ } 11 | 12 | open Ppxlib 13 | open Asttypes 14 | open Parsetree 15 | open Ast_helper 16 | open Ppx_deriving.Ast_convenience 17 | 18 | let lid x = 19 | let loc = !default_loc in 20 | Ast_builder.Default.Located.lident ~loc x 21 | 22 | type pb_encoding = 23 | | Pbe_varint 24 | | Pbe_zigzag 25 | | Pbe_bits32 26 | | Pbe_bits64 27 | | Pbe_bytes 28 | | Pbe_packed of pb_encoding 29 | and pb_type = 30 | | Pbt_bool 31 | | Pbt_int 32 | | Pbt_int32 33 | | Pbt_int64 34 | | Pbt_uint32 35 | | Pbt_uint64 36 | | Pbt_float 37 | | Pbt_string 38 | | Pbt_bytes 39 | | Pbt_imm of core_type 40 | | Pbt_variant of (int * string) list 41 | | Pbt_nested of core_type list * Longident.t 42 | | Pbt_poly of string 43 | and pb_kind = 44 | | Pbk_required 45 | | Pbk_optional 46 | | Pbk_repeated 47 | and pb_field = { 48 | pbf_name : string; 49 | pbf_extname : string; 50 | pbf_path : string list; 51 | pbf_key : int; 52 | pbf_enc : pb_encoding; 53 | pbf_type : pb_type; 54 | pbf_kind : pb_kind; 55 | pbf_default : expression option; 56 | pbf_loc : Location.t; 57 | } 58 | 59 | type error = 60 | | Pberr_attr_syntax of Location.t * [ `Key | `Encoding | `Bare | `Default | `Packed ] 61 | | Pberr_wrong_attr of attribute 62 | | Pberr_no_key of Location.t 63 | | Pberr_key_invalid of Location.t * int 64 | | Pberr_key_duplicate of int * Location.t * Location.t 65 | | Pberr_abstract of type_declaration 66 | | Pberr_open of type_declaration 67 | | Pberr_wrong_ty of core_type 68 | | Pberr_wrong_tparm of core_type 69 | | Pberr_no_conversion of Location.t * pb_type * pb_encoding 70 | | Pberr_packed_bytes of Location.t 71 | | Pberr_dumb_protoc of Location.t 72 | | Pberr_ocaml_expr of Location.t 73 | 74 | exception Error of error 75 | 76 | let filter_map f lst = 77 | let rec filter result lst = 78 | match lst with 79 | | Some x :: lst -> filter (x :: result) lst 80 | | None :: lst -> filter result lst 81 | | [] -> result 82 | in 83 | List.map f lst |> filter [] 84 | 85 | let string_of_lident lid = 86 | String.concat "." (Longident.flatten_exn lid) 87 | 88 | let rec string_of_pb_encoding enc = 89 | match enc with 90 | | Pbe_varint -> "varint" 91 | | Pbe_zigzag -> "zigzag" 92 | | Pbe_bits32 -> "bits32" 93 | | Pbe_bits64 -> "bits64" 94 | | Pbe_bytes -> "bytes" 95 | | Pbe_packed enc -> "packed " ^ (string_of_pb_encoding enc) 96 | 97 | let pb_encoding_of_string str = 98 | match str with 99 | | "varint" -> Some Pbe_varint 100 | | "zigzag" -> Some Pbe_zigzag 101 | | "bits32" -> Some Pbe_bits32 102 | | "bits64" -> Some Pbe_bits64 103 | | "bytes" -> Some Pbe_bytes 104 | | _ -> None 105 | 106 | let rec string_of_pb_type kind = 107 | match kind with 108 | | Pbt_bool -> "bool" 109 | | Pbt_int -> "int" 110 | | Pbt_int32 -> "Int32.t" 111 | | Pbt_int64 -> "Int64.t" 112 | | Pbt_uint32 -> "Uint32.t" 113 | | Pbt_uint64 -> "Uint64.t" 114 | | Pbt_float -> "float" 115 | | Pbt_string -> "string" 116 | | Pbt_bytes -> "bytes" 117 | | Pbt_imm ptyp -> 118 | Ppx_deriving.string_of_core_type ptyp 119 | | Pbt_variant constrs -> 120 | String.concat " | " (List.map snd constrs) 121 | | Pbt_nested (args, lid) -> 122 | begin match args with 123 | | [] -> "" 124 | | args -> Printf.sprintf "(%s) " (String.concat ", " 125 | (List.map Ppx_deriving.string_of_core_type args)) 126 | end ^ string_of_lident lid 127 | | Pbt_poly var -> "'" ^ var 128 | 129 | let string_payload_kind_of_pb_encoding enc = 130 | "Protobuf." ^ 131 | match enc with 132 | | Pbe_varint | Pbe_zigzag -> "Varint" 133 | | Pbe_bytes | Pbe_packed _ -> "Bytes" 134 | | Pbe_bits32 -> "Bits32" 135 | | Pbe_bits64 -> "Bits64" 136 | 137 | let describe_error error = 138 | match error with 139 | | Pberr_attr_syntax (loc, attr) -> 140 | let name, expectation = 141 | match attr with 142 | | `Key -> "key", "a number, e.g. [@key 1]" 143 | | `Encoding -> "encoding", "one of: `bool, `varint, `zigzag, `bits32, `bits64, " ^ 144 | "`bytes, e.g. [@encoding `varint]" 145 | | `Bare -> "bare", "[@bare]" 146 | | `Default -> "default", "an expression, e.g. [@default \"foo\"]" 147 | | `Packed -> "packed", "[@packed]" 148 | in 149 | Location.raise_errorf ~loc "@%s attribute syntax is invalid: expected %s" name expectation 150 | | Pberr_wrong_attr (Attribute_patt(loc, txt, _)) -> 151 | Location.raise_errorf ~loc "Attribute @%s is not recognized here" txt 152 | | Pberr_no_key loc -> 153 | Location.raise_errorf ~loc "Type specification must include a key attribute, e.g. int [@key 42]" 154 | | Pberr_key_invalid (loc, key) -> 155 | if key >= 19000 && key <= 19999 then 156 | Location.raise_errorf ~loc "Key %d is in reserved range [19000:19999]" key 157 | else 158 | Location.raise_errorf ~loc "Key %d is outside of valid range [1:0x1fffffff]" key 159 | | Pberr_key_duplicate (key, loc1, loc2) -> 160 | Location.raise_errorf ~loc:loc1 "Key %d is already used" key 161 | #if OCAML_VERSION >= (4, 08, 0) 162 | ~sub:[Ocaml_common.Location.msg ~loc:loc2 "Initially defined here"] 163 | #else 164 | ~sub:[Location.raise_errorf ~loc:loc2 "Initially defined here"] 165 | #endif 166 | | Pberr_abstract { ptype_loc = loc } -> 167 | Location.raise_errorf ~loc "Abstract types are not supported" 168 | | Pberr_open { ptype_loc = loc } -> 169 | Location.raise_errorf ~loc "Open types are not supported" 170 | | Pberr_wrong_ty ({ ptyp_loc = loc } as ptyp) -> 171 | Location.raise_errorf ~loc "Type %s does not have a Protobuf mapping" 172 | (Ppx_deriving.string_of_core_type ptyp) 173 | | Pberr_wrong_tparm ({ ptyp_loc = loc } as ptyp) -> 174 | Location.raise_errorf ~loc "Type %s cannot be used as a type parameter" 175 | (Ppx_deriving.string_of_core_type ptyp) 176 | | Pberr_no_conversion (loc, kind, enc) -> 177 | Location.raise_errorf ~loc "\"%s\" is not a valid representation for %s" 178 | (string_of_pb_encoding enc) (string_of_pb_type kind) 179 | | Pberr_packed_bytes loc -> 180 | Location.raise_errorf ~loc "Only fields with varint, bits32 or bits64 encoding may be packed" 181 | | Pberr_dumb_protoc loc -> 182 | Location.raise_errorf ~loc "Parametric types are not supported when exporting to protoc" 183 | | Pberr_ocaml_expr loc -> 184 | Location.raise_errorf ~loc "Nontrivial OCaml expressions cannot be exported to protoc" 185 | 186 | let () = 187 | Location.Error.register_error_of_exn (fun exn -> 188 | match exn with 189 | | Error err -> Some (describe_error err) 190 | | _ -> None) 191 | 192 | let deriver = "protobuf" 193 | 194 | let pb_key_of_attrs attrs = 195 | match Ppx_deriving.attr ~deriver "key" attrs with 196 | | Some (Attribute_patt(loc, _, 197 | (PStr [[%stri [%e? { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) }]]]))) -> 198 | let key = int_of_string sn in 199 | if key < 1 || key > 0x1fffffff || (key >= 19000 && key <= 19999) then 200 | raise (Error (Pberr_key_invalid (loc, key))); 201 | Some key 202 | | Some (Attribute_patt(loc, _, _)) -> raise (Error (Pberr_attr_syntax (loc, `Key))) 203 | | None -> None 204 | 205 | let pb_encoding_of_attrs attrs = 206 | match Ppx_deriving.attr ~deriver "encoding" attrs with 207 | | Some (Attribute_patt(loc, _, PStr [[%stri [%e? { pexp_desc = Pexp_variant (kind, None) }]]])) -> 208 | begin match pb_encoding_of_string kind with 209 | | Some x -> Some x 210 | | None -> raise (Error (Pberr_attr_syntax (loc, `Encoding))) 211 | end 212 | | Some (Attribute_patt(loc, _, _)) -> raise (Error (Pberr_attr_syntax (loc, `Encoding))) 213 | | None -> None 214 | 215 | let bare_of_attrs attrs = 216 | match Ppx_deriving.attr ~deriver "bare" attrs with 217 | | Some (Attribute_patt(_, _, PStr [])) -> true 218 | | Some (Attribute_patt(loc, _, _)) -> raise (Error (Pberr_attr_syntax (loc, `Bare))) 219 | | None -> false 220 | 221 | let default_of_attrs attrs = 222 | match Ppx_deriving.attr ~deriver "default" attrs with 223 | | Some (Attribute_patt(_, _, PStr [[%stri [%e? expr]]])) -> Some expr 224 | | Some (Attribute_patt(loc, _, _)) -> raise (Error (Pberr_attr_syntax (loc, `Default))) 225 | | None -> None 226 | 227 | let packed_of_attrs attrs = 228 | match Ppx_deriving.attr ~deriver "packed" attrs with 229 | | Some (Attribute_patt(_, _, PStr [])) -> true 230 | | Some (Attribute_patt(loc, _, _)) -> raise (Error (Pberr_attr_syntax (loc, `Packed))) 231 | | None -> false 232 | 233 | let fields_of_ptype base_path ptype = 234 | let rec field_of_ptyp pbf_name pbf_extname pbf_path pbf_key pbf_kind ptyp = 235 | match ptyp with 236 | | [%type: [%t? arg] option] -> 237 | begin match pbf_kind with 238 | | Pbk_required -> 239 | field_of_ptyp pbf_name pbf_extname pbf_path pbf_key Pbk_optional 240 | { arg with ptyp_attributes = ptyp.ptyp_attributes @ arg.ptyp_attributes } 241 | | _ -> raise (Error (Pberr_wrong_ty ptyp)) 242 | end 243 | | [%type: [%t? arg] array] | [%type: [%t? arg] list] -> 244 | begin match pbf_kind with 245 | | Pbk_required -> 246 | let { pbf_enc } as field = 247 | field_of_ptyp pbf_name pbf_extname pbf_path pbf_key Pbk_repeated 248 | { arg with ptyp_attributes = ptyp.ptyp_attributes @ arg.ptyp_attributes } 249 | in 250 | let pbf_enc = 251 | if packed_of_attrs ptyp.ptyp_attributes then Pbe_packed pbf_enc else pbf_enc 252 | in 253 | if pbf_enc = Pbe_packed Pbe_bytes then 254 | raise (Error (Pberr_packed_bytes ptyp.ptyp_loc)); 255 | { field with pbf_enc } 256 | | _ -> raise (Error (Pberr_wrong_ty ptyp)) 257 | end 258 | | { ptyp_desc = (Ptyp_tuple _ | Ptyp_variant _ | Ptyp_var _) as desc; 259 | ptyp_attributes = attrs; ptyp_loc; } -> 260 | let pbf_key = 261 | match pb_key_of_attrs attrs with 262 | | Some key -> key 263 | | None -> 264 | match pbf_key with 265 | | Some k -> k 266 | | None -> raise (Error (Pberr_no_key ptyp_loc)) 267 | in 268 | let pbf_enc, pbf_type = 269 | match desc with 270 | | Ptyp_variant _ -> 271 | (if bare_of_attrs attrs then Pbe_varint else Pbe_bytes), Pbt_imm ptyp 272 | | Ptyp_tuple _ -> Pbe_bytes, Pbt_imm ptyp 273 | | Ptyp_var var -> Pbe_bytes, Pbt_poly var 274 | | _ -> assert false 275 | in 276 | { pbf_name; pbf_extname; pbf_key; pbf_kind; pbf_path; pbf_type; pbf_enc; 277 | pbf_loc = ptyp_loc; 278 | pbf_default = default_of_attrs attrs; } 279 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args); ptyp_attributes = attrs; ptyp_loc; } -> 280 | let pbf_type = 281 | match args, lid with 282 | | [], Lident "bool" -> Pbt_bool 283 | | [], Lident "int" -> Pbt_int 284 | | [], Lident "float" -> Pbt_float 285 | | [], (Lident "string" | Ldot (Lident "String", "t")) -> Pbt_string 286 | | [], (Lident "bytes" | Ldot (Lident "Bytes", "t")) -> Pbt_bytes 287 | | [], (Lident "int32" | Ldot (Lident "Int32", "t")) -> Pbt_int32 288 | | [], (Lident "int64" | Ldot (Lident "Int64", "t")) -> Pbt_int64 289 | | [], (Lident "uint32" | Ldot (Lident "Uint32", "t")) -> Pbt_uint32 290 | | [], (Lident "uint64" | Ldot (Lident "Uint64", "t")) -> Pbt_uint64 291 | | _, lident -> Pbt_nested (args, lident) 292 | in 293 | let pbf_key = 294 | match pb_key_of_attrs attrs with 295 | | Some key -> key 296 | | None -> 297 | match pbf_key with 298 | | Some k -> k 299 | | None -> raise (Error (Pberr_no_key ptyp_loc)) 300 | in 301 | let pbf_enc = 302 | match pb_encoding_of_attrs attrs with 303 | | Some enc -> enc 304 | | None -> 305 | match pbf_type with 306 | | Pbt_float -> Pbe_bits64 307 | | Pbt_bool | Pbt_int -> Pbe_varint 308 | | Pbt_int32 | Pbt_uint32 -> Pbe_bits32 309 | | Pbt_int64 | Pbt_uint64 -> Pbe_bits64 310 | | Pbt_string | Pbt_bytes 311 | | Pbt_imm _ | Pbt_poly _ -> Pbe_bytes 312 | | Pbt_nested _ -> 313 | if bare_of_attrs attrs then Pbe_varint else Pbe_bytes 314 | | Pbt_variant _ -> assert false 315 | in 316 | begin match pbf_type, pbf_enc with 317 | | Pbt_bool, Pbe_varint 318 | | (Pbt_int | Pbt_int32 | Pbt_int64 | Pbt_uint32 | Pbt_uint64), 319 | (Pbe_varint | Pbe_zigzag | Pbe_bits32 | Pbe_bits64) 320 | | Pbt_float, (Pbe_bits32 | Pbe_bits64) 321 | | (Pbt_string | Pbt_bytes), Pbe_bytes 322 | | Pbt_nested _, (Pbe_bytes | Pbe_varint) -> 323 | { pbf_name; pbf_extname; pbf_key; pbf_enc; pbf_type; pbf_kind; pbf_path; 324 | pbf_loc = ptyp_loc; 325 | pbf_default = default_of_attrs attrs } 326 | | _ -> 327 | raise (Error (Pberr_no_conversion (ptyp_loc, pbf_type, pbf_enc))) 328 | end 329 | | { ptyp_desc = Ptyp_alias (ptyp', _) } -> 330 | field_of_ptyp pbf_name pbf_extname pbf_path pbf_key pbf_kind ptyp' 331 | | ptyp -> raise (Error (Pberr_wrong_ty ptyp)) 332 | in 333 | let fields_of_variant loc constrs = 334 | let constrs' = 335 | constrs |> List.map (fun ((name, args, attrs, loc) as pcd) -> 336 | match pb_key_of_attrs attrs with 337 | | Some key -> key, pcd 338 | | None -> raise (Error (Pberr_no_key loc))) 339 | in 340 | constrs' |> List.iter (fun (key, (_, _, _, loc) as pcd) -> 341 | constrs' |> List.iter (fun (key', (_, _, _, loc') as pcd') -> 342 | if pcd != pcd' && key = key' then 343 | raise (Error (Pberr_key_duplicate (key, loc', loc))))); 344 | { pbf_name = "variant"; 345 | pbf_extname = "tag"; 346 | pbf_path = base_path; 347 | pbf_key = 1; 348 | pbf_enc = Pbe_varint; 349 | pbf_type = Pbt_variant (constrs' |> List.map (fun (key, (name, _, _, _)) -> key, name)); 350 | pbf_kind = Pbk_required; 351 | pbf_loc = loc; 352 | pbf_default = None; } :: 353 | (constrs |> filter_map (fun (name, args, attrs, loc) -> 354 | let ptyp = 355 | match args with 356 | | [] -> None 357 | | [arg] -> Some arg 358 | | args -> Some (Typ.tuple args) 359 | in 360 | match ptyp with 361 | | Some ptyp -> 362 | let key = 1 + (match pb_key_of_attrs attrs with 363 | | Some key -> key | None -> assert false) in 364 | Some (field_of_ptyp (Printf.sprintf "constr_%s" name) name 365 | (base_path @ [name]) (Some key) Pbk_required ptyp) 366 | | None -> None)) 367 | in 368 | let fields = 369 | match ptype with 370 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some { ptyp_desc = Ptyp_tuple ptyps } } -> 371 | ptyps |> List.mapi (fun i ptyp -> 372 | field_of_ptyp (Printf.sprintf "elem_%d" i) (Printf.sprintf "_%d" i) 373 | (base_path @ [string_of_int i]) (Some (i + 1)) Pbk_required ptyp) 374 | | { ptype_kind = Ptype_abstract; 375 | ptype_manifest = Some ({ ptyp_desc = Ptyp_variant (rows, _, _); ptyp_loc } as ptyp); 376 | ptype_loc; } -> 377 | rows |> List.map (fun row_field -> 378 | match row_field with 379 | | Rtag_patt(name, attrs, _, []) -> 380 | (name, [], attrs, ptyp_loc) 381 | | Rtag_patt(name, attrs, _, [a]) -> 382 | (name, [a], attrs, ptyp_loc) 383 | | _ -> raise (Error (Pberr_wrong_ty ptyp))) |> 384 | fields_of_variant ptype_loc 385 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some ptyp } -> 386 | [field_of_ptyp "alias" "_" base_path (Some 1) Pbk_required ptyp] 387 | | { ptype_kind = Ptype_abstract; ptype_manifest = None } -> 388 | raise (Error (Pberr_abstract ptype)) 389 | | { ptype_kind = Ptype_open } -> 390 | raise (Error (Pberr_open ptype)) 391 | | { ptype_kind = Ptype_record fields } -> 392 | fields |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes; } -> 393 | field_of_ptyp ("field_" ^ name) name (base_path @ [name]) None Pbk_required 394 | { pld_type with ptyp_attributes = pld_attributes @ pld_type.ptyp_attributes }) 395 | | { ptype_kind = Ptype_variant constrs; ptype_loc } -> 396 | constrs 397 | |> List.map (fun { pcd_name = { txt = name }; pcd_args; pcd_attributes; pcd_loc; } -> 398 | (name, pcd_args, pcd_attributes, pcd_loc) 399 | ) 400 | |> List.map (fun (name, pcd_args, pcd_attributes, pcd_loc) -> 401 | match pcd_args with 402 | | Pcstr_tuple pcd_args -> (name, pcd_args, pcd_attributes, pcd_loc) 403 | | Pcstr_record pcd_label_args -> 404 | (* For now inline record are treated just like tuple (hence the key will be 405 | automatically generated starting at 1) 406 | 407 | Since inline records support attributes, protobuf keys could be 408 | customized: 409 | 410 | `| F {f10 [@key 10] : int; f11 [@key 11] :string}` 411 | *) 412 | let pcd_args = List.map (fun {pld_type; _ } -> pld_type) pcd_label_args in 413 | (name, pcd_args, pcd_attributes, pcd_loc) 414 | ) 415 | |> fields_of_variant ptype_loc 416 | in 417 | fields |> List.iter (fun field -> 418 | fields |> List.iter (fun field' -> 419 | if field != field' && field.pbf_key = field'.pbf_key then 420 | raise (Error (Pberr_key_duplicate (field.pbf_key, field'.pbf_loc, field.pbf_loc))))); 421 | fields |> List.sort (fun { pbf_key = a } { pbf_key = b } -> compare a b) 422 | 423 | let empty_constructor_argument {pcd_args; _ } = 424 | match pcd_args with 425 | | Pcstr_tuple [] | Pcstr_record [] -> true 426 | | _ -> false 427 | 428 | let int64_constant_of_int i = 429 | Pconst_integer (string_of_int i, Some 'L') 430 | 431 | let derive_reader_bare base_path fields ptype = 432 | let mk_variant mk_constr constrs = 433 | let rec mk_variant_cases constrs = 434 | match constrs with 435 | | (name, attrs) :: rest -> 436 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 437 | (Exp.case (Pat.constant (int64_constant_of_int key)) 438 | (mk_constr name)) :: mk_variant_cases rest 439 | | [] -> 440 | let field_name = String.concat "." base_path in 441 | let loc = !default_loc in 442 | [Exp.case [%pat? _] [%expr raise Protobuf.Decoder. 443 | (Failure (Malformed_variant [%e str field_name]))]] 444 | in 445 | let matcher = 446 | let loc = !default_loc in 447 | Exp.match_ [%expr Protobuf.Decoder.varint decoder] 448 | (mk_variant_cases constrs) in 449 | let loc = !default_loc in 450 | Some (Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "from_protobuf_bare") ptype)) 451 | [%expr fun decoder -> [%e Ppx_deriving.sanitize matcher]]) 452 | in 453 | 454 | match ptype with 455 | | { ptype_kind = Ptype_variant constrs } when 456 | List.for_all empty_constructor_argument constrs -> 457 | constrs |> List.map (fun { pcd_name = { txt = name }; pcd_attributes } -> 458 | name, pcd_attributes) |> mk_variant (fun name -> constr name []) 459 | | { ptype_kind = Ptype_abstract; 460 | ptype_manifest = Some { ptyp_desc = Ptyp_variant (rows, _, _) } } when 461 | List.for_all (fun row_field -> 462 | match row_field with 463 | Rtag_patt(_, _, _, []) -> true | _ -> false) rows -> 464 | rows |> List.map (fun row_field -> 465 | match row_field with 466 | | Rtag_patt(name, attrs, _, []) -> 467 | (name, attrs) 468 | | _ -> assert false) |> mk_variant (fun name -> Exp.variant name None) 469 | | _ -> None 470 | 471 | let rec derive_reader base_path fields ptype = 472 | let rec mk_imm_readers fields k = 473 | match fields with 474 | | { pbf_type = Pbt_imm ptyp; pbf_name; pbf_path; } :: rest -> 475 | (* Manufacture a structure just for this immediate *) 476 | let ptype = Type.mk ~manifest:ptyp (mkloc ("_" ^ pbf_name) !default_loc) in 477 | (* Order is important, derive_reader does less checks than derive_reader_bare. *) 478 | let reader = derive_reader pbf_path (fields_of_ptype pbf_path ptype) ptype in 479 | Exp.let_ Nonrecursive 480 | (reader :: (match derive_reader_bare pbf_path fields ptype with 481 | | Some x -> [x] | None -> [])) 482 | (mk_imm_readers rest k) 483 | | _ :: rest -> mk_imm_readers rest k 484 | | [] -> k 485 | in 486 | let rec mk_cells fields k = 487 | match fields with 488 | | { pbf_kind = (Pbk_required | Pbk_optional) } as field :: rest -> 489 | let loc = !default_loc in 490 | [%expr let [%p pvar field.pbf_name] = ref None in [%e mk_cells rest k]] 491 | | { pbf_kind = Pbk_repeated } as field :: rest -> 492 | let loc = !default_loc in 493 | [%expr let [%p pvar field.pbf_name] = ref [] in [%e mk_cells rest k]] 494 | | [] -> k 495 | in 496 | let rec mk_reader ({ pbf_name; pbf_path; pbf_enc; pbf_type; } as field) = 497 | let loc = !default_loc in 498 | let value = 499 | let ident = Exp.ident (lid ("Protobuf.Decoder." ^ (string_of_pb_encoding pbf_enc))) in 500 | [%expr [%e ident] decoder] 501 | in 502 | let field_name = String.concat "." pbf_path in 503 | match pbf_type, pbf_enc with 504 | (* bool *) 505 | | Pbt_bool, Pbe_varint -> 506 | [%expr Protobuf.Decoder.bool_of_int64 [%e str field_name] [%e value]] 507 | (* int *) 508 | | Pbt_int, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 509 | [%expr Protobuf.Decoder.int_of_int64 [%e str field_name] [%e value]] 510 | | Pbt_int, Pbe_bits32 -> 511 | [%expr Protobuf.Decoder.int_of_int32 [%e str field_name] [%e value]] 512 | (* int32 *) 513 | | Pbt_int32, Pbe_bits32 -> value 514 | | Pbt_int32, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 515 | [%expr Protobuf.Decoder.int32_of_int64 [%e str field_name] [%e value]] 516 | (* int64 *) 517 | | Pbt_int64, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> value 518 | | Pbt_int64, Pbe_bits32 -> 519 | [%expr Int64.of_int32 [%e value]] 520 | (* uint32 *) 521 | | Pbt_uint32, Pbe_bits32 -> 522 | [%expr Uint32.of_int32 [%e value]] 523 | | Pbt_uint32, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 524 | [%expr Uint32.of_int32 (Protobuf.Decoder.int32_of_int64 [%e str field_name] [%e value])] 525 | (* uint64 *) 526 | | Pbt_uint64, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 527 | [%expr Uint64.of_int64 [%e value]] 528 | | Pbt_uint64, Pbe_bits32 -> 529 | [%expr Uint64.of_int32 [%e value]] 530 | (* float *) 531 | | Pbt_float, Pbe_bits32 -> 532 | [%expr Int32.float_of_bits [%e value]] 533 | | Pbt_float, Pbe_bits64 -> 534 | [%expr Int64.float_of_bits [%e value]] 535 | (* string *) 536 | | Pbt_string, Pbe_bytes -> [%expr Bytes.to_string [%e value]] 537 | (* bytes *) 538 | | Pbt_bytes, Pbe_bytes -> value 539 | (* variant *) 540 | | Pbt_variant _, Pbe_varint -> value 541 | (* nested *) 542 | | Pbt_nested (args, lid), Pbe_bytes -> 543 | let reader lid = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "from_protobuf") lid)) in 544 | let rec expr_of_core_type ptyp = 545 | match ptyp with 546 | | { ptyp_desc = Ptyp_var tvar } -> evar ("poly_" ^ tvar) 547 | | { ptyp_desc = Ptyp_constr({ txt = lid }, []) } -> reader lid 548 | | { ptyp_desc = Ptyp_constr({ txt = lid }, ptyps) } -> 549 | app (reader lid) (List.map expr_of_core_type ptyps) 550 | | ptyp -> raise (Error (Pberr_wrong_tparm ptyp)) 551 | in 552 | app (reader lid) ((List.map expr_of_core_type args) @ [[%expr Protobuf.Decoder.nested decoder]]) 553 | | Pbt_nested ([], lid), Pbe_varint -> (* bare enum *) 554 | let ident = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "from_protobuf_bare") lid)) in 555 | [%expr [%e ident] decoder] 556 | (* immediate *) 557 | | Pbt_imm _, Pbe_bytes -> 558 | let ident = evar ("_" ^ pbf_name ^ "_from_protobuf") in 559 | [%expr [%e ident] (Protobuf.Decoder.nested decoder)] 560 | | Pbt_imm _, Pbe_varint -> 561 | let ident = evar ("_" ^ pbf_name ^ "_from_protobuf_bare") in 562 | [%expr [%e ident] decoder] 563 | (* poly *) 564 | | Pbt_poly var, Pbe_bytes -> 565 | [%expr [%e evar ("poly_" ^ var)] (Protobuf.Decoder.nested decoder)] 566 | (* packed *) 567 | | ty, Pbe_packed pbf_enc -> 568 | let _reader = mk_reader { field with pbf_enc } in 569 | [%expr assert false] 570 | | _ -> assert false 571 | in 572 | let rec mk_field_cases fields = 573 | match fields with 574 | | { pbf_key; pbf_name; pbf_enc; pbf_type; pbf_kind; pbf_path } as field :: rest -> 575 | begin match pbf_kind, pbf_enc with 576 | | Pbk_repeated, ((Pbe_varint | Pbe_zigzag | Pbe_bits64 | Pbe_bits32) as pbf_enc 577 | | Pbe_packed pbf_enc) -> 578 | (* always recognize packed fields *) 579 | let loc = !default_loc in 580 | [Exp.case [%pat? (Some ([%p pint pbf_key], Protobuf.Bytes))] 581 | [%expr [%e evar pbf_name] := 582 | (let decoder = Protobuf.Decoder.nested decoder in 583 | let rec read rest = 584 | let value = [%e mk_reader { field with pbf_enc }] in 585 | if Protobuf.Decoder.at_end decoder then value :: rest 586 | else read (value :: rest) 587 | in read ![%e evar pbf_name]); read ()]] 588 | | _ -> [] 589 | end @ 590 | let pbf_enc, updated = 591 | match pbf_enc, pbf_kind with 592 | | pbf_enc, (Pbk_required | Pbk_optional) -> 593 | let loc = !default_loc in 594 | pbf_enc, [%expr Some [%e mk_reader field]] 595 | | (Pbe_packed pbf_enc | pbf_enc), Pbk_repeated -> 596 | let loc = !default_loc in 597 | pbf_enc, [%expr [%e mk_reader field] :: ![%e evar pbf_name]] 598 | in 599 | let field_name = String.concat "." pbf_path in 600 | let payload_enc = string_payload_kind_of_pb_encoding pbf_enc in 601 | let loc = !default_loc in 602 | (Exp.case [%pat? Some ([%p pint pbf_key], [%p pconstr payload_enc []])] 603 | [%expr [%e evar pbf_name] := [%e updated]; read ()]) :: 604 | (Exp.case [%pat? Some ([%p pint pbf_key], kind)] 605 | [%expr raise Protobuf.Decoder.(Failure 606 | (Unexpected_payload ([%e str field_name], kind)))]) :: 607 | mk_field_cases rest 608 | | [] -> [] 609 | in 610 | let matcher = 611 | let loc = !default_loc in 612 | Exp.match_ [%expr Protobuf.Decoder.key decoder] 613 | ((mk_field_cases fields) @ 614 | [Exp.case [%pat? Some (_, kind)] 615 | [%expr Protobuf.Decoder.skip decoder kind; read ()]; 616 | Exp.case [%pat? None] [%expr ()]]) 617 | in 618 | let construct_ptyp pbf_name ptyp = 619 | let { pbf_path; pbf_default } = 620 | fields |> List.find (fun { pbf_name = pbf_name' } -> pbf_name' = pbf_name) 621 | in 622 | match ptyp with 623 | | [%type: [%t? _] option] -> 624 | let loc = !default_loc in 625 | [%expr ![%e evar pbf_name]] 626 | | [%type: [%t? _] list] -> 627 | let loc = !default_loc in 628 | [%expr List.rev (![%e evar pbf_name])] 629 | | [%type: [%t? _] array] -> 630 | let loc = !default_loc in 631 | [%expr Array.of_list (List.rev (![%e evar pbf_name]))] 632 | | { ptyp_desc = (Ptyp_constr _ | Ptyp_tuple _ | Ptyp_variant _ | Ptyp_var _); } -> 633 | let field_name = String.concat "." pbf_path in 634 | let loc = !default_loc in 635 | let default = [%expr raise Protobuf.Decoder.(Failure (Missing_field [%e str field_name]))] in 636 | let default = match pbf_default with Some x -> x | None -> default in 637 | [%expr match ![%e evar pbf_name] with None -> [%e default] | Some v -> v ] 638 | | _ -> assert false 639 | in 640 | let mk_variant ptype_name ptype_loc mk_constr constrs = 641 | let loc = ptype_loc in 642 | let with_args = 643 | constrs |> filter_map (fun pcd -> 644 | match pcd with 645 | | (name, [], attrs) -> None 646 | | (name, args, attrs) -> Some name) 647 | in 648 | let rec mk_variant_cases constrs = 649 | match constrs with 650 | | (name, args, attrs) :: rest -> 651 | let field = try Some (List.find (fun { pbf_name } -> pbf_name = "constr_" ^ name) fields) 652 | with Not_found -> None in 653 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 654 | let pkey = [%pat? Some [%p Pat.constant (int64_constant_of_int key)]] in 655 | let pargs = 656 | with_args |> List.map (fun name' -> 657 | let field' = List.find (fun { pbf_name } -> pbf_name = "constr_" ^ name') fields in 658 | match field'.pbf_kind with 659 | | Pbk_required -> if name = name' then [%pat? Some arg] else [%pat? None] 660 | | Pbk_optional -> if name = name' then [%pat? arg] else [%pat? None] 661 | | Pbk_repeated -> if name = name' then [%pat? arg] else [%pat? []]) 662 | in 663 | let pat = match pargs with [] -> pkey | pargs -> ptuple (pkey :: pargs) in 664 | begin match args with 665 | | [] -> 666 | Exp.case pat (mk_constr name []) 667 | | [arg] -> 668 | begin match field, arg with 669 | | Some { pbf_kind = (Pbk_required | Pbk_optional) }, _ -> 670 | Exp.case pat (mk_constr name [[%expr arg]]) 671 | | Some { pbf_kind = Pbk_repeated }, [%type: [%t? _] list] -> 672 | Exp.case pat (mk_constr name [[%expr List.rev arg]]) 673 | | Some { pbf_kind = Pbk_repeated }, [%type: [%t? _] array] -> 674 | Exp.case pat (mk_constr name [[%expr Array.of_list (List.rev arg)]]) 675 | | _ -> assert false 676 | end 677 | | args' -> (* Annoying constructor corner case *) 678 | let pargs', eargs' = 679 | List.mapi (fun i _ -> 680 | let name = Printf.sprintf "a%d" i in pvar name, evar name) args' |> 681 | List.split 682 | in 683 | Exp.case pat [%expr let [%p ptuple pargs'] = arg in [%e mk_constr name eargs']] 684 | end :: mk_variant_cases rest 685 | | [] -> 686 | let field_name = String.concat "." base_path in 687 | [Exp.case [%pat? _] [%expr raise Protobuf.Decoder. 688 | (Failure (Malformed_variant [%e str field_name]))]] 689 | in 690 | let input = 691 | match with_args with 692 | | [] -> [%expr !variant] 693 | | args -> (tuple ([%expr !variant] :: 694 | List.map (fun name -> [%expr ![%e evar ("constr_" ^ name)]]) with_args)) 695 | in 696 | Exp.match_ input (mk_variant_cases constrs) 697 | in 698 | let constructor = 699 | match ptype with 700 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some { ptyp_desc = Ptyp_tuple ptyps } } -> 701 | Exp.tuple (List.mapi (fun i ptyp -> 702 | construct_ptyp (Printf.sprintf "elem_%d" i) ptyp) ptyps) 703 | | { ptype_name; ptype_loc; 704 | ptype_kind = Ptype_abstract; 705 | ptype_manifest = Some { ptyp_desc = Ptyp_variant (rows, _, _) } } -> 706 | rows |> List.map (fun row_field -> 707 | match row_field with 708 | | Rtag_patt(name, attrs, _, args) -> 709 | (name, args, attrs) 710 | | _ -> assert false) |> mk_variant ptype_name ptype_loc 711 | (fun name args -> 712 | match args with 713 | | [] -> Exp.variant name None 714 | | [arg] -> Exp.variant name (Some arg) 715 | | args -> Exp.variant name (Some (tuple args))) 716 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some ptyp } -> 717 | construct_ptyp "alias" ptyp 718 | | { ptype_kind = (Ptype_abstract | Ptype_open) } -> 719 | assert false 720 | | { ptype_kind = Ptype_record fields; } -> 721 | Exp.record (List.mapi (fun i { pld_name; pld_type; } -> 722 | lid pld_name.txt, construct_ptyp ("field_" ^ pld_name.txt) pld_type) fields) None 723 | | { ptype_kind = Ptype_variant constrs; ptype_name; ptype_loc } -> 724 | constrs 725 | |> List.map (fun { pcd_name = { txt = name}; pcd_args; pcd_attributes; } -> 726 | name, pcd_args, pcd_attributes 727 | ) 728 | |> List.map (fun (name, pcd_args, pcd_attributes) -> 729 | match pcd_args with 730 | | Pcstr_tuple pcd_args -> (name, pcd_args, pcd_attributes) 731 | | Pcstr_record pcd_label_args -> 732 | let pcd_args = List.map (fun {pld_type; _ } -> pld_type) pcd_label_args in 733 | (name, pcd_args, pcd_attributes) 734 | ) 735 | |> mk_variant ptype_name ptype_loc constr 736 | in 737 | let loc = !default_loc in 738 | let read = 739 | [%expr let rec read () = [%e matcher] in read (); [%e constructor]] |> 740 | mk_cells fields |> 741 | mk_imm_readers fields 742 | in 743 | Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "from_protobuf") ptype)) 744 | (Ppx_deriving.poly_fun_of_type_decl ptype 745 | [%expr fun decoder -> [%e Ppx_deriving.sanitize read]]) 746 | 747 | let derive_writer_bare fields ptype = 748 | let mk_variant mk_pconstr constrs = 749 | let rec mk_variant_cases constrs = 750 | match constrs with 751 | | (name, attrs) :: rest -> 752 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 753 | (Exp.case (mk_pconstr name) 754 | (Exp.constant (int64_constant_of_int key))) :: 755 | mk_variant_cases rest 756 | | [] -> [] 757 | in 758 | let loc = !default_loc in 759 | let matcher = Exp.match_ [%expr value] (mk_variant_cases constrs) in 760 | let writer = [%expr Protobuf.Encoder.varint [%e matcher] encoder] in 761 | Some (Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "to_protobuf_bare") ptype)) 762 | [%expr fun value encoder -> [%e Ppx_deriving.sanitize writer]]) 763 | in 764 | match ptype with 765 | | { ptype_kind = Ptype_variant constrs } when 766 | List.for_all empty_constructor_argument constrs -> 767 | constrs |> List.map (fun { pcd_name = { txt = name }; pcd_attributes } -> 768 | name, pcd_attributes) |> mk_variant (fun name -> pconstr name []) 769 | | { ptype_kind = Ptype_abstract; 770 | ptype_manifest = Some { ptyp_desc = Ptyp_variant (rows, _, _) } } when 771 | List.for_all (fun row_field -> 772 | match row_field with 773 | Rtag_patt(_, _, _, []) -> true | _ -> false) rows -> 774 | rows |> List.map (fun row_field -> 775 | match row_field with 776 | | Rtag_patt(name, attrs, _, []) -> 777 | (name, attrs) 778 | | _ -> assert false) |> mk_variant (fun name -> Pat.variant name None) 779 | | _ -> None 780 | 781 | let rec derive_writer fields ptype = 782 | let rec mk_imm_writers fields k = 783 | match fields with 784 | | { pbf_type = Pbt_imm ptyp; pbf_name; pbf_path; } :: rest -> 785 | (* Manufacture a structure just for this immediate *) 786 | let ptype = Type.mk ~manifest:ptyp (mknoloc ("_" ^ pbf_name)) in 787 | Exp.let_ Nonrecursive 788 | ((derive_writer (fields_of_ptype pbf_path ptype) ptype) :: 789 | (match derive_writer_bare fields ptype with 790 | | Some x -> [x] | None -> [])) 791 | (mk_imm_writers rest k) 792 | | _ :: rest -> mk_imm_writers rest k 793 | | [] -> k 794 | in 795 | let mk_value_writer { pbf_name; pbf_path; pbf_enc; pbf_type; } = 796 | let loc = !default_loc in 797 | let encode v = 798 | let ident = Exp.ident (lid ("Protobuf.Encoder." ^ (string_of_pb_encoding pbf_enc))) in 799 | [%expr [%e ident] [%e v] encoder] 800 | in 801 | let field_name = String.concat "." pbf_path in 802 | match pbf_type, pbf_enc with 803 | (* bool *) 804 | | Pbt_bool, Pbe_varint -> 805 | encode [%expr if [%e evar pbf_name] then 1L else 0L] 806 | (* int *) 807 | | Pbt_int, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 808 | encode [%expr Int64.of_int [%e evar pbf_name]] 809 | | Pbt_int, Pbe_bits32 -> 810 | encode [%expr Protobuf.Encoder.int32_of_int [%e str field_name] [%e evar pbf_name]] 811 | (* int32 *) 812 | | Pbt_int32, Pbe_bits32 -> encode (evar pbf_name) 813 | | Pbt_int32, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 814 | encode [%expr Int64.of_int32 [%e evar pbf_name]] 815 | (* int64 *) 816 | | Pbt_int64, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> encode (evar pbf_name) 817 | | Pbt_int64, Pbe_bits32 -> 818 | encode [%expr Protobuf.Encoder.int32_of_int64 [%e str field_name] [%e evar pbf_name]] 819 | (* uint32 *) 820 | | Pbt_uint32, Pbe_bits32 -> 821 | encode [%expr Uint32.to_int32 [%e evar pbf_name]] 822 | | Pbt_uint32, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 823 | encode [%expr Int64.of_int32 (Uint32.to_int32 [%e evar pbf_name])] 824 | (* uint64 *) 825 | | Pbt_uint64, (Pbe_varint | Pbe_zigzag | Pbe_bits64) -> 826 | encode [%expr Uint64.to_int64 [%e evar pbf_name]] 827 | | Pbt_uint64, Pbe_bits32 -> 828 | encode [%expr Protobuf.Encoder.int32_of_int64 [%e str field_name] 829 | (Uint64.to_int64 [%e evar pbf_name])] 830 | (* float *) 831 | | Pbt_float, Pbe_bits32 -> 832 | encode [%expr Int32.bits_of_float [%e evar pbf_name]] 833 | | Pbt_float, Pbe_bits64 -> 834 | encode [%expr Int64.bits_of_float [%e evar pbf_name]] 835 | (* string *) 836 | | Pbt_string, Pbe_bytes -> encode [%expr Bytes.of_string [%e evar pbf_name]] 837 | (* bytes *) 838 | | Pbt_bytes, Pbe_bytes -> encode (evar pbf_name) 839 | (* variant *) 840 | | Pbt_variant _, Pbe_varint -> encode (evar pbf_name) 841 | (* nested *) 842 | | Pbt_nested (args, lid), Pbe_bytes -> 843 | let writer lid = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "to_protobuf") lid)) in 844 | let rec expr_of_core_type ptyp = 845 | match ptyp with 846 | | { ptyp_desc = Ptyp_var tvar } -> evar ("poly_" ^ tvar) 847 | | { ptyp_desc = Ptyp_constr({ txt = lid }, []) } -> writer lid 848 | | { ptyp_desc = Ptyp_constr({ txt = lid }, ptyps) } -> 849 | app (writer lid) (List.map expr_of_core_type ptyps) 850 | | _ -> raise (Error (Pberr_wrong_tparm ptyp)) 851 | in 852 | [%expr Protobuf.Encoder.nested 853 | [%e app (writer lid) ((List.map expr_of_core_type args) @ [evar pbf_name])] encoder] 854 | | Pbt_nested ([], lid), Pbe_varint -> (* bare enum *) 855 | let ident = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "to_protobuf_bare") lid)) in 856 | [%expr ([%e ident] [%e evar pbf_name]) encoder] 857 | (* immediate *) 858 | | Pbt_imm _, Pbe_bytes -> 859 | let ident = evar ("_" ^ pbf_name ^ "_to_protobuf") in 860 | [%expr Protobuf.Encoder.nested ([%e ident] [%e evar pbf_name]) encoder] 861 | | Pbt_imm _, Pbe_varint -> 862 | let ident = evar ("_" ^ pbf_name ^ "_to_protobuf_bare") in 863 | [%expr [%e ident] [%e evar pbf_name] encoder] 864 | (* poly *) 865 | | Pbt_poly var, Pbe_bytes -> 866 | [%expr Protobuf.Encoder.nested ([%e evar ("poly_" ^ var)] [%e evar pbf_name]) encoder] 867 | | _ -> assert false 868 | in 869 | let mk_writer ({ pbf_name; pbf_kind; pbf_key; pbf_enc; pbf_default } as field) = 870 | let loc = !default_loc in 871 | let key_writer = [%expr Protobuf.Encoder.key ([%e int pbf_key ], 872 | [%e constr (string_payload_kind_of_pb_encoding pbf_enc) []]) encoder] in 873 | match pbf_kind, pbf_enc with 874 | | Pbk_required, _ -> 875 | let writer = [%expr [%e key_writer]; [%e mk_value_writer field]] in 876 | begin match pbf_default with 877 | | Some default -> [%expr if [%e evar pbf_name] <> [%e default] then [%e writer]] 878 | | None -> writer 879 | end 880 | | Pbk_optional, _ -> 881 | [%expr 882 | match [%e evar pbf_name] with 883 | | Some [%p pvar pbf_name] -> [%e key_writer]; [%e mk_value_writer field] 884 | | None -> ()] 885 | | Pbk_repeated, Pbe_packed pbf_enc -> 886 | let value_writer = mk_value_writer { field with pbf_enc } in 887 | [%expr 888 | if [%e evar pbf_name] <> [] then begin 889 | [%e key_writer]; 890 | Protobuf.Encoder.nested (fun encoder -> 891 | List.iter (fun [%p pvar pbf_name] -> [%e value_writer]) [%e evar pbf_name]) 892 | encoder 893 | end] 894 | | Pbk_repeated, _ -> 895 | [%expr 896 | List.iter (fun [%p pvar pbf_name] -> 897 | [%e key_writer]; [%e mk_value_writer field]) [%e evar pbf_name]] 898 | in 899 | let mk_writers fields = 900 | let loc = !default_loc in 901 | List.fold_right (fun field k -> 902 | [%expr [%e mk_writer field]; [%e k]]) fields [%expr ()] 903 | in 904 | let deconstruct_ptyp pbf_name ptyp k = 905 | match ptyp with 906 | | [%type: [%t? _] array] -> 907 | let loc = !default_loc in 908 | [%expr let [%p pvar pbf_name] = Array.to_list [%e evar pbf_name] in [%e k]] 909 | | [%type: [%t? _] option] 910 | | [%type: [%t? _] list] 911 | | { ptyp_desc = (Ptyp_constr _ | Ptyp_tuple _ | Ptyp_variant _ | Ptyp_var _); } -> 912 | k 913 | | _ -> assert false 914 | in 915 | let mk_variant mk_patt constrs = 916 | let rec mk_variant_cases constrs = 917 | match constrs with 918 | | (name, [], attrs) :: rest -> 919 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 920 | let ekey = Exp.constant (int64_constant_of_int key) in 921 | let loc = !default_loc in 922 | (Exp.case (mk_patt name []) [%expr Protobuf.Encoder.varint [%e ekey] encoder]) :: 923 | mk_variant_cases rest 924 | | (name, [arg], attrs) :: rest -> 925 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 926 | let ekey = Exp.constant (int64_constant_of_int key) in 927 | let field = List.find (fun { pbf_name } -> pbf_name = "constr_" ^ name) fields in 928 | let loc = !default_loc in 929 | (Exp.case (mk_patt name [pvar ("constr_" ^ name)]) 930 | (deconstruct_ptyp field.pbf_name arg 931 | [%expr 932 | Protobuf.Encoder.varint [%e ekey] encoder; 933 | [%e mk_writer field]])) :: 934 | mk_variant_cases rest 935 | | (name, args, attrs) :: rest -> 936 | let key = match pb_key_of_attrs attrs with Some key -> key | None -> assert false in 937 | let ekey = Exp.constant (int64_constant_of_int key) in 938 | let field = List.find (fun { pbf_name } -> pbf_name = "constr_" ^ name) fields in 939 | let argns = List.mapi (fun i _ -> "a" ^ (string_of_int i)) args in 940 | let loc = !default_loc in 941 | (Exp.case (mk_patt name (List.map pvar argns)) 942 | [%expr 943 | Protobuf.Encoder.varint [%e ekey] encoder; 944 | let [%p pvar ("constr_" ^ name)] = [%e tuple (List.map evar argns)] in 945 | [%e mk_writer field]]) :: 946 | mk_variant_cases rest 947 | | [] -> [] 948 | in 949 | let loc = !default_loc in 950 | [%expr 951 | Protobuf.Encoder.key (1, Protobuf.Varint) encoder; 952 | [%e Exp.match_ (evar "value") (mk_variant_cases constrs)]] 953 | in 954 | let mk_deconstructor fields = 955 | match ptype with 956 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some { ptyp_desc = Ptyp_tuple ptyps } } -> 957 | let loc = !default_loc in 958 | [%expr 959 | let [%p Pat.tuple (List.mapi (fun i _ -> 960 | pvar (Printf.sprintf "elem_%d" i)) ptyps)] = value in 961 | [%e List.fold_right (fun (i, ptyp) k -> 962 | deconstruct_ptyp (Printf.sprintf "elem_%d" i) ptyp k) 963 | (List.mapi (fun i ptyp -> i, ptyp) ptyps) 964 | (mk_writers fields)]] 965 | | { ptype_kind = Ptype_abstract; 966 | ptype_manifest = Some { ptyp_desc = Ptyp_variant (rows, _, _) } } -> 967 | mk_variant (fun name args -> 968 | Pat.variant name ( 969 | match args with 970 | | [] -> None 971 | | [x] -> Some x 972 | | _ -> Some (ptuple args))) 973 | (List.map (fun row_field -> 974 | match row_field with 975 | | Rtag_patt(name, attrs, _, args) -> 976 | (name, args, attrs) 977 | | _ -> assert false) rows) 978 | 979 | | { ptype_kind = Ptype_abstract; ptype_manifest = Some ptyp } -> 980 | let loc = !default_loc in 981 | [%expr let alias = value in 982 | [%e deconstruct_ptyp "alias" ptyp (mk_writers fields)]] 983 | | { ptype_kind = (Ptype_abstract | Ptype_open) } -> 984 | assert false 985 | | { ptype_kind = Ptype_record ldecls; } -> 986 | let loc = !default_loc in 987 | [%expr 988 | let [%p Pat.record (List.map (fun { pld_name } -> 989 | let label = lid pld_name.txt in 990 | let patt = pvar (Printf.sprintf "field_%s" pld_name.txt) in 991 | label, patt) ldecls) Closed] = value in 992 | [%e List.fold_right (fun { pld_name; pld_type } k -> 993 | deconstruct_ptyp (Printf.sprintf "field_%s" pld_name.txt) pld_type k) ldecls 994 | (mk_writers fields)]] 995 | | { ptype_kind = Ptype_variant constrs; ptype_name } -> 996 | constrs 997 | |> List.map (fun { pcd_name = { txt = name }; pcd_args; pcd_attributes } -> 998 | (name, pcd_args, pcd_attributes) 999 | ) 1000 | |> List.map (fun (name, pcd_args, pcd_attributes) -> 1001 | match pcd_args with 1002 | | Pcstr_tuple pcd_args -> (name, pcd_args, pcd_attributes) 1003 | | Pcstr_record pcd_label_args -> 1004 | let pcd_args = List.map (fun {pld_type; _ } -> pld_type) pcd_label_args in 1005 | (name, pcd_args, pcd_attributes) 1006 | ) 1007 | |> mk_variant pconstr 1008 | 1009 | in 1010 | let write = mk_deconstructor fields |> mk_imm_writers fields in 1011 | let loc = !default_loc in 1012 | Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "to_protobuf") ptype)) 1013 | (Ppx_deriving.poly_fun_of_type_decl ptype 1014 | [%expr fun value encoder -> [%e Ppx_deriving.sanitize write]]) 1015 | 1016 | let str_of_type ~options ~path ({ ptype_name = { txt = name }; ptype_loc } as ptype) = 1017 | let path = path @ [name] in 1018 | let fields = fields_of_ptype path ptype in 1019 | (* Order is important, writer does less checks than reader. *) 1020 | let reader = 1021 | derive_reader path fields ptype :: 1022 | (match derive_reader_bare path fields ptype with | Some x -> [x] | None -> []) 1023 | in 1024 | let writer = 1025 | derive_writer fields ptype :: 1026 | (match derive_writer_bare fields ptype with | Some x -> [x] | None -> []) 1027 | in 1028 | reader @ writer 1029 | 1030 | let has_bare ptype = 1031 | match ptype with 1032 | | { ptype_kind = Ptype_variant constrs } when 1033 | List.for_all empty_constructor_argument constrs -> true 1034 | | { ptype_kind = Ptype_abstract; 1035 | ptype_manifest = Some { ptyp_desc = Ptyp_variant (rows, _, _) } } when 1036 | List.for_all (fun row_field -> 1037 | match row_field with 1038 | Rtag_patt(_, _, _, []) -> true | _ -> false) rows -> true 1039 | | _ -> false 1040 | 1041 | let sig_of_type ~options ~path ({ ptype_name = { txt = name } } as ptype) = 1042 | let typ = Ppx_deriving.core_type_of_type_decl ptype in 1043 | let loc = !default_loc in 1044 | let reader_typ = Ppx_deriving.poly_arrow_of_type_decl 1045 | (fun var -> [%type: Protobuf.Decoder.t -> [%t var]]) ptype 1046 | [%type: Protobuf.Decoder.t -> [%t typ]] 1047 | and writer_typ = Ppx_deriving.poly_arrow_of_type_decl 1048 | (fun var -> [%type: [%t var] -> Protobuf.Encoder.t -> unit]) ptype 1049 | [%type: [%t typ] -> Protobuf.Encoder.t -> unit] 1050 | in 1051 | (if not (has_bare ptype) then [] else 1052 | [Sig.value (Val.mk (mknoloc 1053 | (Ppx_deriving.mangle_type_decl (`Suffix "from_protobuf_bare") ptype)) reader_typ); 1054 | Sig.value (Val.mk (mknoloc 1055 | (Ppx_deriving.mangle_type_decl (`Suffix "to_protobuf_bare") ptype)) writer_typ)]) @ 1056 | [Sig.value (Val.mk (mknoloc 1057 | (Ppx_deriving.mangle_type_decl (`Suffix "from_protobuf") ptype)) reader_typ); 1058 | Sig.value (Val.mk (mknoloc 1059 | (Ppx_deriving.mangle_type_decl (`Suffix "to_protobuf") ptype)) writer_typ)] 1060 | 1061 | module LongidentSet = Set.Make(struct 1062 | type t = Longident.t 1063 | let compare = compare 1064 | end) 1065 | 1066 | let rec write_protoc ~fmt ~path:base_path ?(import=[]) 1067 | ({ ptype_name = { txt = name; loc } } as ptype) = 1068 | let path = base_path @ [name] in 1069 | let fields = fields_of_ptype path ptype in 1070 | Format.fprintf fmt "@,// %s:%d" loc.loc_start.Lexing.pos_fname loc.loc_end.Lexing.pos_lnum; 1071 | (* import all external definitions *) 1072 | if (List.length import) = 0 then 1073 | let depends = ref LongidentSet.empty in 1074 | fields |> List.iter (fun field -> 1075 | match field.pbf_type with 1076 | | Pbt_nested ([], Ldot (lid, _)) -> 1077 | begin try 1078 | ignore (LongidentSet.find lid !depends) 1079 | with Not_found -> 1080 | depends := LongidentSet.add lid !depends; 1081 | Format.fprintf fmt "@,import \"%s.protoc\";" (string_of_lident lid) 1082 | end 1083 | | _ -> ()) 1084 | else 1085 | import |> List.iter (Format.fprintf fmt "@,import \"%s\";"); 1086 | (* emit a bare variant form *) 1087 | Format.fprintf fmt "@,@[message %s {" name; 1088 | fields |> List.iter (fun field -> 1089 | let subname = "_" ^ field.pbf_extname in 1090 | match field.pbf_type with 1091 | | Pbt_variant variants -> 1092 | Format.fprintf fmt "@,@[enum %s {" subname; 1093 | variants |> List.iter (fun (key, name) -> 1094 | Format.fprintf fmt "@,%s_tag = %d;" name key); 1095 | Format.fprintf fmt "@]@,}@,"; 1096 | | Pbt_imm ptyp -> 1097 | (* Manufacture a structure just for this immediate *) 1098 | let ptype = Type.mk ~manifest:ptyp (mkloc subname !default_loc) in 1099 | write_protoc ~fmt ~path:(path @ [field.pbf_name]) ptype 1100 | | _ -> ()); 1101 | let write_field ?(omit_recurrence=false) ({ pbf_extname } as field) = 1102 | let is_packed, pbf_enc = 1103 | match field.pbf_enc with 1104 | | Pbe_packed pbf_enc -> true, pbf_enc 1105 | | pbf_enc -> false, pbf_enc 1106 | in 1107 | let protoc_recurrence = 1108 | match field.pbf_kind with 1109 | | Pbk_required -> "required" 1110 | | Pbk_optional -> "optional" 1111 | | Pbk_repeated -> "repeated" 1112 | and protoc_type = 1113 | match field.pbf_type, pbf_enc with 1114 | | Pbt_bool, Pbe_varint -> "bool" 1115 | | Pbt_int, Pbe_varint -> "int64" (* conservative choice of size *) 1116 | | Pbt_int, Pbe_zigzag -> "sint64" (* ditto *) 1117 | | Pbt_int32, Pbe_varint -> "int32" 1118 | | Pbt_int32, Pbe_zigzag -> "sint32" 1119 | | Pbt_int64, Pbe_varint -> "int64" 1120 | | Pbt_int64, Pbe_zigzag -> "sint64" 1121 | | Pbt_uint32, Pbe_varint -> "uint32" 1122 | | Pbt_uint32, Pbe_zigzag -> "sint32" 1123 | | Pbt_uint64, Pbe_varint -> "uint64" 1124 | | Pbt_uint64, Pbe_zigzag -> "sint64" 1125 | | (Pbt_int | Pbt_int32 | Pbt_int64 | Pbt_uint32 | Pbt_uint64), 1126 | Pbe_bits32 -> "sfixed32" 1127 | | (Pbt_int | Pbt_int32 | Pbt_int64 | Pbt_uint32 | Pbt_uint64), 1128 | Pbe_bits64 -> "sfixed64" 1129 | | Pbt_float, Pbe_bits32 -> "float" 1130 | | Pbt_float, Pbe_bits64 -> "double" 1131 | | Pbt_string, Pbe_bytes -> "string" 1132 | | Pbt_bytes, Pbe_bytes -> "bytes" 1133 | | Pbt_imm _, Pbe_varint -> "_" ^ pbf_extname ^ "._tag" 1134 | | Pbt_imm _, Pbe_bytes -> "_" ^ pbf_extname 1135 | | Pbt_variant _, Pbe_varint -> "_" ^ pbf_extname 1136 | | Pbt_nested ([], lid), Pbe_varint -> 1137 | (string_of_lident lid) ^ "._tag" 1138 | | Pbt_nested ([], lid), Pbe_bytes -> 1139 | string_of_lident lid 1140 | | Pbt_nested(_, _), _ 1141 | | Pbt_poly(_), _ -> 1142 | raise (Error (Pberr_dumb_protoc field.pbf_loc)) 1143 | | _ -> assert false 1144 | in 1145 | Format.fprintf fmt "@,"; 1146 | if omit_recurrence then assert (field.pbf_kind == Pbk_required) 1147 | else Format.fprintf fmt "%s " protoc_recurrence; 1148 | Format.fprintf fmt "%s %s = %d" protoc_type pbf_extname field.pbf_key; 1149 | if is_packed then 1150 | Format.fprintf fmt " [packed=true]"; 1151 | let escape ~pass_8bit s = 1152 | let buf = Buffer.create (String.length s) in 1153 | s |> String.iter (fun c -> 1154 | match c with 1155 | | '\x00'..'\x19' -> 1156 | Buffer.add_string buf (Printf.sprintf "\\x%02x" (Char.code c)) 1157 | | '\x80'..'\xff' when not pass_8bit -> 1158 | Buffer.add_string buf (Printf.sprintf "\\x%02x" (Char.code c)) 1159 | | '"' -> Buffer.add_string buf "\\\"" 1160 | | c -> Buffer.add_char buf c); 1161 | Buffer.contents buf 1162 | in 1163 | begin match field.pbf_default with 1164 | | Some [%expr true] -> Format.fprintf fmt " [default=true]" 1165 | | Some [%expr false] -> Format.fprintf fmt " [default=false]" 1166 | | Some { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> 1167 | let i = int_of_string sn in 1168 | Format.fprintf fmt " [default=%d]" i 1169 | | Some { pexp_desc = Pexp_construct ({ txt = Lident n }, _) } 1170 | | Some { pexp_desc = Pexp_variant (n, _) } -> 1171 | Format.fprintf fmt " [default=%s_tag]" n 1172 | | None -> () 1173 | | Some expr -> 1174 | let expr, pass_8bit = 1175 | match expr with 1176 | | [%expr Bytes.of_string [%e? sub_expr ]] -> sub_expr, false 1177 | | _ -> expr, true in 1178 | match Ppx_deriving.string_of_expression_opt expr with 1179 | | Some s -> 1180 | Format.fprintf fmt " [default=\"%s\"]" (escape ~pass_8bit s) 1181 | | None -> 1182 | raise (Error (Pberr_ocaml_expr expr.pexp_loc)) 1183 | end; 1184 | Format.fprintf fmt ";" 1185 | in 1186 | begin match fields with 1187 | | [{ pbf_type = Pbt_variant _ } as field] -> 1188 | write_field field 1189 | | ({ pbf_type = Pbt_variant _ } as field) :: fields -> 1190 | write_field field; 1191 | Format.fprintf fmt "@,@[oneof value {"; 1192 | List.iter (write_field ~omit_recurrence:true) fields; 1193 | Format.fprintf fmt "@]@,}" 1194 | | _ -> List.iter write_field fields 1195 | end; 1196 | Format.fprintf fmt "@]@,}@," 1197 | 1198 | let protoc_files: (string, Format.formatter) Hashtbl.t = Hashtbl.create 16 1199 | 1200 | let parse_options ~options ~path type_decls = 1201 | let protoc = ref None 1202 | and protoc_import = ref [] 1203 | in 1204 | options |> List.iter (fun (name, expr) -> 1205 | match name with 1206 | | "protoc" -> 1207 | let protoc_filename = 1208 | match expr with 1209 | | [%expr protoc] -> (String.concat "." path) ^ ".protoc" 1210 | | _ -> Ppx_deriving.Arg.(get_expr ~deriver string) expr 1211 | in 1212 | let source_path = expr.pexp_loc.loc_start.Lexing.pos_fname in 1213 | let protoc_path = 1214 | Filename.concat (Filename.dirname source_path) protoc_filename in 1215 | protoc := Some protoc_path 1216 | | "protoc_import" -> 1217 | protoc_import := !protoc_import @ Ppx_deriving.Arg.(get_expr ~deriver (list string)) expr 1218 | | _ -> Location.raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); 1219 | match !protoc with 1220 | | Some protoc_path -> 1221 | let fmt = 1222 | try 1223 | Hashtbl.find protoc_files protoc_path 1224 | with Not_found -> 1225 | let protoc_file = open_out protoc_path in 1226 | let protoc_formatter = Format.formatter_of_out_channel protoc_file in 1227 | Format.fprintf protoc_formatter 1228 | "@[// protoc file autogenerated from OCaml type definitions@,"; 1229 | Format.fprintf protoc_formatter "package %s;@," (String.concat "." path); 1230 | at_exit (fun () -> Format.fprintf protoc_formatter "@]@?"); 1231 | Hashtbl.add protoc_files protoc_path protoc_formatter; 1232 | protoc_formatter 1233 | in 1234 | List.iter (write_protoc ~fmt ~path ~import:!protoc_import) type_decls 1235 | | None -> () 1236 | 1237 | let () = 1238 | Ppx_deriving.(register (create "protobuf" 1239 | ~type_decl_str:(fun ~options ~path type_decls -> 1240 | parse_options ~options ~path type_decls; 1241 | [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) 1242 | ~type_decl_sig:(fun ~options ~path type_decls -> 1243 | parse_options ~options ~path type_decls; 1244 | List.concat (List.map (sig_of_type ~options ~path) type_decls)) 1245 | () 1246 | )) 1247 | --------------------------------------------------------------------------------