├── .github └── workflows │ └── main.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── msgpck-repr.opam ├── msgpck.opam ├── src ├── dune ├── msgpck.ml ├── msgpck.mli ├── msgpck_repr.ml └── msgpck_repr.mli └── test ├── dune └── test.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: [push, pull_request] 3 | jobs: 4 | run: 5 | name: Build 6 | strategy: 7 | matrix: 8 | os: 9 | - macos-latest 10 | - ubuntu-latest 11 | - windows-latest 12 | ocaml-compiler: 13 | - 4.8.x 14 | - 4.12.x 15 | runs-on: ${{ matrix.os }} 16 | steps: 17 | - uses: actions/checkout@v2 18 | - uses: ocaml/setup-ocaml@v2 19 | with: 20 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 21 | - run: opam pin -n . 22 | - run: opam depext -yt msgpck msgpck-repr 23 | - run: opam install -t . --deps-only 24 | - run: opam exec -- dune build 25 | - run: opam exec -- dune runtest 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *~ 3 | \.\#* 4 | \#*# 5 | *.install 6 | .merlin -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = compact 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v1.7 2021-06-04 Paris 2 | --------------------- 3 | 4 | * bugfix: fix buffer overflows by not using _unsafe ocplib-endian functions (@c-cube) 5 | * read_all: bugfix (pos vs n_read) (@c-cube) 6 | * test: fix for 32bit archs 7 | 8 | v1.6 2021-03-20 Paris 9 | --------------------- 10 | 11 | * bugfix: bug when serializing big Int values 12 | * bugfix: 32 bits architectures now also try to pack parsed ints into int type 13 | * ocamlformat 14 | 15 | v1.5 2020-01-10 Paris 16 | --------------------- 17 | 18 | * use Buffer's binary encodings of integers (>= 4.08.0) 19 | * bugfix: 32 bits architecture now working as well 20 | * bugfix: fix computation of size for the Bytes type 21 | 22 | v1.4 2018-04-27 Paris 23 | --------------------- 24 | 25 | * compile in dev mode (removed dead code and unused variables) 26 | * add optional `Msgpck_repr` module compatible with `ocplib-json-typed` 27 | * tests: switch to alcotest 28 | * add compare and equal functions 29 | * bugfix: uint64 were previously written as int64 30 | 31 | v1.3 2017-05-17 Paris 32 | --------------------- 33 | 34 | * Add read_all function. 35 | * Better error messages on unpack. 36 | * Add format based pretty-printers. 37 | * BUILD: switch to jbuilder. 38 | 39 | v1.2 2017-03-06 Paris 40 | --------------------- 41 | 42 | * BUGFIX: fix reading signed integers. 43 | 44 | v1.1 2017-02-21 Paris 45 | --------------------- 46 | 47 | * Add documentation. 48 | * Drop dependency to ppx (and sexplib). 49 | * Function `to_string' now uses `size' and allocate a string of the 50 | exact required length. 51 | * Add function `size'. 52 | 53 | v1.0 2016-08-31 Paris 54 | --------------------- 55 | 56 | First release. 57 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Vincent Bernardoff 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install @runtest 3 | 4 | clean: 5 | dune clean 6 | 7 | test: 8 | dune runtest --force --no-buffer 9 | 10 | watch: 11 | dune build @install -w 12 | 13 | .PHONY: test 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | msgpck — msgpack library for OCaml 2 | ---------------------------------- 3 | %%VERSION%% 4 | 5 | [![Build](https://github.com/vbmithr/ocaml-msgpck/workflows/Build/badge.svg)](https://github.com/vbmithr/ocaml-msgpck/actions) 6 | 7 | msgpck is a pure OCaml implementation of 8 | [msgpack](https://msgpack.org/) serialization and deserialization. 9 | 10 | msgpck is distributed under the ISC license. 11 | 12 | Homepage: https://github.com/vbmithr/ocaml-msgpck 13 | Contact: Vincent Bernardoff `` 14 | 15 | Documentation: https://vbmithr.github.io/ocaml-msgpck/doc/ 16 | 17 | ## Installation 18 | 19 | msgpck can be installed with `opam`: 20 | 21 | ``` 22 | opam install msgpck 23 | ``` 24 | 25 | If you don't use `opam` consult the [`opam`](msgpck.opam) file for build 26 | instructions. 27 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | (name msgpck) 3 | -------------------------------------------------------------------------------- /msgpck-repr.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Vincent Bernardoff " 3 | authors: "Vincent Bernardoff " 4 | homepage: "https://github.com/vbmithr/ocaml-msgpck" 5 | license: "ISC" 6 | dev-repo: "git+https://github.com/vbmithr/ocaml-msgpck.git" 7 | bug-reports: "https://github.com/vbmithr/ocaml-msgpck/issues" 8 | tags: [] 9 | depends: [ 10 | "dune" {>= "1.11.4"} 11 | "msgpck" {= version} 12 | "ocplib-json-typed" {>= "0.7.1"} 13 | "ocaml" {>= "4.08.0"} 14 | ] 15 | build:[ "dune" "build" "-p" name "-j" jobs ] 16 | synopsis: "Fast MessagePack (http://msgpack.org) library -- ocplib-json-typed interface" 17 | description: """ 18 | Interface between msgpck and ocplib-json-typed. 19 | """ 20 | -------------------------------------------------------------------------------- /msgpck.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Vincent Bernardoff " 3 | authors: "Vincent Bernardoff " 4 | homepage: "https://github.com/vbmithr/ocaml-msgpck" 5 | license: "ISC" 6 | dev-repo: "git+https://github.com/vbmithr/ocaml-msgpck.git" 7 | bug-reports: "https://github.com/vbmithr/ocaml-msgpck/issues" 8 | doc: "https://vbmithr.github.io/ocaml-msgpck/doc" 9 | tags: ["messagepack" "msgpack" "binary" "serialization"] 10 | depends: [ 11 | "dune" {>= "1.11.4"} 12 | "ocplib-endian" {>= "1.0"} 13 | "ocaml" {>= "4.08.0"} 14 | "alcotest" {with-test & >= "0.8.5"} 15 | "qcheck-core" {with-test} 16 | "qcheck-alcotest" {with-test} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | [ "dune" "build" "-p" name "-j" jobs ] 21 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 22 | [ "dune" "build" "@doc" "-p" name "-j" jobs ] {with-doc} 23 | ] 24 | 25 | synopsis: "Fast MessagePack (http://msgpack.org) library" 26 | description: """ 27 | msgpck is written in pure OCaml. 28 | 29 | MessagePack is an efficient binary serialization format. It lets you 30 | exchange data among multiple languages like JSON. But it's faster and 31 | smaller. Small integers are encoded into a single byte, and typical 32 | short strings require only one extra byte in addition to the strings 33 | themselves.""" 34 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name msgpck) 3 | (public_name msgpck) 4 | (modules msgpck) 5 | (libraries ocplib-endian)) 6 | 7 | (library 8 | (name msgpck_repr) 9 | (public_name msgpck-repr) 10 | (optional) 11 | (modules msgpck_repr) 12 | (libraries msgpck ocplib-json-typed)) 13 | -------------------------------------------------------------------------------- /src/msgpck.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Vincent Bernardoff. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | module type STRING = sig 8 | type buf_in 9 | type buf_out 10 | 11 | val get_uint8 : buf_in -> int -> int 12 | val get_int8 : buf_in -> int -> int 13 | val get_uint16 : buf_in -> int -> int 14 | val get_int16 : buf_in -> int -> int 15 | val get_int32 : buf_in -> int -> int32 16 | val get_int64 : buf_in -> int -> int64 17 | val get_float : buf_in -> int -> float 18 | val get_double : buf_in -> int -> float 19 | val set_int8 : buf_out -> int -> int -> unit 20 | val set_int16 : buf_out -> int -> int -> unit 21 | val set_int32 : buf_out -> int -> int32 -> unit 22 | val set_int64 : buf_out -> int -> int64 -> unit 23 | val set_double : buf_out -> int -> float -> unit 24 | val length : buf_in -> int 25 | val blit : string -> int -> buf_out -> int -> int -> unit 26 | val sub : buf_in -> int -> int -> string 27 | val create_out : int -> buf_out 28 | end 29 | 30 | module SIBO = struct 31 | type buf_in = string 32 | type buf_out = Bytes.t 33 | 34 | include EndianString.BigEndian 35 | 36 | let length = String.length 37 | let blit = Bytes.blit_string 38 | let sub = String.sub 39 | let create_out = Bytes.create 40 | end 41 | 42 | module BIBO = struct 43 | type buf_in = Bytes.t 44 | type buf_out = Bytes.t 45 | 46 | include EndianBytes.BigEndian 47 | 48 | let length = Bytes.length 49 | let blit = Bytes.blit_string 50 | let sub = Bytes.sub_string 51 | let create_out = Bytes.create 52 | end 53 | 54 | module SIBUFO = struct 55 | type buf_in = string 56 | type buf_out = Buffer.t 57 | 58 | include EndianString.BigEndian 59 | 60 | let set_int8 buf _i i = Buffer.add_int8 buf i 61 | let set_int16 buf _i i = Buffer.add_int16_be buf i 62 | let set_int32 buf _i i = Buffer.add_int32_be buf i 63 | let set_int64 buf _i i = Buffer.add_int64_be buf i 64 | let set_double buf _i f = Buffer.add_int64_be buf (Int64.bits_of_float f) 65 | let length = String.length 66 | let blit i i_pos o _o_pos len = Buffer.add_substring o i i_pos len 67 | let sub = String.sub 68 | let create_out = Buffer.create 69 | end 70 | 71 | module BIBUFO = struct 72 | type buf_in = Bytes.t 73 | type buf_out = Buffer.t 74 | 75 | include EndianBytes.BigEndian 76 | 77 | let set_int8 buf _i i = Buffer.add_int8 buf i 78 | let set_int16 buf _i i = Buffer.add_int16_be buf i 79 | let set_int32 buf _i i = Buffer.add_int32_be buf i 80 | let set_int64 buf _i i = Buffer.add_int64_be buf i 81 | let set_double buf _i f = Buffer.add_int64_be buf (Int64.bits_of_float f) 82 | let length = Bytes.length 83 | let blit i i_pos o _o_pos len = Buffer.add_substring o i i_pos len 84 | let sub = Bytes.sub_string 85 | let create_out = Buffer.create 86 | end 87 | 88 | type t = 89 | | Nil 90 | | Bool of bool 91 | | Int of int 92 | | Uint32 of int32 93 | | Int32 of int32 94 | | Uint64 of int64 95 | | Int64 of int64 96 | | Float32 of int32 97 | | Float of float 98 | | String of string 99 | | Bytes of string 100 | | Ext of int * string 101 | | List of t list 102 | | Map of (t * t) list 103 | 104 | let compare = Stdlib.compare 105 | let equal = Stdlib.( = ) 106 | 107 | let rec size = function 108 | | Nil -> 1 109 | | Bool _ -> 1 110 | | Int i -> size_int i 111 | | Int32 _ | Uint32 _ | Float32 _ -> 5 112 | | Int64 _ | Uint64 _ | Float _ -> 9 113 | | String s -> size_string s 114 | | Bytes s -> size_bytes s 115 | | Ext (_typ, s) -> size_ext s 116 | | List l -> 117 | let nb_written = 118 | match List.length l with 119 | | len when len <= 0xf -> 1 120 | | len when len <= 0xffff -> 3 121 | | _ -> 5 in 122 | List.fold_left (fun nbw e -> nbw + size e) nb_written l 123 | | Map l -> 124 | let nb_written = 125 | match List.length l with 126 | | len when len <= 0xf -> 1 127 | | len when len <= 0xffff -> 3 128 | | _ -> 5 in 129 | List.fold_left 130 | (fun nbw (k, v) -> 131 | let nbw = nbw + size k in 132 | nbw + size v ) 133 | nb_written l 134 | 135 | and size_int i = 136 | match Int64.of_int i with 137 | | i when i >= 0L && i <= 0x7fL -> 1 138 | | i when i >= 0L && i <= 0xffL -> 2 139 | | i when i >= 0L && i <= 0xffffL -> 3 140 | | i when i >= 0L && i <= 0xffff_ffffL -> 5 141 | | i when i >= 0L -> 9 142 | | i when i >= Int64.(sub (neg 0x1fL) 1L) -> 1 143 | | i when i >= Int64.(sub (neg 0x7fL) 1L) -> 2 144 | | i when i >= Int64.(sub (neg 0x7fffL) 1L) -> 3 145 | | i when i >= Int64.(sub (neg 0x7fff_ffffL) 1L) -> 5 146 | | _ -> 9 147 | 148 | and size_string str = 149 | match String.length str with 150 | | n when n <= 0x1f -> n + 1 151 | | n when n <= 0xff -> n + 2 152 | | n when n <= 0xffff -> n + 3 153 | | n -> n + 5 154 | 155 | and size_bytes str = 156 | match String.length str with 157 | | n when n <= 0xff -> n + 2 158 | | n when n <= 0xffff -> n + 3 159 | | n -> n + 5 160 | 161 | and size_ext str = 162 | match String.length str with 163 | | 1 -> 1 + 2 164 | | 2 -> 2 + 2 165 | | 4 -> 4 + 2 166 | | 8 -> 8 + 2 167 | | 16 -> 16 + 2 168 | | n when n <= 0xff -> n + 3 169 | | n when n <= 0xffff -> n + 4 170 | | n -> n + 6 171 | 172 | let rec pp ppf t = 173 | let open Format in 174 | match t with 175 | | Nil -> pp_print_string ppf "()" 176 | | Bool b -> pp_print_bool ppf b 177 | | Int i -> pp_print_int ppf i 178 | | Uint32 i -> fprintf ppf "%ldul" i 179 | | Int32 i -> fprintf ppf "%ldl" i 180 | | Uint64 i -> fprintf ppf "%LdUL" i 181 | | Int64 i -> fprintf ppf "%LdL" i 182 | | Float32 f -> pp_print_float ppf (Int32.to_float f) 183 | | Float f -> pp_print_float ppf f 184 | | String s -> pp_print_string ppf s 185 | | Bytes s -> fprintf ppf "%S" s 186 | | Ext (i, b) -> fprintf ppf "(%d %S)" i b 187 | | List ts -> 188 | let pp_sep ppf () = fprintf ppf ",@ " in 189 | fprintf ppf "[@[%a@]]" (pp_print_list ~pp_sep pp) ts 190 | | Map ts -> 191 | let pp_sep ppf () = fprintf ppf ",@ " in 192 | let pp_tuple ppf (k, v) = fprintf ppf "%a:@ %a" pp k pp v in 193 | fprintf ppf "{@[%a@]}" (pp_print_list ~pp_sep pp_tuple) ts 194 | 195 | let show t = Format.asprintf "%a" pp t 196 | let of_nil = Nil 197 | let of_bool b = Bool b 198 | let of_int i = Int i 199 | let of_uint32 i = Uint32 i 200 | let of_int32 i = Int32 i 201 | let of_uint64 i = Uint64 i 202 | let of_int64 i = Int64 i 203 | let of_float32 i = Float32 i 204 | let of_float f = Float f 205 | let of_string s = String s 206 | let of_bytes s = Bytes s 207 | let of_ext t s = Ext (t, s) 208 | let of_list l = List l 209 | let of_map l = Map l 210 | 211 | let raise_invalid_arg typ v = 212 | invalid_arg (Format.asprintf "to_%s: got %a" typ pp v) 213 | 214 | let to_nil = function Nil -> () | v -> raise_invalid_arg "nil" v 215 | let to_bool = function Bool b -> b | v -> raise_invalid_arg "bool" v 216 | let to_int = function Int i -> i | v -> raise_invalid_arg "int" v 217 | let to_uint32 = function Uint32 i -> i | v -> raise_invalid_arg "uint32" v 218 | let to_int32 = function Int32 i -> i | v -> raise_invalid_arg "int32" v 219 | let to_uint64 = function Uint64 i -> i | v -> raise_invalid_arg "uint64" v 220 | let to_int64 = function Int64 i -> i | v -> raise_invalid_arg "int64" v 221 | let to_float32 = function Float32 f -> f | v -> raise_invalid_arg "float32" v 222 | let to_float = function Float f -> f | v -> raise_invalid_arg "float" v 223 | let to_string = function String s -> s | v -> raise_invalid_arg "string" v 224 | let to_bytes = function Bytes b -> b | v -> raise_invalid_arg "bytes" v 225 | let to_ext = function Ext (t, s) -> (t, s) | v -> raise_invalid_arg "ext" v 226 | let to_list = function List l -> l | v -> raise_invalid_arg "list" v 227 | let to_map = function Map l -> l | v -> raise_invalid_arg "map" v 228 | 229 | module type S = sig 230 | type buf_in 231 | type buf_out 232 | val read : ?pos:int -> buf_in -> int * t 233 | val read_all : ?allow_partial:bool -> ?pos:int -> buf_in -> int * t list 234 | val write : ?pos:int -> buf_out -> t -> int 235 | val write_all : ?pos:int -> buf_out -> t list -> int 236 | val to_string : t -> buf_out 237 | val to_string_all : t list -> buf_out 238 | end 239 | 240 | module Make (S : STRING) 241 | : S with type buf_in = S.buf_in and type buf_out = S.buf_out 242 | = struct 243 | include S 244 | 245 | let write_nil ?(pos = 0) buf = set_int8 buf pos 0xc0 ; 1 246 | 247 | let write_bool ?(pos = 0) buf b = 248 | set_int8 buf pos (if b then 0xc3 else 0xc2) ; 249 | 1 250 | 251 | let write_float ?(pos = 0) buf i = 252 | set_int8 buf pos 0xca ; 253 | set_int32 buf (pos + 1) i ; 254 | 5 255 | 256 | let write_double ?(pos = 0) buf f = 257 | set_int8 buf pos 0xcb ; 258 | set_double buf (pos + 1) f ; 259 | 9 260 | 261 | let write_int ?(pos = 0) buf v = 262 | match Int64.of_int v with 263 | | i when i >= 0L && i <= 0x7fL -> set_int8 buf pos v ; 1 264 | | i when i >= 0L && i <= 0xffL -> 265 | set_int16 buf pos ((0xcc lsl 8) + v) ; 266 | 2 267 | | i when i >= 0L && i <= 0xffffL -> 268 | set_int8 buf pos 0xcd ; 269 | set_int16 buf (pos + 1) v ; 270 | 3 271 | | i when i >= 0L && i <= 0xffff_ffffL -> 272 | set_int8 buf pos 0xce ; 273 | set_int32 buf (pos + 1) @@ Int32.of_int v ; 274 | 5 275 | | i when i >= 0L -> 276 | set_int8 buf pos 0xcf ; 277 | set_int64 buf (pos + 1) i ; 278 | 9 279 | | i when i >= Int64.(sub (neg 0x1fL) 1L) -> set_int8 buf pos v ; 1 280 | | i when i >= Int64.(sub (neg 0x7fL) 1L) -> 281 | set_int8 buf pos @@ 0xd0 ; 282 | set_int8 buf (pos + 1) v ; 283 | 2 284 | | i when i >= Int64.(sub (neg 0x7fffL) 1L) -> 285 | set_int8 buf pos 0xd1 ; 286 | set_int16 buf (pos + 1) v ; 287 | 3 288 | | i when i >= Int64.(sub (neg 0x7fff_ffffL) 1L) -> 289 | set_int8 buf pos 0xd2 ; 290 | set_int32 buf (pos + 1) @@ Int32.of_int v ; 291 | 5 292 | | i -> 293 | set_int8 buf pos 0xd3 ; 294 | set_int64 buf (pos + 1) i ; 295 | 9 296 | 297 | let write_uint32 ?(pos = 0) buf i = 298 | set_int8 buf pos 0xce ; 299 | set_int32 buf (pos + 1) i ; 300 | 5 301 | 302 | let write_uint64 ?(pos = 0) buf i = 303 | set_int8 buf pos 0xcf ; 304 | set_int64 buf (pos + 1) i ; 305 | 9 306 | 307 | let write_int32 ?(pos = 0) buf i = 308 | set_int8 buf pos 0xd2 ; 309 | set_int32 buf (pos + 1) i ; 310 | 5 311 | 312 | let write_int64 ?(pos = 0) buf i = 313 | set_int8 buf pos 0xd3 ; 314 | set_int64 buf (pos + 1) i ; 315 | 9 316 | 317 | let write_string ~src ?(src_pos = 0) ~dst ?(dst_pos = 0) ?src_len () = 318 | let len = 319 | match src_len with Some l -> l | None -> String.length src - src_pos in 320 | match len with 321 | | n when n <= 0x1f -> 322 | set_int8 dst dst_pos @@ (0xa0 lor n) ; 323 | blit src src_pos dst (dst_pos + 1) len ; 324 | len + 1 325 | | n when n <= 0xff -> 326 | set_int16 dst dst_pos @@ ((0xd9 lsl 8) + n) ; 327 | blit src src_pos dst (dst_pos + 2) len ; 328 | len + 2 329 | | n when n <= 0xffff -> 330 | set_int8 dst dst_pos 0xda ; 331 | set_int16 dst (dst_pos + 1) len ; 332 | blit src src_pos dst (dst_pos + 3) len ; 333 | len + 3 334 | | _ -> 335 | set_int8 dst dst_pos 0xdb ; 336 | set_int32 dst (dst_pos + 1) (Int32.of_int len) ; 337 | blit src src_pos dst (dst_pos + 5) len ; 338 | len + 5 339 | 340 | let write_bin ~src ?(src_pos = 0) ~dst ?(dst_pos = 0) ?src_len () = 341 | let len = 342 | match src_len with Some l -> l | None -> String.length src - src_pos in 343 | match len with 344 | | n when n <= 0xff -> 345 | set_int16 dst dst_pos @@ ((0xc4 lsl 8) + n) ; 346 | blit src src_pos dst (dst_pos + 2) len ; 347 | len + 2 348 | | n when n <= 0xffff -> 349 | set_int8 dst dst_pos 0xc5 ; 350 | set_int16 dst (dst_pos + 1) len ; 351 | blit src src_pos dst (dst_pos + 3) len ; 352 | len + 3 353 | | _ -> 354 | set_int8 dst dst_pos 0xc6 ; 355 | set_int32 dst (dst_pos + 1) (Int32.of_int len) ; 356 | blit src src_pos dst (dst_pos + 5) len ; 357 | len + 5 358 | 359 | let write_ext ~src ?(src_pos = 0) ~dst ?(dst_pos = 0) ?src_len typ = 360 | let len = 361 | match src_len with Some l -> l | None -> String.length src - src_pos in 362 | match len with 363 | | 1 -> 364 | set_int16 dst dst_pos @@ ((0xd4 lsl 8) + typ) ; 365 | blit src src_pos dst (dst_pos + 2) len ; 366 | len + 2 367 | | 2 -> 368 | set_int16 dst dst_pos @@ ((0xd5 lsl 8) + typ) ; 369 | blit src src_pos dst (dst_pos + 2) len ; 370 | len + 2 371 | | 4 -> 372 | set_int16 dst dst_pos @@ ((0xd6 lsl 8) + typ) ; 373 | blit src src_pos dst (dst_pos + 2) len ; 374 | len + 2 375 | | 8 -> 376 | set_int16 dst dst_pos @@ ((0xd7 lsl 8) + typ) ; 377 | blit src src_pos dst (dst_pos + 2) len ; 378 | len + 2 379 | | 16 -> 380 | set_int16 dst dst_pos @@ ((0xd8 lsl 8) + typ) ; 381 | blit src src_pos dst (dst_pos + 2) len ; 382 | len + 2 383 | | n when n <= 0xff -> 384 | set_int8 dst dst_pos 0xc7 ; 385 | set_int16 dst (dst_pos + 1) ((n lsl 8) + typ) ; 386 | blit src src_pos dst (dst_pos + 3) len ; 387 | len + 3 388 | | n when n <= 0xffff -> 389 | set_int32 dst dst_pos ((0xc8 lsl 24) + (len lsl 8) + typ |> Int32.of_int) ; 390 | blit src src_pos dst (dst_pos + 4) len ; 391 | len + 4 392 | | _ -> 393 | set_int8 dst dst_pos 0xc9 ; 394 | set_int32 dst (dst_pos + 1) (Int32.of_int len) ; 395 | set_int8 dst (dst_pos + 5) typ ; 396 | blit src src_pos dst (dst_pos + 6) len ; 397 | len + 6 398 | 399 | let rec write ?(pos = 0) buf = function 400 | | Nil -> write_nil ~pos buf 401 | | Bool b -> write_bool ~pos buf b 402 | | Int i -> write_int ~pos buf i 403 | | Int32 i -> write_int32 ~pos buf i 404 | | Uint32 i -> write_uint32 ~pos buf i 405 | | Int64 i -> write_int64 ~pos buf i 406 | | Uint64 i -> write_uint64 ~pos buf i 407 | | Float32 i -> write_float ~pos buf i 408 | | Float f -> write_double ~pos buf f 409 | | String s -> write_string ~src:s ~dst_pos:pos ~dst:buf () 410 | | Bytes s -> write_bin ~src:s ~dst_pos:pos ~dst:buf () 411 | | Ext (t, d) -> write_ext ~src:d ~dst_pos:pos ~dst:buf t 412 | | List l -> 413 | let nb_written = 414 | match List.length l with 415 | | len when len <= 0xf -> 416 | set_int8 buf pos @@ (0x90 lor len) ; 417 | 1 418 | | len when len <= 0xffff -> 419 | set_int8 buf pos 0xdc ; 420 | set_int16 buf (pos + 1) len ; 421 | 3 422 | | len -> 423 | set_int8 buf pos 0xdd ; 424 | set_int32 buf (pos + 1) (Int32.of_int len) ; 425 | 5 in 426 | List.fold_left 427 | (fun nbw e -> nbw + write ~pos:(pos + nbw) buf e) 428 | nb_written l 429 | | Map l -> 430 | let nb_written = 431 | match List.length l with 432 | | len when len <= 0xf -> 433 | set_int8 buf pos @@ (0x80 lor len) ; 434 | 1 435 | | len when len <= 0xffff -> 436 | set_int8 buf pos 0xde ; 437 | set_int16 buf (pos + 1) len ; 438 | 3 439 | | len -> 440 | set_int8 buf pos 0xdf ; 441 | set_int32 buf (pos + 1) (Int32.of_int len) ; 442 | 5 in 443 | List.fold_left 444 | (fun nbw (k, v) -> 445 | let nbw = nbw + write ~pos:(pos + nbw) buf k in 446 | nbw + write ~pos:(pos + nbw) buf v ) 447 | nb_written l 448 | 449 | let write_all ?(pos=0) buf l = 450 | let nb_write = ref 0 in 451 | List.iter 452 | (fun m -> nb_write := !nb_write + write ~pos:(pos + !nb_write) buf m) 453 | l; 454 | !nb_write 455 | 456 | let to_string msg = 457 | let buf = create_out @@ size msg in 458 | let _nb_written : int = write buf msg in 459 | buf 460 | 461 | let to_string_all l = 462 | let size = List.fold_left (fun s x -> s + size x) 0 l in 463 | let buf = create_out size in 464 | let _nb_written : int = write_all buf l in 465 | buf 466 | 467 | let max_int31 = Int32.(shift_left one 30 |> pred) 468 | let min_int31 = Int32.(neg max_int31 |> pred) 469 | let max_int31_64 = Int64.(shift_left one 30 |> pred) 470 | let min_int31_64 = Int64.(neg max_int31_64 |> pred) 471 | let max_int63 = Int64.(shift_left one 62 |> pred) 472 | let min_int63 = Int64.(neg max_int63 |> pred) 473 | 474 | let parse_int32 i = 475 | match Sys.word_size with 476 | | 32 -> 477 | if i >= min_int31 && i <= max_int31 then Int (Int32.to_int i) 478 | else Int32 i 479 | | 64 -> Int (Int32.to_int i) 480 | | _ -> invalid_arg "Sys.word_size" 481 | 482 | let parse_uint32 i = 483 | match Sys.word_size with 484 | | 32 -> if i >= 0l && i <= max_int31 then Int (Int32.to_int i) else Uint32 i 485 | | 64 -> Int (if i >= 0l then Int32.to_int i else (1 lsl 32) + Int32.to_int i) 486 | | _ -> invalid_arg "Sys.word_size" 487 | 488 | let parse_int64 i = 489 | match Sys.word_size with 490 | | 32 -> 491 | if i >= min_int31_64 && i <= max_int31_64 then Int (Int64.to_int i) 492 | else Int64 i 493 | | 64 -> 494 | if i >= min_int63 && i <= max_int63 then Int (Int64.to_int i) 495 | else Int64 i 496 | | _ -> invalid_arg "Sys.word_size" 497 | 498 | let parse_uint64 i = 499 | match Sys.word_size with 500 | | 32 -> 501 | if i >= 0L && i <= max_int31_64 then Int (Int64.to_int i) else Uint64 i 502 | | 64 -> if i >= 0L && i <= max_int63 then Int (Int64.to_int i) else Uint64 i 503 | | _ -> invalid_arg "Sys.word_size" 504 | 505 | let pairs l = 506 | List.fold_left 507 | (fun acc e -> 508 | match acc with 509 | | None, acc -> (Some e, acc) 510 | | Some v, acc -> (None, (e, v) :: acc) ) 511 | (None, []) l 512 | |> snd 513 | 514 | let get_uint32 buf pos = 515 | match get_int32 buf pos with 516 | | i when i >= 0l -> Int64.of_int32 i 517 | | i -> Int64.(add (add 0xffff_ffffL 1L) (of_int32 i)) 518 | 519 | let rec read_n ?(pos = 0) buf n = 520 | let rec inner nbr elts n = 521 | if n > 0L then 522 | let nbr', elt = read ~pos:(pos + nbr) buf in 523 | inner (nbr + nbr') (elt :: elts) (Int64.pred n) 524 | else (nbr, elts) in 525 | inner 0 [] n 526 | 527 | and read ?(pos = 0) buf = 528 | match get_uint8 buf pos with 529 | | i when i lsr 4 = 0x8 -> 530 | let n = i land 0x0f in 531 | read_n ~pos:(pos + 1) buf (Int64.of_int (2 * n)) 532 | |> fun (nb_read, elts) -> (1 + nb_read, Map (pairs elts)) 533 | | i when i lsr 4 = 0x9 -> 534 | let n = i land 0x0f in 535 | read_n ~pos:(pos + 1) buf (Int64.of_int n) 536 | |> fun (nb_read, elts) -> (1 + nb_read, List (List.rev elts)) 537 | | 0xdc -> 538 | let n = get_uint16 buf (pos + 1) in 539 | read_n ~pos:(pos + 3) buf (Int64.of_int n) 540 | |> fun (nb_read, elts) -> (3 + nb_read, List (List.rev elts)) 541 | | 0xdd -> 542 | let n = get_uint32 buf (pos + 1) in 543 | read_n ~pos:(pos + 5) buf n 544 | |> fun (nb_read, elts) -> (5 + nb_read, List (List.rev elts)) 545 | | 0xde -> 546 | let n = get_uint16 buf (pos + 1) in 547 | read_n ~pos:(pos + 3) buf (Int64.of_int (2 * n)) 548 | |> fun (nb_read, elts) -> (3 + nb_read, Map (pairs elts)) 549 | | 0xdf -> 550 | let n = get_uint32 buf (pos + 1) in 551 | read_n ~pos:(pos + 5) buf (Int64.mul 2L n) 552 | |> fun (nb_read, elts) -> (5 + nb_read, Map (pairs elts)) 553 | (* Atomic types (i.e. non-collection) *) 554 | | i when i < 0x80 -> (1, Int (i land 0x7f)) 555 | | i when i lsr 5 = 5 -> 556 | let len = i land 0x1f in 557 | (succ len, String (sub buf (pos + 1) len)) 558 | | 0xc0 -> (1, Nil) 559 | | 0xc2 -> (1, Bool false) 560 | | 0xc3 -> (1, Bool true) 561 | | 0xc4 -> 562 | let len = get_uint8 buf (pos + 1) in 563 | (len + 2, Bytes (sub buf (pos + 2) len)) 564 | | 0xc5 -> 565 | let len = get_uint16 buf (pos + 1) in 566 | (len + 3, Bytes (sub buf (pos + 3) len)) 567 | | 0xc6 -> 568 | let len = get_int32 buf (pos + 1) |> Int32.to_int in 569 | (len + 5, Bytes (sub buf (pos + 5) len)) 570 | | 0xc7 -> 571 | let hdr = get_uint16 buf (pos + 1) in 572 | let len = hdr lsr 8 in 573 | let typ = hdr land 0xff in 574 | (len + 3, Ext (typ, sub buf (pos + 3) len)) 575 | | 0xc8 -> 576 | let len = get_uint16 buf (pos + 1) in 577 | let typ = get_int8 buf (pos + 3) in 578 | (len + 4, Ext (typ, sub buf (pos + 4) len)) 579 | | 0xc9 -> 580 | let len = get_int32 buf (pos + 1) |> Int32.to_int in 581 | let typ = get_int8 buf (pos + 5) in 582 | (len + 6, Ext (typ, sub buf (pos + 6) len)) 583 | | 0xca -> (5, Float (get_float buf @@ (pos + 1))) 584 | | 0xcb -> (9, Float (get_double buf @@ (pos + 1))) 585 | | 0xcc -> (2, Int (get_uint8 buf @@ (pos + 1))) 586 | | 0xcd -> (3, Int (get_uint16 buf @@ (pos + 1))) 587 | | 0xce -> (5, parse_uint32 (get_int32 buf @@ (pos + 1))) 588 | | 0xcf -> (9, parse_uint64 (get_int64 buf @@ (pos + 1))) 589 | | 0xd0 -> (2, Int (get_int8 buf @@ (pos + 1))) 590 | | 0xd1 -> (3, Int (get_int16 buf @@ (pos + 1))) 591 | | 0xd2 -> (5, parse_int32 (get_int32 buf @@ (pos + 1))) 592 | | 0xd3 -> (9, parse_int64 (get_int64 buf @@ (pos + 1))) 593 | | 0xd4 -> 594 | ( 3 595 | , let typ = get_int8 buf (pos + 1) in 596 | Ext (typ, sub buf (pos + 2) 1) ) 597 | | 0xd5 -> 598 | ( 4 599 | , let typ = get_int8 buf (pos + 1) in 600 | Ext (typ, sub buf (pos + 2) 2) ) 601 | | 0xd6 -> 602 | ( 6 603 | , let typ = get_int8 buf (pos + 1) in 604 | Ext (typ, sub buf (pos + 2) 4) ) 605 | | 0xd7 -> 606 | ( 10 607 | , let typ = get_int8 buf (pos + 1) in 608 | Ext (typ, sub buf (pos + 2) 8) ) 609 | | 0xd8 -> 610 | ( 18 611 | , let typ = get_int8 buf (pos + 1) in 612 | Ext (typ, sub buf (pos + 2) 16) ) 613 | | 0xd9 -> 614 | let len = get_uint8 buf (pos + 1) in 615 | (len + 2, String (sub buf (pos + 2) len)) 616 | | 0xda -> 617 | let len = get_uint16 buf (pos + 1) in 618 | (len + 3, String (sub buf (pos + 3) len)) 619 | | 0xdb -> 620 | let len = get_int32 buf (pos + 1) |> Int32.to_int in 621 | (len + 5, String (sub buf (pos + 5) len)) 622 | | i when i >= 0xe0 -> (1, Int (get_int8 buf pos)) 623 | | i -> invalid_arg (Printf.sprintf "read: unsupported tag 0x%x" i) 624 | 625 | let read_all ?(allow_partial=true) ?(pos = 0) buf = 626 | let len = length buf in 627 | let rec inner acc pos = 628 | if pos >= len then (pos, List.rev acc) 629 | else ( 630 | match read ~pos buf with 631 | | n_read, msg -> 632 | let new_pos = pos + n_read in 633 | inner (msg :: acc) new_pos 634 | | exception e -> 635 | if allow_partial 636 | then (pos, List.rev acc) 637 | else raise e 638 | ) 639 | in 640 | inner [] pos 641 | end 642 | 643 | module String = Make (SIBO) 644 | module Bytes = Make (BIBO) 645 | module StringBuf = Make (SIBUFO) 646 | module BytesBuf = Make (BIBUFO) 647 | 648 | (*--------------------------------------------------------------------------- 649 | Copyright (c) 2016 Vincent Bernardoff 650 | 651 | Permission to use, copy, modify, and/or distribute this software for any 652 | purpose with or without fee is hereby granted, provided that the above 653 | copyright notice and this permission notice appear in all copies. 654 | 655 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 656 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 657 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 658 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 659 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 660 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 661 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 662 | ---------------------------------------------------------------------------*) 663 | -------------------------------------------------------------------------------- /src/msgpck.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Vincent Bernardoff. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** msgpack library for OCaml 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 10 | 11 | (** {1 Msgpck} *) 12 | 13 | type t = 14 | | Nil 15 | | Bool of bool 16 | | Int of int 17 | | Uint32 of int32 18 | | Int32 of int32 19 | | Uint64 of int64 20 | | Int64 of int64 21 | | Float32 of int32 22 | | Float of float 23 | | String of string 24 | | Bytes of string 25 | | Ext of int * string 26 | | List of t list 27 | | Map of (t * t) list (** MessagePack types. *) 28 | 29 | val compare : t -> t -> int 30 | val equal : t -> t -> bool 31 | 32 | val size : t -> int 33 | (** [size msg] is the size in bytes of the MessagePack serialization 34 | of message [msg]. *) 35 | 36 | val pp : Format.formatter -> t -> unit 37 | val show : t -> string 38 | 39 | (** {1 Conversion functions OCaml -> MessagePack } *) 40 | 41 | val of_nil : t 42 | val of_bool : bool -> t 43 | val of_int : int -> t 44 | val of_uint32 : int32 -> t 45 | val of_int32 : int32 -> t 46 | val of_uint64 : int64 -> t 47 | val of_int64 : int64 -> t 48 | val of_float32 : int32 -> t 49 | val of_float : float -> t 50 | val of_string : string -> t 51 | val of_bytes : string -> t 52 | val of_ext : int -> string -> t 53 | val of_list : t list -> t 54 | val of_map : (t * t) list -> t 55 | 56 | (** {1 Conversion functions MessagePack -> OCaml } *) 57 | 58 | val to_nil : t -> unit 59 | val to_bool : t -> bool 60 | val to_int : t -> int 61 | val to_uint32 : t -> int32 62 | val to_int32 : t -> int32 63 | val to_uint64 : t -> int64 64 | val to_int64 : t -> int64 65 | val to_float32 : t -> int32 66 | val to_float : t -> float 67 | val to_string : t -> string 68 | val to_bytes : t -> string 69 | val to_ext : t -> int * string 70 | val to_list : t -> t list 71 | val to_map : t -> (t * t) list 72 | 73 | (** {1 Output signature for functors defined below } *) 74 | 75 | module type S = sig 76 | (** Type of input buffer (where MessagePack data will be read) *) 77 | type buf_in 78 | 79 | (** Type of output buffer (where MessagePack data will be written) *) 80 | type buf_out 81 | 82 | val read : ?pos:int -> buf_in -> int * t 83 | (** [read ?pos buf] is [(nb_read, t)], where [nb_read] is the number 84 | of bytes read from [buf] at pos [?pos], and [t] is the decoded 85 | MessagePack value. 86 | 87 | [@raise] Invalid_argument "msg" when there is no valid 88 | MessagePack value to be read from [buf] at position [pos]. *) 89 | 90 | val read_all : ?allow_partial:bool -> ?pos:int -> buf_in -> int * t list 91 | (** [read_all ?pos buf] reads all messages found in [buf]. 92 | @return a tuple [(pos, l)] where [pos] is the new position 93 | in the buffer, and [l] is the list of read messages. 94 | 95 | @param allow_partial if true (default), 96 | then [read_all buf] will not fail if it 97 | meets a partial value in [buf]. It will only return the full values 98 | read prior to the partial value. The caller can then extend the buffer, 99 | for example after performing some more IO, and call [read_all] again. 100 | (since 1.8) 101 | 102 | [@raise] Invalid_argument "msg" when there is no valid 103 | MessagePack value to be read from [buf] at position [pos]. *) 104 | 105 | val write : ?pos:int -> buf_out -> t -> int 106 | (** [write ?pos buf msg] is [nb_written], the number of bytes 107 | written on [buf] at position [?pos]. The serialization of [msg] 108 | have been written to [buf] starting at [?pos]. *) 109 | 110 | val write_all : ?pos:int -> buf_out -> t list -> int 111 | (** [write_all buf l] writes all messages of [l] into the buffer, and returns 112 | how many bytes were written. 113 | @since 1.8 *) 114 | 115 | val to_string : t -> buf_out 116 | (** [to_string msg] is the MessagePack serialization of [msg]. *) 117 | 118 | val to_string_all : t list -> buf_out 119 | (** [to_string l] is the MessagePack serialization of the list of objects [l], 120 | as a set of consecutive serialized values. *) 121 | end 122 | 123 | (** MessagePack library decoding from strings and writing in 124 | Buffers. *) 125 | module StringBuf : S with type buf_in = string and type buf_out = Buffer.t 126 | 127 | (** MessagePack library decoding from bytes and writing in Buffers. *) 128 | module BytesBuf : S with type buf_in = Bytes.t and type buf_out = Buffer.t 129 | 130 | (** MessagePack library decoding from strings and writing in bytes. *) 131 | module String : S with type buf_in = string and type buf_out = Bytes.t 132 | 133 | (** MessagePack library decoding from bytes and writing in bytes. *) 134 | module Bytes : S with type buf_in = Bytes.t and type buf_out = Bytes.t 135 | 136 | (*--------------------------------------------------------------------------- 137 | Copyright (c) 2016 Vincent Bernardoff 138 | 139 | Permission to use, copy, modify, and/or distribute this software for any 140 | purpose with or without fee is hereby granted, provided that the above 141 | copyright notice and this permission notice appear in all copies. 142 | 143 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 144 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 145 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 146 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 147 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 148 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 149 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 150 | ---------------------------------------------------------------------------*) 151 | -------------------------------------------------------------------------------- /src/msgpck_repr.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Vincent Bernardoff. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | module Repr = struct 8 | type value = Msgpck.t 9 | 10 | let view : value -> value Json_repr.view = function 11 | | Msgpck.Nil -> `Null 12 | | Bool b -> `Bool b 13 | | Float f -> `Float f 14 | | String s -> `String s 15 | | Bytes b -> `String b 16 | | Int i -> `Float (float i) 17 | | Uint32 i -> `Float Int32.(to_float (if i < 0l then add i max_int else i)) 18 | | Int32 i -> `Float (Int32.to_float i) 19 | | Uint64 i -> `Float Int64.(to_float (if i < 0L then add i max_int else i)) 20 | | Int64 i -> `Float (Int64.to_float i) 21 | | Float32 i -> `Float (Int32.float_of_bits i) 22 | | Ext (i, b) -> `A [Int i; String b] 23 | | List l -> `A l 24 | | Map m -> `A (List.map (fun (k, v) -> Msgpck.List [k; v]) m) 25 | 26 | let repr : value Json_repr.view -> value = function 27 | | `A l -> List l 28 | | `Bool b -> Bool b 29 | | `Float f -> Float f 30 | | `Null -> Nil 31 | | `O kvs -> Map (List.map (fun (k, v) -> (Msgpck.String k, v)) kvs) 32 | | `String s -> String s 33 | 34 | let repr_uid = Json_repr.repr_uid () 35 | end 36 | 37 | include Json_encoding.Make (Repr) 38 | 39 | (*--------------------------------------------------------------------------- 40 | Copyright (c) 2016 Vincent Bernardoff 41 | 42 | Permission to use, copy, modify, and/or distribute this software for any 43 | purpose with or without fee is hereby granted, provided that the above 44 | copyright notice and this permission notice appear in all copies. 45 | 46 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 47 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 48 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 49 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 50 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 51 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 52 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 53 | ---------------------------------------------------------------------------*) 54 | -------------------------------------------------------------------------------- /src/msgpck_repr.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Vincent Bernardoff. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Json_encoding 8 | module Repr : Json_repr.Repr with type value := Msgpck.t 9 | 10 | val construct : 't encoding -> 't -> Msgpck.t 11 | val destruct : 't encoding -> Msgpck.t -> 't 12 | 13 | val custom : 14 | ('t -> Msgpck.t) 15 | -> (Msgpck.t -> 't) 16 | -> schema:Json_schema.schema 17 | -> 't encoding 18 | 19 | (*--------------------------------------------------------------------------- 20 | Copyright (c) 2016 Vincent Bernardoff 21 | 22 | Permission to use, copy, modify, and/or distribute this software for any 23 | purpose with or without fee is hereby granted, provided that the above 24 | copyright notice and this permission notice appear in all copies. 25 | 26 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 27 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 28 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 29 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 30 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 31 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 32 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 33 | ---------------------------------------------------------------------------*) 34 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (modules test) 4 | (libraries msgpck alcotest qcheck-core qcheck-alcotest)) 5 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Vincent Bernardoff. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Alcotest 8 | module M = Msgpck 9 | module Q = QCheck 10 | 11 | let buf = Bytes.create (5 + (2 * 0x10000)) 12 | let msgpck = testable M.pp M.equal 13 | 14 | let roundtrip ?msg expected x = 15 | let buf = Buffer.create 13 in 16 | let _nbWritten = M.StringBuf.write buf x in 17 | let _posOut, x' = M.String.read (Buffer.contents buf) in 18 | let msg = "roundtrip" ^ match msg with None -> "" | Some msg -> ": " ^ msg in 19 | check msgpck msg expected x' 20 | 21 | let max_int31 = Int.(shift_left one 30 |> pred) 22 | let min_int31 = Int.(neg max_int31 |> pred) 23 | let max_int31_32 = Int32.(shift_left one 30 |> pred) 24 | let min_int31_32 = Int32.(neg max_int31_32 |> pred) 25 | let max_int31_64 = Int64.(shift_left one 30 |> pred) 26 | let min_int31_64 = Int64.(neg max_int31_64 |> pred) 27 | let max_int63 = Int.(shift_left one 62 |> pred) 28 | let min_int63 = Int.(neg max_int63 |> pred) 29 | let max_int63_64 = Int64.(shift_left one 62 |> pred) 30 | let min_int63_64 = Int64.(neg max_int63_64 |> pred) 31 | 32 | let reg_int_1 () = 33 | let m = M.(Int 4294967296) in 34 | let s = M.String.to_string m in 35 | let _, m2 = M.Bytes.read s in 36 | check msgpck "read int back" m m2 37 | 38 | let rt64 () = 39 | List.iter 40 | (fun (e, x) -> roundtrip e x) 41 | [ (Int 1, Int32 1l); (Int max_int31, Int max_int31) 42 | ; (Int max_int63, Int max_int63); (Int max_int63, Int64 max_int63_64) 43 | ; (Int min_int63, Int64 min_int63_64); (Uint64 (-1L), Uint64 (-1L)) ] 44 | 45 | let rt32 () = 46 | List.iter 47 | (fun (e, x) -> roundtrip e x) 48 | [ (Int 1, Int32 1l); (Int max_int31, Int max_int31) 49 | ; (Int max_int31, Int max_int31) ] 50 | 51 | let wr ?(section = "") ?expected size v = 52 | let expected = match expected with Some v -> v | None -> v in 53 | let nb_written = M.Bytes.write buf v in 54 | let computed_size = M.size v in 55 | check int (section ^ ": nb_written") size nb_written ; 56 | check int (section ^ ": size") nb_written computed_size ; 57 | let nb_read, msg = M.Bytes.read buf in 58 | check int (section ^ ": nb_read") size nb_read ; 59 | check msgpck (section ^ ": msgpck equality") expected msg 60 | 61 | let checkb ?(msg = "") testable ~expected buf = 62 | let _nb_read, msgpck = M.Bytes.read buf in 63 | check testable msg expected msgpck 64 | 65 | let negative_ints () = 66 | let open Bytes in 67 | checkb msgpck ~expected:(Int (-1)) (of_string "\xff") ; 68 | checkb msgpck ~expected:(Int (-33)) (of_string "\xd0\xdf") ; 69 | checkb msgpck ~expected:(Int (-32767)) (of_string "\xd1\x80\x01") ; 70 | checkb msgpck ~expected:(Int (-32768)) (of_string "\xd2\xff\xff\x80\x00") 71 | 72 | let negative_ints_64 () = 73 | checkb msgpck 74 | ~expected:(Int (Int32.to_int (-2147483647l))) 75 | (Bytes.of_string "\xd2\x80\x00\x00\x01") ; 76 | checkb msgpck 77 | ~expected:(Int (Int32.to_int (-2147483648l))) 78 | (Bytes.of_string "\xd3\xff\xff\xff\xff\x80\x00\x00\x00") 79 | 80 | let negative_ints_32 () = 81 | checkb msgpck ~expected:(Int32 (-2147483647l)) 82 | (Bytes.of_string "\xd2\x80\x00\x00\x01") ; 83 | checkb msgpck ~expected:(Int64 (-2147483648L)) 84 | (Bytes.of_string "\xd3\xff\xff\xff\xff\x80\x00\x00\x00") 85 | 86 | let size1 () = 87 | let l = 88 | M. 89 | [ Nil; Bool true; Bool false; Int 127; Int (-32); Int (-31); Int (-30) 90 | ; Int (-2); Int (-1) ] in 91 | ListLabels.iter l ~f:(wr 1) 92 | 93 | let size2 () = 94 | let l = M.[Int (-0x7f - 1); Int 0xff] in 95 | ListLabels.iter l ~f:(wr 2) 96 | 97 | let size3 () = 98 | let l = M.[Int (-0x7fff - 1); Int 0xffff] in 99 | ListLabels.iter l ~f:(wr 3) 100 | 101 | let size5 () = 102 | let l32 = M.[(None, Int32 Int32.max_int); (None, Int 0x3fff_ffff)] in 103 | let l64 = 104 | M. 105 | [ (Some (Int Int32.(to_int max_int)), Int32 Int32.max_int) 106 | ; (Some (Int ~-1), Int32 0xffff_ffffl) ] in 107 | ListLabels.iter 108 | (if Sys.word_size = 32 then l32 else l64) 109 | ~f:(fun (expected, v) -> wr ?expected 5 v) 110 | 111 | let size9 () = 112 | let l = M.[(None, Int64 Int64.max_int); (None, Float 0.)] in 113 | ListLabels.iter l ~f:(fun (expected, v) -> wr ?expected 9 v) 114 | 115 | let str () = 116 | wr ~section:"empty string" 1 @@ M.String "" ; 117 | wr 5 (M.String "Bleh") ; 118 | wr (0x20 + 2) (M.String (Bytes.create 0x20 |> Bytes.unsafe_to_string)) ; 119 | wr (0x100 + 3) (M.String (Bytes.create 0x100 |> Bytes.unsafe_to_string)) ; 120 | wr (0x10000 + 5) (M.String (Bytes.create 0x10000 |> Bytes.unsafe_to_string)) 121 | 122 | let bytes () = 123 | wr (0x20 + 2) (M.Bytes (Bytes.create 0x20 |> Bytes.unsafe_to_string)) ; 124 | wr (0x100 + 3) (M.Bytes (Bytes.create 0x100 |> Bytes.unsafe_to_string)) ; 125 | wr (0x10000 + 5) (M.Bytes (Bytes.create 0x10000 |> Bytes.unsafe_to_string)) 126 | 127 | let bytes2 () = 128 | let msg = "my_payload is so really long tt" in 129 | let msgpck = M.of_bytes msg in 130 | let size = M.size msgpck in 131 | check int "bytes2: size" (String.length msg + 2) size ; 132 | let buf = Bytes.create size in 133 | let nb_written = M.Bytes.write buf msgpck in 134 | check int "bytes2: size written" size nb_written 135 | 136 | let ext () = 137 | wr 3 (M.Ext (4, "1")) ; 138 | wr 4 (M.Ext (4, "22")) ; 139 | wr 6 (M.Ext (4, "4444")) ; 140 | wr 10 (M.Ext (4, Bytes.create 8 |> Bytes.unsafe_to_string)) ; 141 | wr 18 (M.Ext (4, Bytes.create 16 |> Bytes.unsafe_to_string)) ; 142 | wr (0xff + 3) (M.Ext (4, Bytes.create 0xff |> Bytes.unsafe_to_string)) ; 143 | wr (0xffff + 4) (M.Ext (4, Bytes.create 0xffff |> Bytes.unsafe_to_string)) 144 | 145 | let gen_list f n = 146 | let rec inner acc n = if n > 0 then inner (f n :: acc) (pred n) else acc in 147 | inner [] n 148 | 149 | let array () = 150 | wr ~section:"empty list" 1 @@ M.List [] ; 151 | wr ~section:"one elt" 2 M.(List [Nil]) ; 152 | wr ~section:"small array" (15 + 1) M.(List (gen_list (fun i -> Int i) 15)) ; 153 | wr ~section:"medium array" (0xffff + 3) 154 | M.(List (gen_list (fun _ -> Int 0) 0xffff)) ; 155 | wr ~section:"large array" (0x10000 + 5) 156 | M.(List (gen_list (fun _ -> Int 0) 0x10000)) ; 157 | wr ~section:"concatenated lists" 2 M.(List [List []]) ; 158 | wr ~section:"string list" 2 M.(List [String ""]) ; 159 | wr ~section:"hello wamp" 33 160 | M.( 161 | List 162 | [Int 23; String "http://google.com"; Map [(String "subscriber", Map [])]]) 163 | 164 | let map () = 165 | wr ~section:"small map" 166 | ((2 * 15) + 1) 167 | M.(Map (gen_list (fun i -> (Int i, Int i)) 15)) ; 168 | wr ~section:"medium map" 169 | ((2 * 0xffff) + 3) 170 | M.(Map (gen_list (fun _ -> (Int 0, Int 0)) 0xffff)) ; 171 | wr ~section:"large map" 172 | ((2 * 0x10000) + 5) 173 | M.(Map (gen_list (fun _ -> (Int 0, Int 0)) 0x10000)) ; 174 | wr ~section:"concatenated maps" 3 M.(Map [(Nil, Map [])]) ; 175 | wr ~section:"string -> string" 3 M.(Map [(String "", String "")]) 176 | 177 | let overflow () = 178 | let msg = M.(List [Int 1; Int 2; Bool true]) in 179 | let s = M.Bytes.to_string msg in 180 | let b2 = Bytes.sub s 0 2 in 181 | let nbRead, v = M.Bytes.read s in 182 | check int "nbRead" 4 nbRead ; 183 | check msgpck "v" msg v ; 184 | check_raises "overflow" (Invalid_argument "index out of bounds") (fun () -> 185 | let _, _ = M.Bytes.read b2 in 186 | () ) 187 | 188 | let read_all () = 189 | let m0 = M.(List [Int 1; Int 2; Bool true]) in 190 | let b = M.Bytes.to_string m0 in 191 | check int "len" 4 (Bytes.length b) ; 192 | (let nr1, m1 = M.Bytes.read b in 193 | check int "nr" 4 nr1 ; check msgpck "m1" m0 m1 ) ; 194 | let b_long = Bytes.create 5 in 195 | Bytes.blit b 0 b_long 0 4 ; 196 | (let nr2, m2 = M.Bytes.read b_long in 197 | check int "nr2" 4 nr2 ; 198 | check msgpck "m2" m0 m2 ; 199 | let nr3, m3 = M.Bytes.read b_long ~pos:nr2 in 200 | check int "nr3" 1 nr3 ; 201 | check msgpck "m3" m3 (M.Int 0) ; 202 | let _, l = M.Bytes.read_all b_long in 203 | check (list msgpck) "read-all" l [m0; M.Int 0] ) ; 204 | () 205 | 206 | let basic = 207 | [ ("negative_ints", `Quick, negative_ints) 208 | ; ( "big_negative_ints" 209 | , `Quick 210 | , match Sys.word_size with 32 -> negative_ints_32 | _ -> negative_ints_64 ) 211 | ; ("size1", `Quick, size1); ("size2", `Quick, size2); ("size3", `Quick, size3) 212 | ; ("size5", `Quick, size5); ("size9", `Quick, size9); ("str", `Quick, str) 213 | ; ("bytes", `Quick, bytes); ("bytes2", `Quick, bytes2); ("ext", `Quick, ext) 214 | ; ("array", `Quick, array); ("map", `Quick, map) 215 | ; ("rt", `Quick, match Sys.word_size with 32 -> rt32 | _ -> rt64) 216 | ; ("reg-int-1", `Quick, reg_int_1) 217 | ; ("read-all", `Quick, read_all); ("overflow", `Quick, overflow) ] 218 | 219 | module Props = struct 220 | let gen_msg : M.t Q.Gen.t = 221 | let open Q.Gen in 222 | fix (fun self_sized depth -> 223 | frequency @@ List.flatten [ 224 | [(2, let+ x = int in M.Int x); 225 | (1, let+ x = bool in M.Bool x); 226 | (2, let+ s = string_size (0 -- 50) in M.String s); 227 | (1, return M.of_nil); 228 | (1, let+ f = float in M.Float f); 229 | (1, let+ i = 0 -- 10 and+ s = string_size (0--10) in M.Ext (i,s)); 230 | ]; 231 | (if depth < 2 232 | then [ 233 | (2, let+ l = list_size (0 -- (if depth=0 then 10 else 2)) (self_sized (depth+1)) in M.List l); 234 | (2, let+ l = list_size (0 -- (if depth=0 then 10 else 2)) 235 | (let+ k = string_size ~gen:printable (0 -- 5) 236 | and+ v = self_sized (depth+1) in M.String k,v) 237 | in 238 | M.Map l); 239 | ] else []); 240 | ]) 0 241 | 242 | let rec shrink = 243 | let open Q.Iter in 244 | let module S = Q.Shrink in 245 | function 246 | | M.Int i -> let+ j = S.int i in M.Int j 247 | | M.Int32 i -> let+ i = S.int32 i in M.Int32 i 248 | | M.Int64 i -> let+ i = S.int64 i in M.Int64 i 249 | | M.Bool b -> if b then return (M.Bool false) else empty 250 | | M.String s -> let+ s = S.string s in M.String s 251 | | M.Bytes s -> let+ s = S.string s in M.String s 252 | | M.List l -> let+ l = S.list ~shrink l in M.List l 253 | | M.Map l -> let+ l = S.list ~shrink:(S.pair shrink shrink) l in M.Map l 254 | | M.Float _ | M.Uint32 _ | M.Uint64 _ | M.Float32 _ | M.Nil | M.Ext _ -> empty 255 | 256 | let arb_msg : M.t Q.arbitrary = 257 | Q.make ~shrink ~print:(fun m -> Format.asprintf "%a" M.pp m) gen_msg 258 | 259 | let pp_l out l = Format.fprintf out "[@[%a@]]" 260 | (Format.pp_print_list ~pp_sep:(fun out () -> Format.fprintf out ";@ ") M.pp) l 261 | 262 | let arb_msg_l : M.t list Q.arbitrary = 263 | Q.make ~shrink:(Q.Shrink.list ~shrink) 264 | ~print:(fun l -> Format.asprintf "%a" pp_l l) 265 | Q.Gen.(list_size (0 -- 10) gen_msg) 266 | end 267 | 268 | let ser_then_deser = 269 | QCheck_alcotest.to_alcotest ~verbose:true @@ 270 | Q.Test.make ~count:1000 ~name:"ser-then-deser" 271 | Props.arb_msg 272 | (fun m -> 273 | let s = M.Bytes.to_string m in 274 | let off, m2 = M.Bytes.read s in 275 | m = m2 && off = Bytes.length s) 276 | 277 | let ser_then_deser_l = 278 | QCheck_alcotest.to_alcotest ~verbose:true @@ 279 | Q.Test.make ~count:1000 ~name:"ser-then-deser-list" 280 | Props.arb_msg_l 281 | (fun l -> 282 | let buf = Buffer.create 256 in 283 | let i = ref 0 in 284 | List.iter (fun m -> i := !i + M.BytesBuf.write ~pos:!i buf m) l; 285 | let s = Buffer.contents buf in 286 | let off, l2 = M.String.read_all s in 287 | l = l2 && off = Buffer.length buf) 288 | 289 | (* test what happens when we serialize but then read only a prefix of the 290 | resulting byte array *) 291 | let ser_then_deser_sub_list = 292 | QCheck_alcotest.to_alcotest ~verbose:true @@ 293 | let rec list_take n l = 294 | match l with 295 | | _ when n <= 0 -> l 296 | | [] -> [] 297 | | x :: tl -> x :: list_take (n-1) tl 298 | in 299 | let arb' = 300 | Q.( 301 | let gen = 302 | let open Q.Gen in 303 | let* l = list_size (1--15) Props.gen_msg in 304 | let s = Bytes.unsafe_to_string @@ M.String.to_string_all l in 305 | let+ i = 0 -- String.length s in 306 | l, s, i 307 | in 308 | let shrink (l,s,i) = 309 | let open Q.Iter in 310 | (* shrink [i] *) 311 | let s1 = let+ i = Q.Shrink.int i in (l,s,i) in 312 | (* shrink [l] and then adjust s and i *) 313 | let s2 = 314 | let+ l = Q.Shrink.list ~shrink:Props.shrink l in 315 | let s = Bytes.unsafe_to_string @@ M.String.to_string_all l in 316 | let i = min i (String.length s) in 317 | l, s, i 318 | in 319 | append s1 s2 320 | in 321 | let print (l,_s,i) = Format.asprintf "i=%d, l=%a" i Props.pp_l l in 322 | make ~shrink ~print gen) 323 | in 324 | Q.Test.make ~count:1000 ~name:"ser-then-deser-sub-list" 325 | arb' 326 | (fun (l,s,i) -> 327 | let sub = String.sub s 0 i in 328 | let _off, l2 = M.String.read_all ~allow_partial:true sub in 329 | if List.length l2 > List.length l then ( 330 | Q.Test.fail_reportf "bad len:@ l=%a;@ l2=%a" Props.pp_l l Props.pp_l l2 331 | ); 332 | let l' = list_take (List.length l2) l in 333 | if l <> l' then ( 334 | Q.Test.fail_reportf "diff:@ l'=%a;@ l2=%a" Props.pp_l l' Props.pp_l l2 335 | ); 336 | true) 337 | 338 | let props = 339 | [ ser_then_deser 340 | ; ser_then_deser_l 341 | ; ser_then_deser_sub_list 342 | ] 343 | 344 | let () = Alcotest.run "msgpck" 345 | [("basic", basic); ("prop", props)] 346 | 347 | (*--------------------------------------------------------------------------- 348 | Copyright (c) 2016 Vincent Bernardoff 349 | 350 | Permission to use, copy, modify, and/or distribute this software for any 351 | purpose with or without fee is hereby granted, provided that the above 352 | copyright notice and this permission notice appear in all copies. 353 | 354 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 355 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 356 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 357 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 358 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 359 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 360 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 361 | ---------------------------------------------------------------------------*) 362 | --------------------------------------------------------------------------------