+1

ocaml-json/.ocamlformat

reviewed

··· 1 1 + version = 0.29.0

+2 -4

ocaml-json/lib/brr/json_brr.ml

reviewed

··· 74 74 75 75 let type_error t ~fnd = Json.Codec.type_error Json.Meta.none t ~fnd 76 76 77 77 - let find_all_unexpected ~mem_decs mems = 77 77 + let all_unexpected ~mem_decs mems = 78 78 let unexpected (n, _jname) = 79 79 match String_map.find_opt n mem_decs with 80 80 | None -> Some (n, Json.Meta.none) ··· 202 202 | Unknown_skip -> 203 203 decode_object_basic map umems umap mem_decs dict names jv 204 204 | Unknown_error -> 205 205 - let fnd = 206 206 - (n, Json.Meta.none) :: find_all_unexpected ~mem_decs names 207 207 - in 205 205 + let fnd = (n, Json.Meta.none) :: all_unexpected ~mem_decs names in 208 206 Json.Codec.unexpected_mems_error Json.Meta.none map ~fnd 209 207 | Unknown_keep (mmap, _) -> 210 208 let umap =

+3 -3

ocaml-json/lib/brr/json_brr.mli

reviewed

··· 62 62 'a Json.codec -> 63 63 Jstr.t -> 64 64 (Jstr.t, Json.Error.t) result 65 65 - (** [recode] is {!val-decode'} followed by {!val-encode'}. *) 65 65 + (** [recode'] is {!val-decode'} followed by {!val-encode'}. *) 66 66 67 67 val recode_jv : 'a Json.codec -> Jv.t -> (Jv.t, Jv.Error.t) result 68 68 - (** [recode] is {!val-decode} followed by {!val-encode}. *) 68 68 + (** [recode_jv] is {!val-decode_jv} followed by {!val-encode_jv}. *) 69 69 70 70 val recode_jv' : 'a Json.codec -> Jv.t -> (Jv.t, Json.Error.t) result 71 71 - (** [recode] is {!val-decode_jv'} followed by {!encode_jv'}. *) 71 71 + (** [recode_jv'] is {!val-decode_jv'} followed by {!encode_jv'}. *)

+5 -6

ocaml-json/lib/bytesrw/json_bytesrw.ml

reviewed

··· 8 8 9 9 (* XXX add these things to Stdlib.Uchar *) 10 10 11 11 - let uchar_max_utf_8_byte_length = 4 11 11 + let uchar_max_utf8_bytes = 4 12 12 13 13 - let[@inline] uchar_utf_8_byte_decode_length = function 13 13 + let[@inline] uchar_utf8_decode_length = function 14 14 | '\x00' .. '\x7F' -> 1 15 15 | '\x80' .. '\xC1' -> 0 16 16 | '\xC2' .. '\xDF' -> 2 ··· 118 118 } 119 119 120 120 let make_decoder ?(locs = false) ?(layout = false) ?(file = "-") reader = 121 121 - let overlap = Stdlib.Bytes.create uchar_max_utf_8_byte_length in 121 121 + let overlap = Stdlib.Bytes.create uchar_max_utf8_bytes in 122 122 let token = tokbuf_create 255 and ws = tokbuf_create 255 in 123 123 let meta_none = Json.Meta.make (Json.Textloc.(set_file none) file) in 124 124 { ··· 320 320 nextc d) 321 321 else 322 322 let b = Bytes.get d.i d.i_next in 323 323 - if a < uchar_max_utf_8_byte_length && a < uchar_utf_8_byte_decode_length b 324 324 - then begin 325 325 - let s = setup_overlap d 0 (uchar_utf_8_byte_decode_length b) in 323 323 + if a < uchar_max_utf8_bytes && a < uchar_utf8_decode_length b then begin 324 324 + let s = setup_overlap d 0 (uchar_utf8_decode_length b) in 326 325 nextc d; 327 326 set_slice d s 328 327 end

+3 -3

ocaml-json/lib/bytesrw/json_bytesrw.mli

reviewed

··· 31 31 - If [locs] is [true] locations are preserved in {!Json.Meta.t} values and 32 32 error messages are precisely located. Defaults to [false]. 33 33 - [file] is the file path from which [r] is assumed to read. Defaults to 34 34 - {!Json.Textloc.file_none} *) 34 34 + {!Json.Textloc.file_none}. *) 35 35 36 36 val decode' : 37 37 ?layout:bool -> ··· 72 72 eod:bool -> 73 73 Bytes.Writer.t -> 74 74 (unit, string) result 75 75 - (** [encode t v w] encodes value [v] according to [t] on [w]. 75 75 + (** [encode t v ~eod w] encodes value [v] according to [t] on [w]. 76 76 - If [buf] is specified it is used as a buffer for the slices written on 77 77 [w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w]. 78 78 - [format] specifies how the JSON should be formatted. Defaults to ··· 155 155 'a Json.codec -> 156 156 string -> 157 157 (string, string) result 158 158 - (** [recode] is {!decode_string} followed by {!recode_string}. *) 158 158 + (** [recode_string] is {!decode_string} followed by {!encode_string}. *) 159 159 160 160 val recode_string' : 161 161 ?layout:bool ->

+4 -3

ocaml-json/lib/json.ml

reviewed

··· 641 641 642 642 let default_shape = Object_basic Unknown_skip 643 643 644 644 - let _map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec = 644 644 + let raw_map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec = 645 645 { 646 646 kind; 647 647 doc; ··· 652 652 shape = default_shape; 653 653 } 654 654 655 655 - let map ?kind ?doc dec = _map ?kind ?doc (Dec_fun dec) 655 655 + let map ?kind ?doc dec = raw_map ?kind ?doc (Dec_fun dec) 656 656 657 657 let map' ?kind ?doc ?enc_meta dec = 658 658 - _map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg)) 658 658 + raw_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg)) 659 659 660 660 let enc_only ?(kind = "") ?doc ?enc_meta () = 661 661 let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in ··· 922 922 let pp_number' = Value.pp_number' 923 923 let pp_json = Value.pp_json 924 924 let pp_json' = Value.pp_json' 925 925 + let pp = pp_json 925 926 926 927 type number_format = Value.number_format 927 928

+10 -7

ocaml-json/lib/json.mli

reviewed

··· 373 373 otherwise the decoder errors. *) 374 374 375 375 val int64 : int64 codec 376 376 - (** [int] maps truncated JSON numbers or JSON strings to 64-bit integers. 376 376 + (** [int64] maps truncated JSON numbers or JSON strings to 64-bit integers. 377 377 - JSON numbers are sucessfully decoded if after truncation they can be 378 378 represented on the [int64] range, otherwise the decoder errors. [int64] 379 379 values are encoded as JSON numbers if the integer is in the 380 380 \[-2{^ 53};2{^ 53}\] range. 381 381 - JSON strings are decoded using {!int_of_string_opt}, this allows binary, 382 382 octal, decimal and hex syntaxes and errors on overflow and syntax errors. 383 383 - [int] values are encoded as JSON strings with {!Int.to_string} when the 384 384 - integer is outside the \[-2{^ 53};2{^ 53}\] range *) 383 383 + [int64] values are encoded as JSON strings with {!Int64.to_string} when 384 384 + the integer is outside the \[-2{^ 53};2{^ 53}\] range. *) 385 385 386 386 val int64_as_string : int64 codec 387 387 (** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this uses ··· 442 442 (** [enum assoc] maps JSON strings member of the [assoc] list to the 443 443 corresponding OCaml value and vice versa in log(n). [cmp] is used to compare 444 444 the OCaml values, it defaults to {!Stdlib.compare}. Decoding and encoding 445 445 - errors on strings or values not part of [assoc] *) 445 445 + errors on strings or values not part of [assoc]. *) 446 446 447 447 val binary_string : string codec 448 448 (** [binary_string] maps JSON strings made of an even number of hexdecimal ··· 1020 1020 | Array of t list node 1021 1021 | Object of object' node (** *) 1022 1022 1023 1023 + val pp : t Fmt.t 1024 1024 + (** [pp] is {!pp_json}. *) 1025 1025 + 1023 1026 (** Generic JSON values. *) 1024 1027 module Value : sig 1025 1028 (** {1:json JSON values} *) ··· 1368 1371 Uses the {!default_number_format}. *) 1369 1372 1370 1373 val pp_number' : number_format -> float Fmt.t 1371 1371 - (** [pp_number Fmt.t] is like {!pp_number} but uses [fmt] to format the number. 1374 1374 + (** [pp_number' fmt] is like {!pp_number} but uses [fmt] to format the number. 1372 1375 *) 1373 1376 1374 1377 val pp_string : string Fmt.t ··· 1379 1382 (** [pp_json] formats JSON, see {!pp_json'}. *) 1380 1383 1381 1384 val pp_json' : ?number_format:number_format -> unit -> t Fmt.t 1382 1382 - (** [pp' ~format ~number_format () ppf j] formats [j] on [ppf]. The output is 1385 1385 + (** [pp_json' ?number_format () ppf j] formats [j] on [ppf]. The output is 1383 1386 indented but may be more compact than an [Indent] JSON encoder may do. For 1384 1387 example arrays may be output on one line if they fit etc. 1385 1388 - [number_format] is used to format JSON numbers. Defaults to 1386 1386 - {!default_number_format} 1389 1389 + {!default_number_format}. 1387 1390 - Non-finite numbers are output as JSON nulls 1388 1391 ({{!page-cookbook.non_finite_numbers}explanation}). 1389 1392 - Strings are assumed to be valid UTF-8. *)

+15

ocaml-leb128/LICENSE.md

reviewed

··· 1 1 + ISC License 2 2 + 3 3 + Copyright (c) 2026 Thomas Gazagnaire <thomas@gazagnaire.org> 4 4 + 5 5 + Permission to use, copy, modify, and distribute this software for any 6 6 + purpose with or without fee is hereby granted, provided that the above 7 7 + copyright notice and this permission notice appear in all copies. 8 8 + 9 9 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 10 + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 11 + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 12 + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 13 + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 14 + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 15 + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

+63

ocaml-leb128/README.md

reviewed

··· 1 1 + # leb128 2 2 + 3 3 + LEB128 (Little-Endian Base 128) variable-length integer codec for OCaml. 4 4 + 5 5 + LEB128 encodes a non-negative integer as a sequence of 7-bit groups, low group 6 6 + first, with the high bit of each byte set as a continuation flag. Signed values 7 7 + are first zig-zag encoded so that small magnitudes (positive or negative) stay 8 8 + small. 9 9 + 10 10 + Used by: 11 11 + 12 12 + - **DWARF** debug info — unsigned and signed LEB128 throughout 13 13 + - **WebAssembly** — all integer immediates 14 14 + - **Protocol Buffers** — called "varint", with zig-zag for `sint32`/`sint64` 15 15 + - **IPLD CAR** files — block length prefixes 16 16 + - **Git pack-delta headers** — source and target sizes 17 17 + 18 18 + ## Installation 19 19 + 20 20 + ``` 21 21 + opam install leb128 22 22 + ``` 23 23 + 24 24 + ## Usage 25 25 + 26 26 + ```ocaml 27 27 + (* Bytes-based core: fast path, no allocation for the value. *) 28 28 + let buf = Bytes.create 10 29 29 + let n = Leb128.encode_u64 300L buf 0 (* n = 2, buf.[0..1] = ac 02 *) 30 30 + let v, n = Leb128.decode_u64 buf 0 (* v = 300L, n = 2 *) 31 31 + 32 32 + (* OCaml-int fast path (no int64 boxing). *) 33 33 + let n = Leb128.encode_u63 150 buf 0 34 34 + let id, n = Leb128.decode_u63 buf 0 (* id = 150 *) 35 35 + 36 36 + (* Zig-zag signed. *) 37 37 + let n = Leb128.encode_int (-1) buf 0 (* encodes as 0x01 *) 38 38 + let v, n = Leb128.decode_int buf 0 (* v = -1 *) 39 39 + 40 40 + (* String convenience — shares no bytes, no copy. *) 41 41 + let v, n = Leb128.decode_u63_string "\xac\x02" 0 42 42 + 43 43 + (* Streaming over Bytesrw. *) 44 44 + let r = Bytesrw.Bytes.Reader.of_string "\xac\x02" 45 45 + let v = Leb128.read_u63 r (* v = 300 *) 46 46 + ``` 47 47 + 48 48 + ## API shape 49 49 + 50 50 + | Variant | Type | Width | Signed | 51 51 + |-----------------------|-----------|---------------|--------| 52 52 + | `u64` | `int64` | full 64 bits | no | 53 53 + | `u63` | `int` | OCaml int | no | 54 54 + | `i64` | `int64` | zig-zag | yes | 55 55 + | `int` | `int` | zig-zag | yes | 56 56 + 57 57 + Each variant has `decode_*`, `encode_*`, and `size_*`. Most have a `_string` 58 58 + form for non-allocating reads from string, and streaming `read_*` / `write_*` 59 59 + over `Bytesrw.Bytes.Reader.t` / `.Writer.t`. 60 60 + 61 61 + Decoders raise `Invalid_argument` on over-long encodings, truncated input, 62 62 + or values outside the target type's range. Encoders never emit over-long 63 63 + forms.

+25

ocaml-leb128/dune-project

reviewed

··· 1 1 + (lang dune 3.21) 2 2 + (name leb128) 3 3 + 4 4 + (generate_opam_files true) 5 5 + 6 6 + (license ISC) 7 7 + (authors "Thomas Gazagnaire <thomas@gazagnaire.org>") 8 8 + (maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>") 9 9 + (source (tangled gazagnaire.org/ocaml-leb128)) 10 10 + 11 11 + (package 12 12 + (name leb128) 13 13 + (synopsis "LEB128 variable-length integer codec") 14 14 + (tags (org:blacksun codec.binary)) 15 15 + (description 16 16 + "LEB128 (Little-Endian Base 128) encoder and decoder with unsigned and 17 17 + zig-zag signed variants. Used by DWARF, WebAssembly, protobuf (as varint), 18 18 + IPLD CAR files, and Git pack-delta headers. Streams over bytesrw readers 19 19 + and writers; a fast bytes-based core avoids tuple allocation in hot loops.") 20 20 + (depends 21 21 + (ocaml (>= 5.1)) 22 22 + (bytesrw (>= 0.2)) 23 23 + (odoc :with-doc) 24 24 + (alcotest (and (>= 1.7) :with-test)) 25 25 + (crowbar (and (>= 0.2) :with-test))))

+30

ocaml-leb128/fuzz/dune

reviewed

··· 1 1 + ; Crowbar-shaped fuzz testing for LEB128 round-tripping. 2 2 + ; 3 3 + ; Quick check (runs tests with random inputs): 4 4 + ; dune build @fuzz 5 5 + ; 6 6 + ; With AFL instrumentation (use crow orchestrator): 7 7 + ; crow start --cpus=4 8 8 + 9 9 + (executable 10 10 + (name fuzz) 11 11 + (modules fuzz fuzz_leb128) 12 12 + (libraries leb128 bytesrw alcobar)) 13 13 + 14 14 + (rule 15 15 + (alias runtest) 16 16 + (enabled_if 17 17 + (<> %{profile} afl)) 18 18 + (deps fuzz.exe) 19 19 + (action 20 20 + (run %{exe:fuzz.exe}))) 21 21 + 22 22 + (rule 23 23 + (alias fuzz) 24 24 + (enabled_if 25 25 + (= %{profile} afl)) 26 26 + (deps fuzz.exe) 27 27 + (action 28 28 + (progn 29 29 + (run %{exe:fuzz.exe} --gen-corpus corpus) 30 30 + (run afl-fuzz -V 60 -i corpus -o _fuzz -- %{exe:fuzz.exe} @@))))

+1

ocaml-leb128/fuzz/fuzz.ml

reviewed

··· 1 1 + let () = Alcobar.run "leb128" [ Fuzz_leb128.suite ]

+96

ocaml-leb128/fuzz/fuzz_leb128.ml

reviewed

··· 1 1 + (* Fuzz tests for LEB128 round-tripping and decoder robustness. 2 2 + 3 3 + Invariants: 4 4 + - encode then decode recovers the value exactly (unsigned and signed). 5 5 + - decoding arbitrary bytes either succeeds or raises [Invalid_argument]; 6 6 + it never loops, segfaults, or raises anything else. 7 7 + - zig-zag encode/decode are mutual inverses. *) 8 8 + 9 9 + open Alcobar 10 10 + 11 11 + (* --- Generators --- *) 12 12 + 13 13 + let nonneg_int = map [ int ] (fun n -> if n < 0 then lnot n else n) 14 14 + 15 15 + (* --- Round-trip properties --- *) 16 16 + 17 17 + let test_roundtrip_u64 v = 18 18 + let out = Bytes.create 10 in 19 19 + let n = Leb128.encode_u64 v out 0 in 20 20 + let v', n' = Leb128.decode_u64 out 0 in 21 21 + check_eq ~eq:Int64.equal ~pp:pp_int64 v v'; 22 22 + check_eq ~eq:Int.equal ~pp:pp_int n n'; 23 23 + check_eq ~eq:Int.equal ~pp:pp_int (Leb128.size_u64 v) n 24 24 + 25 25 + let test_roundtrip_u63 v = 26 26 + let out = Bytes.create 10 in 27 27 + let n = Leb128.encode_u63 v out 0 in 28 28 + let v', n' = Leb128.decode_u63 out 0 in 29 29 + check_eq ~eq:Int.equal ~pp:pp_int v v'; 30 30 + check_eq ~eq:Int.equal ~pp:pp_int n n'; 31 31 + check_eq ~eq:Int.equal ~pp:pp_int (Leb128.size_u63 v) n 32 32 + 33 33 + let test_roundtrip_i64 v = 34 34 + let out = Bytes.create 10 in 35 35 + let n = Leb128.encode_i64 v out 0 in 36 36 + let v', n' = Leb128.decode_i64 out 0 in 37 37 + check_eq ~eq:Int64.equal ~pp:pp_int64 v v'; 38 38 + check_eq ~eq:Int.equal ~pp:pp_int n n' 39 39 + 40 40 + let test_roundtrip_int v = 41 41 + let out = Bytes.create 10 in 42 42 + let n = Leb128.encode_int v out 0 in 43 43 + let v', n' = Leb128.decode_int out 0 in 44 44 + check_eq ~eq:Int.equal ~pp:pp_int v v'; 45 45 + check_eq ~eq:Int.equal ~pp:pp_int n n' 46 46 + 47 47 + let test_zigzag_inverse v = 48 48 + let u = Leb128.zigzag_encode_i64 v in 49 49 + let v' = Leb128.zigzag_decode_i64 u in 50 50 + check_eq ~eq:Int64.equal ~pp:pp_int64 v v' 51 51 + 52 52 + (* --- Decoder robustness: any byte sequence is handled cleanly --- *) 53 53 + 54 54 + let test_decode_any_u64 input = 55 55 + let buf = Bytes.unsafe_of_string input in 56 56 + match Leb128.decode_u64 buf 0 with 57 57 + | _ -> () 58 58 + | exception Invalid_argument _ -> () 59 59 + 60 60 + let test_decode_any_u63 input = 61 61 + let buf = Bytes.unsafe_of_string input in 62 62 + match Leb128.decode_u63 buf 0 with 63 63 + | _ -> () 64 64 + | exception Invalid_argument _ -> () 65 65 + 66 66 + let test_decode_any_i64 input = 67 67 + let buf = Bytes.unsafe_of_string input in 68 68 + match Leb128.decode_i64 buf 0 with 69 69 + | _ -> () 70 70 + | exception Invalid_argument _ -> () 71 71 + 72 72 + (* --- Bytesrw streaming round-trip --- *) 73 73 + 74 74 + let test_bytesrw_roundtrip v = 75 75 + let buf = Buffer.create 16 in 76 76 + let w = Bytesrw.Bytes.Writer.of_buffer buf in 77 77 + Leb128.write_u64 w v; 78 78 + Bytesrw.Bytes.Writer.write_eod w; 79 79 + let r = Bytesrw.Bytes.Reader.of_string (Buffer.contents buf) in 80 80 + let v' = Leb128.read_u64 r in 81 81 + check_eq ~eq:Int64.equal ~pp:pp_int64 v v' 82 82 + 83 83 + let suite = 84 84 + ( "leb128", 85 85 + [ 86 86 + test_case "round-trip u64" [ int64 ] test_roundtrip_u64; 87 87 + test_case "round-trip u63 (non-negative int)" [ nonneg_int ] 88 88 + test_roundtrip_u63; 89 89 + test_case "round-trip i64" [ int64 ] test_roundtrip_i64; 90 90 + test_case "round-trip int" [ int ] test_roundtrip_int; 91 91 + test_case "zigzag inverse" [ int64 ] test_zigzag_inverse; 92 92 + test_case "decode any bytes (u64)" [ bytes ] test_decode_any_u64; 93 93 + test_case "decode any bytes (u63)" [ bytes ] test_decode_any_u63; 94 94 + test_case "decode any bytes (i64)" [ bytes ] test_decode_any_i64; 95 95 + test_case "bytesrw u64 round-trip" [ int64 ] test_bytesrw_roundtrip; 96 96 + ] )

+1

ocaml-leb128/fuzz/fuzz_leb128.mli

reviewed

··· 1 1 + val suite : string * Alcobar.test_case list

+41

ocaml-leb128/leb128.opam

reviewed

··· 1 1 + # This file is generated by dune, edit dune-project instead 2 2 + opam-version: "2.0" 3 3 + synopsis: "LEB128 variable-length integer codec" 4 4 + description: """ 5 5 + LEB128 (Little-Endian Base 128) encoder and decoder with unsigned and 6 6 + zig-zag signed variants. Used by DWARF, WebAssembly, protobuf (as varint), 7 7 + IPLD CAR files, and Git pack-delta headers. Streams over bytesrw readers 8 8 + and writers; a fast bytes-based core avoids tuple allocation in hot loops.""" 9 9 + maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"] 10 10 + authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"] 11 11 + license: "ISC" 12 12 + tags: ["org:blacksun" "codec.binary"] 13 13 + homepage: "https://tangled.org/gazagnaire.org/ocaml-leb128" 14 14 + bug-reports: "https://tangled.org/gazagnaire.org/ocaml-leb128/issues" 15 15 + depends: [ 16 16 + "dune" {>= "3.21"} 17 17 + "ocaml" {>= "5.1"} 18 18 + "bytesrw" {>= "0.2"} 19 19 + "odoc" {with-doc} 20 20 + "alcotest" {>= "1.7" & with-test} 21 21 + "crowbar" {>= "0.2" & with-test} 22 22 + ] 23 23 + build: [ 24 24 + ["dune" "subst"] {dev} 25 25 + [ 26 26 + "dune" 27 27 + "build" 28 28 + "-p" 29 29 + name 30 30 + "-j" 31 31 + jobs 32 32 + "@install" 33 33 + "@runtest" {with-test} 34 34 + "@doc" {with-doc} 35 35 + ] 36 36 + ] 37 37 + dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-leb128" 38 38 + x-maintenance-intent: ["(latest)"] 39 39 + x-quality-build: "2026-04-20" 40 40 + x-quality-fuzz: "2026-04-20" 41 41 + x-quality-test: "2026-04-20"

+3

ocaml-leb128/leb128.opam.template

reviewed

··· 1 1 + x-quality-build: "2026-04-20" 2 2 + x-quality-fuzz: "2026-04-20" 3 3 + x-quality-test: "2026-04-20"

+4

ocaml-leb128/lib/dune

reviewed

··· 1 1 + (library 2 2 + (name leb128) 3 3 + (public_name leb128) 4 4 + (libraries bytesrw))

+268

ocaml-leb128/lib/leb128.ml

reviewed

··· 1 1 + (* Bytes-based core. Same implementation as the embedded codecs in 2 2 + ocaml-wire 0.9.0, extracted for reuse. *) 3 3 + 4 4 + let max_bytes_u64 = 10 5 5 + (* 9 * 7 = 63 bits, 10th byte carries the top bit. *) 6 6 + 7 7 + (* -- Unsigned int64 -- *) 8 8 + 9 9 + let size_u64 v = 10 10 + if Int64.equal v 0L then 1 11 11 + else 12 12 + let rec go v n = 13 13 + if Int64.equal v 0L then n else go (Int64.shift_right_logical v 7) (n + 1) 14 14 + in 15 15 + go v 0 16 16 + 17 17 + let encode_u64 v buf off = 18 18 + let rec go v off = 19 19 + let byte = Int64.to_int (Int64.logand v 0x7fL) in 20 20 + let rest = Int64.shift_right_logical v 7 in 21 21 + if Int64.equal rest 0L then begin 22 22 + Bytes.set_uint8 buf off byte; 23 23 + off + 1 24 24 + end 25 25 + else begin 26 26 + Bytes.set_uint8 buf off (byte lor 0x80); 27 27 + go rest (off + 1) 28 28 + end 29 29 + in 30 30 + go v off - off 31 31 + 32 32 + let size_of_u64 buf off = 33 33 + let len = Bytes.length buf in 34 34 + let i = ref off in 35 35 + let result = ref 0 in 36 36 + let done_ = ref false in 37 37 + while not !done_ do 38 38 + if !i >= len then invalid_arg "Leb128: truncated varint"; 39 39 + if !i - off >= max_bytes_u64 then 40 40 + invalid_arg "Leb128: varint longer than 10 bytes"; 41 41 + let b = Bytes.get_uint8 buf !i in 42 42 + if b land 0x80 = 0 then begin 43 43 + result := !i - off + 1; 44 44 + done_ := true 45 45 + end 46 46 + else incr i 47 47 + done; 48 48 + !result 49 49 + 50 50 + let decode_u64_raw buf off = 51 51 + let len = Bytes.length buf in 52 52 + let rec go acc shift i = 53 53 + if i >= len then invalid_arg "Leb128: truncated varint" 54 54 + else if i - off >= max_bytes_u64 then 55 55 + invalid_arg "Leb128: varint longer than 10 bytes" 56 56 + else 57 57 + let b = Bytes.get_uint8 buf i in 58 58 + let lo = b land 0x7f in 59 59 + (* On the 10th byte (shift=63), only bit 0 of the payload is valid; 60 60 + anything else overflows u64. *) 61 61 + if shift = 63 && lo > 1 then invalid_arg "Leb128: u64 overflow"; 62 62 + let acc = Int64.logor acc (Int64.shift_left (Int64.of_int lo) shift) in 63 63 + if b land 0x80 = 0 then acc 64 64 + else if shift + 7 >= 64 then invalid_arg "Leb128: u64 overflow" 65 65 + else go acc (shift + 7) (i + 1) 66 66 + in 67 67 + go 0L 0 off 68 68 + 69 69 + let decode_u64 buf off = 70 70 + let v = decode_u64_raw buf off in 71 71 + (v, size_of_u64 buf off) 72 72 + 73 73 + (* -- Unsigned OCaml int (int63 on 64-bit). Operates on [int] directly, 74 74 + no int64 boxing, no closure allocation. [max_int] on 64-bit is 75 75 + 2^62 - 1; a value fits iff it never sets bit 62. -- *) 76 76 + 77 77 + let decode_u63_raw buf off = 78 78 + let len = Bytes.length buf in 79 79 + let acc = ref 0 in 80 80 + let shift = ref 0 in 81 81 + let i = ref off in 82 82 + let result = ref 0 in 83 83 + let done_ = ref false in 84 84 + while not !done_ do 85 85 + if !i >= len then invalid_arg "Leb128: truncated varint"; 86 86 + if !i - off >= max_bytes_u64 then 87 87 + invalid_arg "Leb128: varint longer than 10 bytes"; 88 88 + let b = Bytes.get_uint8 buf !i in 89 89 + let payload = b land 0x7f in 90 90 + if b land 0x80 = 0 then begin 91 91 + if !shift > 56 || (!shift = 56 && payload > 0x3f) then 92 92 + invalid_arg "Leb128: value exceeds OCaml int range"; 93 93 + result := !acc lor (payload lsl !shift); 94 94 + done_ := true 95 95 + end 96 96 + else begin 97 97 + if !shift + 7 >= 63 then 98 98 + invalid_arg "Leb128: value exceeds OCaml int range"; 99 99 + acc := !acc lor (payload lsl !shift); 100 100 + shift := !shift + 7; 101 101 + incr i 102 102 + end 103 103 + done; 104 104 + !result 105 105 + 106 106 + let decode_u63 buf off = 107 107 + let v = decode_u63_raw buf off in 108 108 + (v, size_of_u64 buf off) 109 109 + 110 110 + let encode_u63 v buf off = 111 111 + if v < 0 then invalid_arg "Leb128: negative int passed to unsigned encoder"; 112 112 + let v = ref v in 113 113 + let i = ref off in 114 114 + let done_ = ref false in 115 115 + while not !done_ do 116 116 + let byte = !v land 0x7f in 117 117 + let rest = !v lsr 7 in 118 118 + if rest = 0 then begin 119 119 + Bytes.set_uint8 buf !i byte; 120 120 + incr i; 121 121 + done_ := true 122 122 + end 123 123 + else begin 124 124 + Bytes.set_uint8 buf !i (byte lor 0x80); 125 125 + v := rest; 126 126 + incr i 127 127 + end 128 128 + done; 129 129 + !i - off 130 130 + 131 131 + let size_u63 v = 132 132 + if v < 0 then invalid_arg "Leb128: negative int passed to unsigned encoder"; 133 133 + if v = 0 then 1 134 134 + else 135 135 + let rec go v n = if v = 0 then n else go (v lsr 7) (n + 1) in 136 136 + go v 0 137 137 + 138 138 + (* -- Zig-zag. For 64-bit: [(v lsl 1) lxor (v asr 63)]. -- *) 139 139 + 140 140 + let zigzag_encode_i64 v = 141 141 + Int64.logxor (Int64.shift_left v 1) (Int64.shift_right v 63) 142 142 + 143 143 + let zigzag_decode_i64 v = 144 144 + Int64.logxor (Int64.shift_right_logical v 1) (Int64.neg (Int64.logand v 1L)) 145 145 + 146 146 + let encode_i64 v buf off = encode_u64 (zigzag_encode_i64 v) buf off 147 147 + let size_i64 v = size_u64 (zigzag_encode_i64 v) 148 148 + 149 149 + let decode_i64 buf off = 150 150 + let u, n = decode_u64 buf off in 151 151 + (zigzag_decode_i64 u, n) 152 152 + 153 153 + let encode_int v buf off = 154 154 + encode_u64 (zigzag_encode_i64 (Int64.of_int v)) buf off 155 155 + 156 156 + let size_int v = size_u64 (zigzag_encode_i64 (Int64.of_int v)) 157 157 + 158 158 + let decode_int buf off = 159 159 + let v, n = decode_i64 buf off in 160 160 + if 161 161 + Int64.compare v (Int64.of_int max_int) > 0 162 162 + || Int64.compare v (Int64.of_int min_int) < 0 163 163 + then invalid_arg "Leb128: signed value out of OCaml int range"; 164 164 + (Int64.to_int v, n) 165 165 + 166 166 + (* -- String convenience. 167 167 + [Bytes.unsafe_of_string] is O(1) and the decoders only read. -- *) 168 168 + 169 169 + let decode_u64_string s off = decode_u64 (Bytes.unsafe_of_string s) off 170 170 + let decode_u63_string s off = decode_u63 (Bytes.unsafe_of_string s) off 171 171 + let decode_i64_string s off = decode_i64 (Bytes.unsafe_of_string s) off 172 172 + let decode_int_string s off = decode_int (Bytes.unsafe_of_string s) off 173 173 + 174 174 + let encode_u64_string v = 175 175 + let buf = Bytes.create (size_u64 v) in 176 176 + let _ = encode_u64 v buf 0 in 177 177 + Bytes.unsafe_to_string buf 178 178 + 179 179 + let encode_u63_string v = 180 180 + let buf = Bytes.create (size_u63 v) in 181 181 + let _ = encode_u63 v buf 0 in 182 182 + Bytes.unsafe_to_string buf 183 183 + 184 184 + let encode_i64_string v = 185 185 + let buf = Bytes.create (size_i64 v) in 186 186 + let _ = encode_i64 v buf 0 in 187 187 + Bytes.unsafe_to_string buf 188 188 + 189 189 + let encode_int_string v = 190 190 + let buf = Bytes.create (size_int v) in 191 191 + let _ = encode_int v buf 0 in 192 192 + Bytes.unsafe_to_string buf 193 193 + 194 194 + let add_u64_to_buffer b v = 195 195 + let scratch = Bytes.create (size_u64 v) in 196 196 + let n = encode_u64 v scratch 0 in 197 197 + Buffer.add_subbytes b scratch 0 n 198 198 + 199 199 + let add_u63_to_buffer b v = 200 200 + let scratch = Bytes.create (size_u63 v) in 201 201 + let n = encode_u63 v scratch 0 in 202 202 + Buffer.add_subbytes b scratch 0 n 203 203 + 204 204 + let add_i64_to_buffer b v = 205 205 + let scratch = Bytes.create (size_i64 v) in 206 206 + let n = encode_i64 v scratch 0 in 207 207 + Buffer.add_subbytes b scratch 0 n 208 208 + 209 209 + let add_int_to_buffer b v = 210 210 + let scratch = Bytes.create (size_int v) in 211 211 + let n = encode_int v scratch 0 in 212 212 + Buffer.add_subbytes b scratch 0 n 213 213 + 214 214 + (* -- Streaming over Bytesrw. [sniff] peeks up to 10 bytes; if the varint 215 215 + fits we decode from the peeked prefix and [skip] the consumed count. 216 216 + The reader's position is rewound to just past the terminator. -- *) 217 217 + 218 218 + let sniff_bytes r = 219 219 + let s = Bytesrw.Bytes.Reader.sniff max_bytes_u64 r in 220 220 + Bytes.unsafe_of_string s 221 221 + 222 222 + let read_u64 r = 223 223 + let buf = sniff_bytes r in 224 224 + let v, n = decode_u64 buf 0 in 225 225 + Bytesrw.Bytes.Reader.skip n r; 226 226 + v 227 227 + 228 228 + let read_u63 r = 229 229 + let buf = sniff_bytes r in 230 230 + let v, n = decode_u63 buf 0 in 231 231 + Bytesrw.Bytes.Reader.skip n r; 232 232 + v 233 233 + 234 234 + let read_i64 r = 235 235 + let buf = sniff_bytes r in 236 236 + let v, n = decode_i64 buf 0 in 237 237 + Bytesrw.Bytes.Reader.skip n r; 238 238 + v 239 239 + 240 240 + let read_int r = 241 241 + let buf = sniff_bytes r in 242 242 + let v, n = decode_int buf 0 in 243 243 + Bytesrw.Bytes.Reader.skip n r; 244 244 + v 245 245 + 246 246 + let write_slice w buf n = 247 247 + let slice = Bytesrw.Bytes.Slice.make buf ~first:0 ~length:n in 248 248 + Bytesrw.Bytes.Writer.write w slice 249 249 + 250 250 + let write_u64 w v = 251 251 + let buf = Bytes.create (size_u64 v) in 252 252 + let n = encode_u64 v buf 0 in 253 253 + write_slice w buf n 254 254 + 255 255 + let write_u63 w v = 256 256 + let buf = Bytes.create (size_u63 v) in 257 257 + let n = encode_u63 v buf 0 in 258 258 + write_slice w buf n 259 259 + 260 260 + let write_i64 w v = 261 261 + let buf = Bytes.create (size_i64 v) in 262 262 + let n = encode_i64 v buf 0 in 263 263 + write_slice w buf n 264 264 + 265 265 + let write_int w v = 266 266 + let buf = Bytes.create (size_int v) in 267 267 + let n = encode_int v buf 0 in 268 268 + write_slice w buf n

+117

ocaml-leb128/lib/leb128.mli

reviewed

··· 1 1 + (** LEB128 variable-length integer codec. 2 2 + 3 3 + LEB128 (Little-Endian Base 128) encodes a non-negative integer as a sequence 4 4 + of 7-bit groups, low-order group first. Each byte's high bit is a 5 5 + continuation flag: set on every byte except the last. Used by DWARF, 6 6 + WebAssembly, protobuf (which calls it "varint"), IPLD CAR files, and Git 7 7 + pack-delta headers. 8 8 + 9 9 + Signed values map to unsigned LEB128 via zig-zag encoding, the convention 10 10 + protobuf uses for [sint32] and [sint64]: value [v] becomes 11 11 + [(v lsl 1) lxor (v asr bitwidth-1)], so small magnitudes of either sign stay 12 12 + small. 13 13 + 14 14 + All decoders reject over-long encodings (more bytes than the type can hold) 15 15 + and values out of range for the target type. Encoders never emit over-long 16 16 + forms. Errors are signalled by raising [Invalid_argument]. *) 17 17 + 18 18 + (** {1 Unsigned varints — [int64]} *) 19 19 + 20 20 + val decode_u64 : bytes -> int -> int64 * int 21 21 + (** [decode_u64 buf off] returns [(value, bytes_consumed)]. Raises 22 22 + [Invalid_argument] on over-long encoding, truncation, or overflow past 23 23 + [0xFFFF_FFFF_FFFF_FFFF]. Consumes at most 10 bytes. *) 24 24 + 25 25 + val decode_u64_raw : bytes -> int -> int64 26 26 + (** [decode_u64_raw buf off] returns just the decoded value, skipping the tuple 27 27 + allocation of {!decode_u64}. Use in hot loops where the consumed byte count 28 28 + is recoverable via {!size_of_u64}. *) 29 29 + 30 30 + val encode_u64 : int64 -> bytes -> int -> int 31 31 + (** [encode_u64 v buf off] writes [v] at [off] and returns the number of bytes 32 32 + written. *) 33 33 + 34 34 + val size_u64 : int64 -> int 35 35 + (** [size_u64 v] is the number of bytes [encode_u64 v _ _] writes. *) 36 36 + 37 37 + val size_of_u64 : bytes -> int -> int 38 38 + (** [size_of_u64 buf off] scans the encoding at [buf.{off..}] and returns the 39 39 + number of bytes the varint occupies. Raises [Invalid_argument] if no 40 40 + terminator is found within 10 bytes or the buffer is exhausted. *) 41 41 + 42 42 + (** {1 Unsigned varints — OCaml [int]} *) 43 43 + 44 44 + val decode_u63 : bytes -> int -> int * int 45 45 + (** [decode_u63 buf off] decodes into an OCaml [int]. Raises [Invalid_argument] 46 46 + if the decoded value exceeds [max_int] (2{^ 62} - 1 on 64-bit systems). *) 47 47 + 48 48 + val decode_u63_raw : bytes -> int -> int 49 49 + (** Fast path: decodes into OCaml [int] using [int] arithmetic, no [int64] 50 50 + boxing, no tuple allocation. Raises [Invalid_argument] if the value exceeds 51 51 + [max_int]. *) 52 52 + 53 53 + val encode_u63 : int -> bytes -> int -> int 54 54 + (** [encode_u63 v buf off] writes [v] as an unsigned LEB128. Raises 55 55 + [Invalid_argument] if [v] is negative. *) 56 56 + 57 57 + val size_u63 : int -> int 58 58 + (** [size_u63 v] is the number of bytes {!encode_u63} writes for [v]. Raises 59 59 + [Invalid_argument] if [v] is negative. *) 60 60 + 61 61 + (** {1 Zig-zag signed varints — [int64]} *) 62 62 + 63 63 + val zigzag_encode_i64 : int64 -> int64 64 64 + (** [zigzag_encode_i64 v] is [(v lsl 1) lxor (v asr 63)]. *) 65 65 + 66 66 + val zigzag_decode_i64 : int64 -> int64 67 67 + (** Inverse of {!zigzag_encode_i64}. *) 68 68 + 69 69 + val decode_i64 : bytes -> int -> int64 * int 70 70 + (** Decodes a zig-zag signed LEB128 as [int64]. *) 71 71 + 72 72 + val encode_i64 : int64 -> bytes -> int -> int 73 73 + (** Encodes [v] as a zig-zag signed LEB128. *) 74 74 + 75 75 + val size_i64 : int64 -> int 76 76 + 77 77 + (** {1 Zig-zag signed varints — OCaml [int]} *) 78 78 + 79 79 + val decode_int : bytes -> int -> int * int 80 80 + (** Decodes a zig-zag LEB128 as an OCaml [int]. Raises [Invalid_argument] if the 81 81 + decoded value is outside [[min_int, max_int]]. *) 82 82 + 83 83 + val encode_int : int -> bytes -> int -> int 84 84 + val size_int : int -> int 85 85 + 86 86 + (** {1 String convenience} 87 87 + 88 88 + Non-allocating reads from strings and allocating convenience wrappers for 89 89 + writes. These match the bytes-based API one-to-one. *) 90 90 + 91 91 + val decode_u64_string : string -> int -> int64 * int 92 92 + val decode_u63_string : string -> int -> int * int 93 93 + val decode_i64_string : string -> int -> int64 * int 94 94 + val decode_int_string : string -> int -> int * int 95 95 + val encode_u64_string : int64 -> string 96 96 + val encode_u63_string : int -> string 97 97 + val encode_i64_string : int64 -> string 98 98 + val encode_int_string : int -> string 99 99 + val add_u64_to_buffer : Buffer.t -> int64 -> unit 100 100 + val add_u63_to_buffer : Buffer.t -> int -> unit 101 101 + val add_i64_to_buffer : Buffer.t -> int64 -> unit 102 102 + val add_int_to_buffer : Buffer.t -> int -> unit 103 103 + 104 104 + (** {1 Streaming over Bytesrw} 105 105 + 106 106 + Readers use {!Bytesrw.Bytes.Reader.sniff} to look ahead by up to 10 bytes 107 107 + and {!Bytesrw.Bytes.Reader.skip} the consumed prefix. Writers emit a single 108 108 + slice per call. *) 109 109 + 110 110 + val read_u64 : Bytesrw.Bytes.Reader.t -> int64 111 111 + val read_u63 : Bytesrw.Bytes.Reader.t -> int 112 112 + val read_i64 : Bytesrw.Bytes.Reader.t -> int64 113 113 + val read_int : Bytesrw.Bytes.Reader.t -> int 114 114 + val write_u64 : Bytesrw.Bytes.Writer.t -> int64 -> unit 115 115 + val write_u63 : Bytesrw.Bytes.Writer.t -> int -> unit 116 116 + val write_i64 : Bytesrw.Bytes.Writer.t -> int64 -> unit 117 117 + val write_int : Bytesrw.Bytes.Writer.t -> int -> unit

+3

ocaml-leb128/test/dune

reviewed

··· 1 1 + (test 2 2 + (name test) 3 3 + (libraries leb128 bytesrw alcotest fmt))

+1

ocaml-leb128/test/test.ml

reviewed

··· 1 1 + let () = Alcotest.run "leb128" [ Test_leb128.suite ]

+328

ocaml-leb128/test/test_leb128.ml

reviewed

··· 1 1 + (* Spec-exact encodings drawn from RFC-style references (DWARF v5 Appendix E, 2 2 + the WebAssembly spec binary format, and the protobuf encoding guide). *) 3 3 + 4 4 + let hex s = 5 5 + let b = Buffer.create (2 * String.length s) in 6 6 + String.iter (fun c -> Buffer.add_string b (Fmt.str "%02x" (Char.code c))) s; 7 7 + Buffer.contents b 8 8 + 9 9 + let bs s = Bytes.of_string s 10 10 + 11 11 + (* --- Known unsigned encodings --- *) 12 12 + 13 13 + let test_encode_u64_known () = 14 14 + let check name v expected = 15 15 + let out = Bytes.create 10 in 16 16 + let n = Leb128.encode_u64 v out 0 in 17 17 + let got = Bytes.sub_string out 0 n in 18 18 + Alcotest.(check string) name (hex expected) (hex got) 19 19 + in 20 20 + check "0" 0L "\x00"; 21 21 + check "1" 1L "\x01"; 22 22 + check "127" 127L "\x7f"; 23 23 + check "128" 128L "\x80\x01"; 24 24 + check "300" 300L "\xac\x02"; 25 25 + check "16383" 16383L "\xff\x7f"; 26 26 + check "16384" 16384L "\x80\x80\x01"; 27 27 + check "max_u64" 0xffffffffffffffffL "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01" 28 28 + 29 29 + let test_decode_u64_known () = 30 30 + let check name input expected = 31 31 + let v, n = Leb128.decode_u64 (bs input) 0 in 32 32 + Alcotest.(check int64) (name ^ " value") expected v; 33 33 + Alcotest.(check int) (name ^ " consumed") (String.length input) n 34 34 + in 35 35 + check "0" "\x00" 0L; 36 36 + check "127" "\x7f" 127L; 37 37 + check "128" "\x80\x01" 128L; 38 38 + check "300" "\xac\x02" 300L; 39 39 + check "16384" "\x80\x80\x01" 16384L; 40 40 + check "max_u64" "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01" 0xffffffffffffffffL 41 41 + 42 42 + let test_encode_u63_known () = 43 43 + let check name v expected = 44 44 + let out = Bytes.create 10 in 45 45 + let n = Leb128.encode_u63 v out 0 in 46 46 + Alcotest.(check string) name (hex expected) (hex (Bytes.sub_string out 0 n)) 47 47 + in 48 48 + check "0" 0 "\x00"; 49 49 + check "127" 127 "\x7f"; 50 50 + check "128" 128 "\x80\x01"; 51 51 + check "300" 300 "\xac\x02" 52 52 + 53 53 + let test_encode_u63_negative () = 54 54 + Alcotest.check_raises "negative rejected" 55 55 + (Invalid_argument "Leb128: negative int passed to unsigned encoder") 56 56 + @@ fun () -> 57 57 + let out = Bytes.create 10 in 58 58 + ignore (Leb128.encode_u63 (-1) out 0) 59 59 + 60 60 + (* --- Round-trip sweep --- *) 61 61 + 62 62 + let roundtrip_u64 v = 63 63 + let out = Bytes.create 11 in 64 64 + let n = Leb128.encode_u64 v out 0 in 65 65 + let v', n' = Leb128.decode_u64 out 0 in 66 66 + Alcotest.(check int64) (Fmt.str "roundtrip %Lu" v) v v'; 67 67 + Alcotest.(check int) (Fmt.str "consumed %Lu" v) n n' 68 68 + 69 69 + let test_roundtrip_u64_sweep () = 70 70 + List.iter roundtrip_u64 71 71 + [ 72 72 + 0L; 73 73 + 1L; 74 74 + 127L; 75 75 + 128L; 76 76 + 129L; 77 77 + 255L; 78 78 + 256L; 79 79 + 16383L; 80 80 + 16384L; 81 81 + 0x1fffffffL; 82 82 + 0xffffffffL; 83 83 + 0x7fffffffffffL; 84 84 + Int64.max_int; 85 85 + 0x8000000000000000L; 86 86 + 0xffffffffffffffffL; 87 87 + ]; 88 88 + (* power-of-two boundaries *) 89 89 + for i = 0 to 63 do 90 90 + let v = Int64.shift_left 1L i in 91 91 + roundtrip_u64 v; 92 92 + roundtrip_u64 (Int64.sub v 1L) 93 93 + done 94 94 + 95 95 + let roundtrip_u63 v = 96 96 + let out = Bytes.create 10 in 97 97 + let n = Leb128.encode_u63 v out 0 in 98 98 + let v', n' = Leb128.decode_u63 out 0 in 99 99 + Alcotest.(check int) (Fmt.str "roundtrip %d" v) v v'; 100 100 + Alcotest.(check int) (Fmt.str "consumed %d" v) n n' 101 101 + 102 102 + let test_roundtrip_u63_sweep () = 103 103 + List.iter roundtrip_u63 104 104 + [ 105 105 + 0; 106 106 + 1; 107 107 + 127; 108 108 + 128; 109 109 + 129; 110 110 + 255; 111 111 + 256; 112 112 + 16383; 113 113 + 16384; 114 114 + 0x1fffffff; 115 115 + 0xffffffff; 116 116 + 0x7fffffffffff; 117 117 + max_int; 118 118 + ]; 119 119 + for i = 0 to 61 do 120 120 + let v = 1 lsl i in 121 121 + roundtrip_u63 v; 122 122 + roundtrip_u63 (v - 1) 123 123 + done 124 124 + 125 125 + (* --- Error cases --- *) 126 126 + 127 127 + let decode_u64_raises msg input = 128 128 + Alcotest.check_raises msg (Invalid_argument "") @@ fun () -> 129 129 + try ignore (Leb128.decode_u64 (bs input) 0) 130 130 + with Invalid_argument _ -> raise (Invalid_argument "") 131 131 + 132 132 + let test_truncated () = 133 133 + decode_u64_raises "empty" ""; 134 134 + decode_u64_raises "no terminator" "\x80\x80\x80" 135 135 + 136 136 + let test_overlong () = 137 137 + (* 11 bytes with continuation: must reject *) 138 138 + decode_u64_raises "11 bytes" "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01" 139 139 + 140 140 + let test_u64_overflow () = 141 141 + decode_u64_raises "10th byte = 2" "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02"; 142 142 + decode_u64_raises "10th byte = 0x80" 143 143 + "\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80" 144 144 + 145 145 + let test_u63_overflow () = 146 146 + (* max_u64 doesn't fit in OCaml int (max_int = 2^62 - 1) *) 147 147 + Alcotest.check_raises "u63 overflow" (Invalid_argument "") @@ fun () -> 148 148 + try 149 149 + ignore (Leb128.decode_u63 (bs "\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01") 0) 150 150 + with Invalid_argument _ -> raise (Invalid_argument "") 151 151 + 152 152 + (* --- size_of agrees with encode --- *) 153 153 + 154 154 + let test_size_of_consistency () = 155 155 + let check v = 156 156 + let out = Bytes.create 10 in 157 157 + let n = Leb128.encode_u64 v out 0 in 158 158 + Alcotest.(check int) (Fmt.str "size_u64 %Lu" v) n (Leb128.size_u64 v); 159 159 + Alcotest.(check int) 160 160 + (Fmt.str "size_of_u64 %Lu" v) 161 161 + n (Leb128.size_of_u64 out 0) 162 162 + in 163 163 + List.iter check [ 0L; 1L; 127L; 128L; 300L; Int64.max_int ] 164 164 + 165 165 + (* --- Zig-zag --- *) 166 166 + 167 167 + let test_zigzag () = 168 168 + let check name v expected = 169 169 + Alcotest.(check int64) name expected (Leb128.zigzag_encode_i64 v); 170 170 + Alcotest.(check int64) (name ^ " inv") v (Leb128.zigzag_decode_i64 expected) 171 171 + in 172 172 + check "0" 0L 0L; 173 173 + check "-1" (-1L) 1L; 174 174 + check "1" 1L 2L; 175 175 + check "-2" (-2L) 3L; 176 176 + check "2147483647" 2147483647L 4294967294L; 177 177 + check "-2147483648" (-2147483648L) 4294967295L; 178 178 + check "min_int64" Int64.min_int 0xffffffffffffffffL; 179 179 + check "max_int64" Int64.max_int 0xfffffffffffffffeL 180 180 + 181 181 + let roundtrip_i64 v = 182 182 + let out = Bytes.create 10 in 183 183 + let n = Leb128.encode_i64 v out 0 in 184 184 + let v', n' = Leb128.decode_i64 out 0 in 185 185 + Alcotest.(check int64) (Fmt.str "roundtrip i64 %Ld" v) v v'; 186 186 + Alcotest.(check int) (Fmt.str "consumed i64 %Ld" v) n n' 187 187 + 188 188 + let test_sint_roundtrip () = 189 189 + List.iter roundtrip_i64 190 190 + [ 191 191 + 0L; 192 192 + 1L; 193 193 + -1L; 194 194 + 63L; 195 195 + -63L; 196 196 + 64L; 197 197 + -64L; 198 198 + 8192L; 199 199 + -8192L; 200 200 + 1073741823L; 201 201 + -1073741824L; 202 202 + Int64.max_int; 203 203 + Int64.min_int; 204 204 + ] 205 205 + 206 206 + let test_int_roundtrip () = 207 207 + let check v = 208 208 + let out = Bytes.create 10 in 209 209 + let n = Leb128.encode_int v out 0 in 210 210 + let v', n' = Leb128.decode_int out 0 in 211 211 + Alcotest.(check int) (Fmt.str "roundtrip int %d" v) v v'; 212 212 + Alcotest.(check int) (Fmt.str "consumed int %d" v) n n' 213 213 + in 214 214 + List.iter check 215 215 + [ 0; 1; -1; 63; -63; 1_000_000_000; -1_000_000_000; max_int; min_int ] 216 216 + 217 217 + (* --- String/Buffer conveniences --- *) 218 218 + 219 219 + let test_string_roundtrip () = 220 220 + let check v = 221 221 + let s = Leb128.encode_u63_string v in 222 222 + let v', n = Leb128.decode_u63_string s 0 in 223 223 + Alcotest.(check int) (Fmt.str "string roundtrip %d" v) v v'; 224 224 + Alcotest.(check int) (Fmt.str "string consumed %d" v) (String.length s) n 225 225 + in 226 226 + List.iter check [ 0; 127; 128; 16383; 16384; 1_000_000; max_int ] 227 227 + 228 228 + let test_string_offset () = 229 229 + let prefix = "abc" in 230 230 + let encoded = Leb128.encode_u63_string 500 in 231 231 + let s = prefix ^ encoded in 232 232 + let v, n = Leb128.decode_u63_string s 3 in 233 233 + Alcotest.(check int) "decoded value at offset" 500 v; 234 234 + Alcotest.(check int) "consumed bytes" (String.length encoded) n 235 235 + 236 236 + let test_buffer () = 237 237 + let buf = Buffer.create 16 in 238 238 + Leb128.add_u63_to_buffer buf 300; 239 239 + Leb128.add_u63_to_buffer buf 1; 240 240 + let s = Buffer.contents buf in 241 241 + Alcotest.(check int) "total length" 3 (String.length s); 242 242 + let v1, n1 = Leb128.decode_u63_string s 0 in 243 243 + Alcotest.(check int) "first value" 300 v1; 244 244 + let v2, _ = Leb128.decode_u63_string s n1 in 245 245 + Alcotest.(check int) "second value" 1 v2 246 246 + 247 247 + (* --- Bytesrw streaming --- *) 248 248 + 249 249 + let test_bytesrw_read () = 250 250 + let r = Bytesrw.Bytes.Reader.of_string "\xac\x02\x01" in 251 251 + let v1 = Leb128.read_u63 r in 252 252 + Alcotest.(check int) "first varint" 300 v1; 253 253 + let v2 = Leb128.read_u63 r in 254 254 + Alcotest.(check int) "second varint" 1 v2 255 255 + 256 256 + let test_bytesrw_write () = 257 257 + let buf = Buffer.create 16 in 258 258 + let w = Bytesrw.Bytes.Writer.of_buffer buf in 259 259 + Leb128.write_u63 w 300; 260 260 + Leb128.write_u63 w 1; 261 261 + Bytesrw.Bytes.Writer.write_eod w; 262 262 + let got = Buffer.contents buf in 263 263 + Alcotest.(check string) "bytesrw writes" "\xac\x02\x01" got 264 264 + 265 265 + let test_bytesrw_roundtrip () = 266 266 + let values = [ 0L; 1L; 127L; 128L; 300L; Int64.max_int ] in 267 267 + let buf = Buffer.create 64 in 268 268 + let w = Bytesrw.Bytes.Writer.of_buffer buf in 269 269 + List.iter (Leb128.write_u64 w) values; 270 270 + Bytesrw.Bytes.Writer.write_eod w; 271 271 + let r = Bytesrw.Bytes.Reader.of_string (Buffer.contents buf) in 272 272 + List.iter 273 273 + (fun expected -> 274 274 + Alcotest.(check int64) 275 275 + (Fmt.str "bytesrw rt %Lu" expected) 276 276 + expected (Leb128.read_u64 r)) 277 277 + values 278 278 + 279 279 + let test_bytesrw_truncated () = 280 280 + let r = Bytesrw.Bytes.Reader.of_string "\x80\x80" in 281 281 + Alcotest.check_raises "truncated raises" (Invalid_argument "") @@ fun () -> 282 282 + try ignore (Leb128.read_u63 r) 283 283 + with Invalid_argument _ -> raise (Invalid_argument "") 284 284 + 285 285 + (* --- Protobuf smoke test (from the protobuf encoding guide). 286 286 + message { int32 id = 1; string name = 2; sint32 score = 3; } 287 287 + id=150, name="abc", score=-1 288 288 + Bytes: 08 96 01 12 03 "abc" 18 01 *) 289 289 + 290 290 + let test_protobuf_bytes () = 291 291 + let pb = bs "\x08\x96\x01\x12\x03abc\x18\x01" in 292 292 + let tag1 = Bytes.get_uint8 pb 0 in 293 293 + Alcotest.(check int) "tag1" 0x08 tag1; 294 294 + let id, n = Leb128.decode_u63 pb 1 in 295 295 + Alcotest.(check int) "id" 150 id; 296 296 + Alcotest.(check int) "id size" 2 n; 297 297 + let tag3 = Bytes.get_uint8 pb 8 in 298 298 + Alcotest.(check int) "tag3" 0x18 tag3; 299 299 + let score, _ = Leb128.decode_int pb 9 in 300 300 + Alcotest.(check int) "score (zigzag)" (-1) score 301 301 + 302 302 + let suite = 303 303 + ( "leb128", 304 304 + [ 305 305 + Alcotest.test_case "encode u64 known values" `Quick test_encode_u64_known; 306 306 + Alcotest.test_case "decode u64 known values" `Quick test_decode_u64_known; 307 307 + Alcotest.test_case "encode u63 known values" `Quick test_encode_u63_known; 308 308 + Alcotest.test_case "encode u63 negative rejected" `Quick 309 309 + test_encode_u63_negative; 310 310 + Alcotest.test_case "u64 round-trip sweep" `Quick test_roundtrip_u64_sweep; 311 311 + Alcotest.test_case "u63 round-trip sweep" `Quick test_roundtrip_u63_sweep; 312 312 + Alcotest.test_case "truncated input" `Quick test_truncated; 313 313 + Alcotest.test_case "over-long rejected" `Quick test_overlong; 314 314 + Alcotest.test_case "u64 overflow rejected" `Quick test_u64_overflow; 315 315 + Alcotest.test_case "u63 overflow rejected" `Quick test_u63_overflow; 316 316 + Alcotest.test_case "size_of consistency" `Quick test_size_of_consistency; 317 317 + Alcotest.test_case "zigzag values" `Quick test_zigzag; 318 318 + Alcotest.test_case "i64 round-trip" `Quick test_sint_roundtrip; 319 319 + Alcotest.test_case "int round-trip" `Quick test_int_roundtrip; 320 320 + Alcotest.test_case "string round-trip" `Quick test_string_roundtrip; 321 321 + Alcotest.test_case "string with offset" `Quick test_string_offset; 322 322 + Alcotest.test_case "buffer append" `Quick test_buffer; 323 323 + Alcotest.test_case "bytesrw read" `Quick test_bytesrw_read; 324 324 + Alcotest.test_case "bytesrw write" `Quick test_bytesrw_write; 325 325 + Alcotest.test_case "bytesrw round-trip" `Quick test_bytesrw_roundtrip; 326 326 + Alcotest.test_case "bytesrw truncated" `Quick test_bytesrw_truncated; 327 327 + Alcotest.test_case "protobuf bytes" `Quick test_protobuf_bytes; 328 328 + ] )

+1

ocaml-leb128/test/test_leb128.mli

reviewed

··· 1 1 + val suite : string * unit Alcotest.test_case list

+1 -1

ocaml-tcpcl/dune-project

reviewed

··· 14 14 (package 15 15 (name tcpcl) 16 16 (synopsis "TCP Convergence Layer Protocol v4 (RFC 9174)") 17 17 - (tags (org:blacksun aerospace codec network)) 17 17 + (tags (org:blacksun aerospace codec.binary network)) 18 18 (description 19 19 "TCPCL v4 is the TCP-based convergence layer for Bundle Protocol, 20 20 providing reliable bundle transfer over TCP connections with TLS support,

+7 -3

ocaml-tcpcl/fuzz/fuzz_tcpcl.ml

reviewed

··· 49 49 if s.node_id <> node_id then fail "node_id mismatch" 50 50 | _ -> fail "SESS_INIT decode failed" 51 51 52 52 - (** XFER_SEGMENT roundtrip. *) 53 53 - let test_xfer_segment_roundtrip tid is_start is_end data = 52 52 + (** XFER_SEGMENT roundtrip. The two boundary flags are packed into a single 53 53 + [flag_bits] integer (low bit = is_start, next = is_end) so the fuzz 54 54 + generator emits one value rather than two unlabeled bools. *) 55 55 + let test_xfer_segment_roundtrip tid flag_bits data = 56 56 + let is_start = flag_bits land 1 <> 0 in 57 57 + let is_end = (flag_bits lsr 1) land 1 <> 0 in 54 58 let data = truncate data in 55 59 let msg = 56 60 Tcpcl.Xfer_segment ··· 81 85 [ range 65536; range 1000000; range 10000000; bytes ] 82 86 test_sess_init_roundtrip; 83 87 test_case "XFER_SEGMENT roundtrip" 84 84 - [ range 1000000; bool; bool; bytes ] 88 88 + [ range 1000000; range 4; bytes ] 85 89 test_xfer_segment_roundtrip; 86 90 test_case "KEEPALIVE roundtrip" [ const () ] test_keepalive_roundtrip; 87 91 ] )

+1 -1

ocaml-tcpcl/tcpcl.opam

reviewed

··· 8 8 maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"] 9 9 authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"] 10 10 license: "ISC" 11 11 - tags: ["org:blacksun" "aerospace" "codec" "network"] 11 11 + tags: ["org:blacksun" "aerospace" "codec.binary" "network"] 12 12 homepage: "https://tangled.org/gazagnaire.org/ocaml-tcpcl" 13 13 bug-reports: "https://tangled.org/gazagnaire.org/ocaml-tcpcl/issues" 14 14 depends: [

+1 -1

ocaml-tcpcl/test/test.ml

reviewed

··· 1 1 - let () = Alcotest.run "tcpcl" [ Test_tcpcl.suite; Test_tcpcl_v3.suite ] 1 1 + let () = Alcotest.run "tcpcl" [ Test_tcpcl.suite ]

+455 -1

ocaml-tcpcl/test/test_tcpcl.ml

reviewed

··· 170 170 171 171 (* {1 Test Suite} *) 172 172 173 173 + (* {1 TCPCL v3 cases (RFC 7242, formerly test_tcpcl_v3.ml)} *) 174 174 + 175 175 + (* {1 SDNV Tests} *) 176 176 + 177 177 + let test_sdnv_zero () = 178 178 + let encoded = Tcpcl.V3.encode_sdnv 0L in 179 179 + Alcotest.(check int) "length" 1 (String.length encoded); 180 180 + Alcotest.(check char) "byte" '\x00' encoded.[0]; 181 181 + match Tcpcl.V3.decode_sdnv encoded 0 with 182 182 + | Ok (v, off) -> 183 183 + Alcotest.(check int64) "value" 0L v; 184 184 + Alcotest.(check int) "offset" 1 off 185 185 + | Error e -> Alcotest.failf "decode failed: %s" e 186 186 + 187 187 + let test_sdnv_small () = 188 188 + (* 127 fits in one byte *) 189 189 + let encoded = Tcpcl.V3.encode_sdnv 127L in 190 190 + Alcotest.(check int) "length" 1 (String.length encoded); 191 191 + match Tcpcl.V3.decode_sdnv encoded 0 with 192 192 + | Ok (v, _) -> Alcotest.(check int64) "value" 127L v 193 193 + | Error e -> Alcotest.failf "decode failed: %s" e 194 194 + 195 195 + let test_sdnv_128 () = 196 196 + (* 128 = 0x80 needs two bytes: 0x81 0x00 *) 197 197 + let encoded = Tcpcl.V3.encode_sdnv 128L in 198 198 + Alcotest.(check int) "length" 2 (String.length encoded); 199 199 + match Tcpcl.V3.decode_sdnv encoded 0 with 200 200 + | Ok (v, off) -> 201 201 + Alcotest.(check int64) "value" 128L v; 202 202 + Alcotest.(check int) "offset" 2 off 203 203 + | Error e -> Alcotest.failf "decode failed: %s" e 204 204 + 205 205 + let test_sdnv_large () = 206 206 + (* Test with a larger value that needs multiple bytes *) 207 207 + let n = 16384L in 208 208 + let encoded = Tcpcl.V3.encode_sdnv n in 209 209 + Alcotest.(check int) "length" 3 (String.length encoded); 210 210 + match Tcpcl.V3.decode_sdnv encoded 0 with 211 211 + | Ok (v, _) -> Alcotest.(check int64) "value" n v 212 212 + | Error e -> Alcotest.failf "decode failed: %s" e 213 213 + 214 214 + let test_sdnv_roundtrip () = 215 215 + let values = [ 0L; 1L; 127L; 128L; 255L; 256L; 16383L; 16384L; 1000000L ] in 216 216 + List.iter 217 217 + (fun n -> 218 218 + let encoded = Tcpcl.V3.encode_sdnv n in 219 219 + match Tcpcl.V3.decode_sdnv encoded 0 with 220 220 + | Ok (v, _) -> Alcotest.(check int64) (Int64.to_string n) n v 221 221 + | Error e -> Alcotest.failf "decode %Ld failed: %s" n e) 222 222 + values 223 223 + 224 224 + (* {1 Contact Header Tests} *) 225 225 + 226 226 + let test_v3_contact_header_roundtrip () = 227 227 + let h = 228 228 + Tcpcl.V3. 229 229 + { 230 230 + flags = 231 231 + { 232 232 + request_ack = true; 233 233 + reactive_frag = false; 234 234 + allow_refusal = true; 235 235 + request_length = false; 236 236 + }; 237 237 + keepalive_interval = 30; 238 238 + eid = "dtn://node1.example/"; 239 239 + } 240 240 + in 241 241 + let encoded = Tcpcl.V3.encode_contact_header h in 242 242 + (* Check magic *) 243 243 + Alcotest.(check string) "magic" "dtn!" (String.sub encoded 0 4); 244 244 + (* Check version *) 245 245 + Alcotest.(check int) "version" 0x03 (Char.code encoded.[4]); 246 246 + match Tcpcl.V3.decode_contact_header encoded with 247 247 + | Ok decoded -> 248 248 + Alcotest.(check bool) "request_ack" true decoded.flags.request_ack; 249 249 + Alcotest.(check bool) "reactive_frag" false decoded.flags.reactive_frag; 250 250 + Alcotest.(check bool) "allow_refusal" true decoded.flags.allow_refusal; 251 251 + Alcotest.(check bool) "request_length" false decoded.flags.request_length; 252 252 + Alcotest.(check int) "keepalive" 30 decoded.keepalive_interval; 253 253 + Alcotest.(check string) "eid" "dtn://node1.example/" decoded.eid 254 254 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 255 255 + 256 256 + let test_contact_header_default () = 257 257 + let h = Tcpcl.V3.contact_header_default in 258 258 + let encoded = Tcpcl.V3.encode_contact_header h in 259 259 + match Tcpcl.V3.decode_contact_header encoded with 260 260 + | Ok decoded -> 261 261 + Alcotest.(check bool) "request_ack" false decoded.flags.request_ack; 262 262 + Alcotest.(check bool) "reactive_frag" false decoded.flags.reactive_frag; 263 263 + Alcotest.(check bool) "allow_refusal" false decoded.flags.allow_refusal; 264 264 + Alcotest.(check bool) "request_length" false decoded.flags.request_length; 265 265 + Alcotest.(check int) "keepalive" 0 decoded.keepalive_interval; 266 266 + Alcotest.(check string) "eid" "" decoded.eid 267 267 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 268 268 + 269 269 + let test_contact_header_all_flags () = 270 270 + let h = 271 271 + Tcpcl.V3. 272 272 + { 273 273 + flags = 274 274 + { 275 275 + request_ack = true; 276 276 + reactive_frag = true; 277 277 + allow_refusal = true; 278 278 + request_length = true; 279 279 + }; 280 280 + keepalive_interval = 65535; 281 281 + eid = "dtn://all-flags/"; 282 282 + } 283 283 + in 284 284 + let encoded = Tcpcl.V3.encode_contact_header h in 285 285 + match Tcpcl.V3.decode_contact_header encoded with 286 286 + | Ok decoded -> 287 287 + Alcotest.(check bool) "request_ack" true decoded.flags.request_ack; 288 288 + Alcotest.(check bool) "reactive_frag" true decoded.flags.reactive_frag; 289 289 + Alcotest.(check bool) "allow_refusal" true decoded.flags.allow_refusal; 290 290 + Alcotest.(check bool) "request_length" true decoded.flags.request_length; 291 291 + Alcotest.(check int) "keepalive" 65535 decoded.keepalive_interval; 292 292 + Alcotest.(check string) "eid" "dtn://all-flags/" decoded.eid 293 293 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 294 294 + 295 295 + let test_v3_contact_header_invalid_magic () = 296 296 + let bad = "bad!\x03\x00\x00\x1e\x00" in 297 297 + match Tcpcl.V3.decode_contact_header bad with 298 298 + | Ok _ -> Alcotest.fail "should reject bad magic" 299 299 + | Error Tcpcl.Invalid_magic -> () 300 300 + | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 301 301 + 302 302 + let test_v3_contact_header_invalid_version () = 303 303 + let bad = "dtn!\x04\x00\x00\x1e\x00" in 304 304 + match Tcpcl.V3.decode_contact_header bad with 305 305 + | Ok _ -> Alcotest.fail "should reject bad version" 306 306 + | Error (Tcpcl.Invalid_version 4) -> () 307 307 + | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 308 308 + 309 309 + let test_contact_header_long_eid () = 310 310 + let eid = String.make 300 'x' in 311 311 + let h = 312 312 + Tcpcl.V3.{ flags = contact_flags_default; keepalive_interval = 10; eid } 313 313 + in 314 314 + let encoded = Tcpcl.V3.encode_contact_header h in 315 315 + match Tcpcl.V3.decode_contact_header encoded with 316 316 + | Ok decoded -> 317 317 + Alcotest.(check int) "eid length" 300 (String.length decoded.eid); 318 318 + Alcotest.(check string) "eid" eid decoded.eid 319 319 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 320 320 + 321 321 + (* {1 Data Segment Tests} *) 322 322 + 323 323 + let test_data_segment_roundtrip () = 324 324 + let data = "Hello, DTN!" in 325 325 + let msg = 326 326 + Tcpcl.V3.Data_segment { flags = { seg_start = true; seg_end = true }; data } 327 327 + in 328 328 + let encoded = Tcpcl.V3.encode_message msg in 329 329 + match Tcpcl.V3.decode_message encoded with 330 330 + | Ok (Tcpcl.V3.Data_segment s, _) -> 331 331 + Alcotest.(check bool) "seg_start" true s.flags.seg_start; 332 332 + Alcotest.(check bool) "seg_end" true s.flags.seg_end; 333 333 + Alcotest.(check string) "data" data s.data 334 334 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 335 335 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 336 336 + 337 337 + let test_data_segment_start_only () = 338 338 + let msg = 339 339 + Tcpcl.V3.Data_segment 340 340 + { flags = { seg_start = true; seg_end = false }; data = "part1" } 341 341 + in 342 342 + let encoded = Tcpcl.V3.encode_message msg in 343 343 + match Tcpcl.V3.decode_message encoded with 344 344 + | Ok (Tcpcl.V3.Data_segment s, _) -> 345 345 + Alcotest.(check bool) "seg_start" true s.flags.seg_start; 346 346 + Alcotest.(check bool) "seg_end" false s.flags.seg_end; 347 347 + Alcotest.(check string) "data" "part1" s.data 348 348 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 349 349 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 350 350 + 351 351 + let test_data_segment_empty () = 352 352 + let msg = 353 353 + Tcpcl.V3.Data_segment 354 354 + { flags = { seg_start = true; seg_end = true }; data = "" } 355 355 + in 356 356 + let encoded = Tcpcl.V3.encode_message msg in 357 357 + match Tcpcl.V3.decode_message encoded with 358 358 + | Ok (Tcpcl.V3.Data_segment s, _) -> Alcotest.(check string) "data" "" s.data 359 359 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 360 360 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 361 361 + 362 362 + (* {1 Ack Segment Tests} *) 363 363 + 364 364 + let test_ack_segment_roundtrip () = 365 365 + let msg = 366 366 + Tcpcl.V3.Ack_segment 367 367 + { flags = { seg_start = true; seg_end = true }; length = 1024L } 368 368 + in 369 369 + let encoded = Tcpcl.V3.encode_message msg in 370 370 + match Tcpcl.V3.decode_message encoded with 371 371 + | Ok (Tcpcl.V3.Ack_segment a, _) -> 372 372 + Alcotest.(check bool) "seg_start" true a.flags.seg_start; 373 373 + Alcotest.(check bool) "seg_end" true a.flags.seg_end; 374 374 + Alcotest.(check int64) "length" 1024L a.length 375 375 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 376 376 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 377 377 + 378 378 + let test_ack_segment_zero () = 379 379 + let msg = 380 380 + Tcpcl.V3.Ack_segment 381 381 + { flags = { seg_start = false; seg_end = false }; length = 0L } 382 382 + in 383 383 + let encoded = Tcpcl.V3.encode_message msg in 384 384 + match Tcpcl.V3.decode_message encoded with 385 385 + | Ok (Tcpcl.V3.Ack_segment a, _) -> 386 386 + Alcotest.(check int64) "length" 0L a.length 387 387 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 388 388 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 389 389 + 390 390 + (* {1 Refuse Bundle Tests} *) 391 391 + 392 392 + let test_refuse_bundle_roundtrip () = 393 393 + let reasons = 394 394 + Tcpcl.V3. 395 395 + [ 396 396 + Refuse_unknown; Refuse_completed; Refuse_no_resources; Refuse_retransmit; 397 397 + ] 398 398 + in 399 399 + List.iter 400 400 + (fun reason -> 401 401 + let msg = Tcpcl.V3.Refuse_bundle reason in 402 402 + let encoded = Tcpcl.V3.encode_message msg in 403 403 + Alcotest.(check int) "length" 1 (String.length encoded); 404 404 + match Tcpcl.V3.decode_message encoded with 405 405 + | Ok (Tcpcl.V3.Refuse_bundle r, _) -> 406 406 + Alcotest.(check int) 407 407 + (Fmt.str "%a" Tcpcl.V3.pp_refuse_reason reason) 408 408 + (Tcpcl.V3.refuse_reason_to_int reason) 409 409 + (Tcpcl.V3.refuse_reason_to_int r) 410 410 + | Ok (msg, _) -> 411 411 + Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 412 412 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e) 413 413 + reasons 414 414 + 415 415 + (* {1 Keepalive Tests} *) 416 416 + 417 417 + let test_v3_keepalive_roundtrip () = 418 418 + let msg = Tcpcl.V3.Keepalive in 419 419 + let encoded = Tcpcl.V3.encode_message msg in 420 420 + Alcotest.(check int) "length" 1 (String.length encoded); 421 421 + match Tcpcl.V3.decode_message encoded with 422 422 + | Ok (Tcpcl.V3.Keepalive, consumed) -> 423 423 + Alcotest.(check int) "consumed" 1 consumed 424 424 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 425 425 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 426 426 + 427 427 + (* {1 Shutdown Tests} *) 428 428 + 429 429 + let test_shutdown_no_fields () = 430 430 + let msg = Tcpcl.V3.Shutdown { reason = None; delay = None } in 431 431 + let encoded = Tcpcl.V3.encode_message msg in 432 432 + Alcotest.(check int) "length" 1 (String.length encoded); 433 433 + match Tcpcl.V3.decode_message encoded with 434 434 + | Ok (Tcpcl.V3.Shutdown s, _) -> 435 435 + Alcotest.(check bool) "reason" true (Option.is_none s.reason); 436 436 + Alcotest.(check bool) "delay" true (Option.is_none s.delay) 437 437 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 438 438 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 439 439 + 440 440 + let test_shutdown_reason_only () = 441 441 + let msg = 442 442 + Tcpcl.V3.Shutdown { reason = Some Tcpcl.V3.Version_mismatch; delay = None } 443 443 + in 444 444 + let encoded = Tcpcl.V3.encode_message msg in 445 445 + match Tcpcl.V3.decode_message encoded with 446 446 + | Ok (Tcpcl.V3.Shutdown s, _) -> 447 447 + (match s.reason with 448 448 + | Some Tcpcl.V3.Version_mismatch -> () 449 449 + | _ -> Alcotest.fail "wrong shutdown reason"); 450 450 + Alcotest.(check bool) "delay" true (Option.is_none s.delay) 451 451 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 452 452 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 453 453 + 454 454 + let test_shutdown_delay_only () = 455 455 + let msg = Tcpcl.V3.Shutdown { reason = None; delay = Some 300 } in 456 456 + let encoded = Tcpcl.V3.encode_message msg in 457 457 + match Tcpcl.V3.decode_message encoded with 458 458 + | Ok (Tcpcl.V3.Shutdown s, _) -> ( 459 459 + Alcotest.(check bool) "reason" true (Option.is_none s.reason); 460 460 + match s.delay with 461 461 + | Some 300 -> () 462 462 + | _ -> Alcotest.fail "wrong delay value") 463 463 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 464 464 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 465 465 + 466 466 + let test_shutdown_both () = 467 467 + let msg = 468 468 + Tcpcl.V3.Shutdown { reason = Some Tcpcl.V3.Busy; delay = Some 60 } 469 469 + in 470 470 + let encoded = Tcpcl.V3.encode_message msg in 471 471 + match Tcpcl.V3.decode_message encoded with 472 472 + | Ok (Tcpcl.V3.Shutdown s, _) -> ( 473 473 + (match s.reason with 474 474 + | Some Tcpcl.V3.Busy -> () 475 475 + | _ -> Alcotest.fail "wrong shutdown reason"); 476 476 + match s.delay with 477 477 + | Some 60 -> () 478 478 + | _ -> Alcotest.fail "wrong delay value") 479 479 + | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 480 480 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 481 481 + 482 482 + let test_shutdown_all_reasons () = 483 483 + let reasons = Tcpcl.V3.[ Idle; Version_mismatch; Busy ] in 484 484 + List.iter 485 485 + (fun reason -> 486 486 + let msg = Tcpcl.V3.Shutdown { reason = Some reason; delay = None } in 487 487 + let encoded = Tcpcl.V3.encode_message msg in 488 488 + match Tcpcl.V3.decode_message encoded with 489 489 + | Ok (Tcpcl.V3.Shutdown s, _) -> ( 490 490 + match s.reason with 491 491 + | Some r -> 492 492 + Alcotest.(check int) 493 493 + (Fmt.str "%a" Tcpcl.V3.pp_shutdown_reason reason) 494 494 + (Tcpcl.V3.shutdown_reason_to_int reason) 495 495 + (Tcpcl.V3.shutdown_reason_to_int r) 496 496 + | None -> Alcotest.fail "missing reason") 497 497 + | Ok (msg, _) -> 498 498 + Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 499 499 + | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e) 500 500 + reasons 501 501 + 502 502 + (* {1 Pretty-printer Tests} *) 503 503 + 504 504 + let contains s sub = 505 505 + let slen = String.length s in 506 506 + let sublen = String.length sub in 507 507 + if sublen > slen then false 508 508 + else 509 509 + let rec check i = 510 510 + if i > slen - sublen then false 511 511 + else if String.sub s i sublen = sub then true 512 512 + else check (i + 1) 513 513 + in 514 514 + check 0 515 515 + 516 516 + let test_pp_contact_header () = 517 517 + let h = 518 518 + Tcpcl.V3. 519 519 + { 520 520 + flags = 521 521 + { 522 522 + request_ack = true; 523 523 + reactive_frag = false; 524 524 + allow_refusal = false; 525 525 + request_length = false; 526 526 + }; 527 527 + keepalive_interval = 30; 528 528 + eid = "dtn://node1/"; 529 529 + } 530 530 + in 531 531 + let s = Fmt.str "%a" Tcpcl.V3.pp_contact_header h in 532 532 + Alcotest.(check bool) "contains TCPCLv3" true (contains s "TCPCLv3"); 533 533 + Alcotest.(check bool) "contains eid" true (contains s "dtn://node1/") 534 534 + 535 535 + let test_pp_message () = 536 536 + let msgs = 537 537 + Tcpcl.V3. 538 538 + [ 539 539 + Data_segment 540 540 + { flags = { seg_start = true; seg_end = true }; data = "x" }; 541 541 + Ack_segment 542 542 + { flags = { seg_start = true; seg_end = false }; length = 42L }; 543 543 + Refuse_bundle Refuse_completed; 544 544 + Keepalive; 545 545 + Shutdown { reason = Some Busy; delay = Some 10 }; 546 546 + ] 547 547 + in 548 548 + List.iter 549 549 + (fun msg -> 550 550 + let s = Fmt.str "%a" Tcpcl.V3.pp_message msg in 551 551 + Alcotest.(check bool) "non-empty pp output" true (String.length s > 0)) 552 552 + msgs 553 553 + 554 554 + (* {1 Error Handling Tests} *) 555 555 + 556 556 + let test_truncated_message () = 557 557 + match Tcpcl.V3.decode_message "" with 558 558 + | Ok _ -> Alcotest.fail "should fail on empty input" 559 559 + | Error (Tcpcl.Truncated _) -> () 560 560 + | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 561 561 + 562 562 + let test_invalid_message_type () = 563 563 + (* Type 0xF is not a valid v3 message type *) 564 564 + let bad = "\xF0" in 565 565 + match Tcpcl.V3.decode_message bad with 566 566 + | Ok _ -> Alcotest.fail "should reject invalid type" 567 567 + | Error (Tcpcl.Invalid_message_type _) -> () 568 568 + | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 569 569 + 570 570 + (* {1 Test Suite} *) 571 571 + 572 572 + let v3_cases = 573 573 + [ 574 574 + (* SDNV *) 575 575 + Alcotest.test_case "v3: sdnv zero" `Quick test_sdnv_zero; 576 576 + Alcotest.test_case "v3: sdnv small" `Quick test_sdnv_small; 577 577 + Alcotest.test_case "v3: sdnv 128" `Quick test_sdnv_128; 578 578 + Alcotest.test_case "v3: sdnv large" `Quick test_sdnv_large; 579 579 + Alcotest.test_case "v3: sdnv roundtrip" `Quick test_sdnv_roundtrip; 580 580 + (* Contact header *) 581 581 + Alcotest.test_case "v3: contact header roundtrip" `Quick 582 582 + test_v3_contact_header_roundtrip; 583 583 + Alcotest.test_case "v3: contact header default" `Quick 584 584 + test_contact_header_default; 585 585 + Alcotest.test_case "v3: contact header all flags" `Quick 586 586 + test_contact_header_all_flags; 587 587 + Alcotest.test_case "v3: contact header invalid magic" `Quick 588 588 + test_v3_contact_header_invalid_magic; 589 589 + Alcotest.test_case "v3: contact header invalid version" `Quick 590 590 + test_v3_contact_header_invalid_version; 591 591 + Alcotest.test_case "v3: contact header long EID" `Quick 592 592 + test_contact_header_long_eid; 593 593 + (* Data segment *) 594 594 + Alcotest.test_case "v3: data segment roundtrip" `Quick 595 595 + test_data_segment_roundtrip; 596 596 + Alcotest.test_case "v3: data segment start only" `Quick 597 597 + test_data_segment_start_only; 598 598 + Alcotest.test_case "v3: data segment empty" `Quick test_data_segment_empty; 599 599 + (* Ack segment *) 600 600 + Alcotest.test_case "v3: ack segment roundtrip" `Quick 601 601 + test_ack_segment_roundtrip; 602 602 + Alcotest.test_case "v3: ack segment zero" `Quick test_ack_segment_zero; 603 603 + (* Refuse bundle *) 604 604 + Alcotest.test_case "v3: refuse bundle roundtrip" `Quick 605 605 + test_refuse_bundle_roundtrip; 606 606 + (* Keepalive *) 607 607 + Alcotest.test_case "v3: keepalive roundtrip" `Quick 608 608 + test_v3_keepalive_roundtrip; 609 609 + (* Shutdown *) 610 610 + Alcotest.test_case "v3: shutdown no fields" `Quick test_shutdown_no_fields; 611 611 + Alcotest.test_case "v3: shutdown reason only" `Quick 612 612 + test_shutdown_reason_only; 613 613 + Alcotest.test_case "v3: shutdown delay only" `Quick test_shutdown_delay_only; 614 614 + Alcotest.test_case "v3: shutdown both" `Quick test_shutdown_both; 615 615 + Alcotest.test_case "v3: shutdown all reasons" `Quick 616 616 + test_shutdown_all_reasons; 617 617 + (* Pretty-printers *) 618 618 + Alcotest.test_case "v3: pp contact header" `Quick test_pp_contact_header; 619 619 + Alcotest.test_case "v3: pp message" `Quick test_pp_message; 620 620 + (* Error handling *) 621 621 + Alcotest.test_case "v3: truncated message" `Quick test_truncated_message; 622 622 + Alcotest.test_case "v3: invalid message type" `Quick 623 623 + test_invalid_message_type; 624 624 + ] 625 625 + 173 626 let suite = 174 627 ( "tcpcl", 175 628 [ ··· 191 644 Alcotest.test_case "keepalive roundtrip" `Quick test_keepalive_roundtrip; 192 645 Alcotest.test_case "negotiate keepalive" `Quick test_negotiate_keepalive; 193 646 Alcotest.test_case "negotiate mru" `Quick test_negotiate_mru; 194 194 - ] ) 647 647 + ] 648 648 + @ v3_cases )

-454

ocaml-tcpcl/test/test_tcpcl_v3.ml

reviewed

··· 1 1 - (*--------------------------------------------------------------------------- 2 2 - Copyright (c) 2025 Thomas Gazagnaire. All rights reserved. 3 3 - SPDX-License-Identifier: ISC 4 4 - ---------------------------------------------------------------------------*) 5 5 - 6 6 - (** Tests for TCPCL v3 (RFC 7242). *) 7 7 - 8 8 - (* {1 SDNV Tests} *) 9 9 - 10 10 - let test_sdnv_zero () = 11 11 - let encoded = Tcpcl.V3.encode_sdnv 0L in 12 12 - Alcotest.(check int) "length" 1 (String.length encoded); 13 13 - Alcotest.(check char) "byte" '\x00' encoded.[0]; 14 14 - match Tcpcl.V3.decode_sdnv encoded 0 with 15 15 - | Ok (v, off) -> 16 16 - Alcotest.(check int64) "value" 0L v; 17 17 - Alcotest.(check int) "offset" 1 off 18 18 - | Error e -> Alcotest.failf "decode failed: %s" e 19 19 - 20 20 - let test_sdnv_small () = 21 21 - (* 127 fits in one byte *) 22 22 - let encoded = Tcpcl.V3.encode_sdnv 127L in 23 23 - Alcotest.(check int) "length" 1 (String.length encoded); 24 24 - match Tcpcl.V3.decode_sdnv encoded 0 with 25 25 - | Ok (v, _) -> Alcotest.(check int64) "value" 127L v 26 26 - | Error e -> Alcotest.failf "decode failed: %s" e 27 27 - 28 28 - let test_sdnv_128 () = 29 29 - (* 128 = 0x80 needs two bytes: 0x81 0x00 *) 30 30 - let encoded = Tcpcl.V3.encode_sdnv 128L in 31 31 - Alcotest.(check int) "length" 2 (String.length encoded); 32 32 - match Tcpcl.V3.decode_sdnv encoded 0 with 33 33 - | Ok (v, off) -> 34 34 - Alcotest.(check int64) "value" 128L v; 35 35 - Alcotest.(check int) "offset" 2 off 36 36 - | Error e -> Alcotest.failf "decode failed: %s" e 37 37 - 38 38 - let test_sdnv_large () = 39 39 - (* Test with a larger value that needs multiple bytes *) 40 40 - let n = 16384L in 41 41 - let encoded = Tcpcl.V3.encode_sdnv n in 42 42 - Alcotest.(check int) "length" 3 (String.length encoded); 43 43 - match Tcpcl.V3.decode_sdnv encoded 0 with 44 44 - | Ok (v, _) -> Alcotest.(check int64) "value" n v 45 45 - | Error e -> Alcotest.failf "decode failed: %s" e 46 46 - 47 47 - let test_sdnv_roundtrip () = 48 48 - let values = [ 0L; 1L; 127L; 128L; 255L; 256L; 16383L; 16384L; 1000000L ] in 49 49 - List.iter 50 50 - (fun n -> 51 51 - let encoded = Tcpcl.V3.encode_sdnv n in 52 52 - match Tcpcl.V3.decode_sdnv encoded 0 with 53 53 - | Ok (v, _) -> Alcotest.(check int64) (Int64.to_string n) n v 54 54 - | Error e -> Alcotest.failf "decode %Ld failed: %s" n e) 55 55 - values 56 56 - 57 57 - (* {1 Contact Header Tests} *) 58 58 - 59 59 - let test_contact_header_roundtrip () = 60 60 - let h = 61 61 - Tcpcl.V3. 62 62 - { 63 63 - flags = 64 64 - { 65 65 - request_ack = true; 66 66 - reactive_frag = false; 67 67 - allow_refusal = true; 68 68 - request_length = false; 69 69 - }; 70 70 - keepalive_interval = 30; 71 71 - eid = "dtn://node1.example/"; 72 72 - } 73 73 - in 74 74 - let encoded = Tcpcl.V3.encode_contact_header h in 75 75 - (* Check magic *) 76 76 - Alcotest.(check string) "magic" "dtn!" (String.sub encoded 0 4); 77 77 - (* Check version *) 78 78 - Alcotest.(check int) "version" 0x03 (Char.code encoded.[4]); 79 79 - match Tcpcl.V3.decode_contact_header encoded with 80 80 - | Ok decoded -> 81 81 - Alcotest.(check bool) "request_ack" true decoded.flags.request_ack; 82 82 - Alcotest.(check bool) "reactive_frag" false decoded.flags.reactive_frag; 83 83 - Alcotest.(check bool) "allow_refusal" true decoded.flags.allow_refusal; 84 84 - Alcotest.(check bool) "request_length" false decoded.flags.request_length; 85 85 - Alcotest.(check int) "keepalive" 30 decoded.keepalive_interval; 86 86 - Alcotest.(check string) "eid" "dtn://node1.example/" decoded.eid 87 87 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 88 88 - 89 89 - let test_contact_header_default () = 90 90 - let h = Tcpcl.V3.contact_header_default in 91 91 - let encoded = Tcpcl.V3.encode_contact_header h in 92 92 - match Tcpcl.V3.decode_contact_header encoded with 93 93 - | Ok decoded -> 94 94 - Alcotest.(check bool) "request_ack" false decoded.flags.request_ack; 95 95 - Alcotest.(check bool) "reactive_frag" false decoded.flags.reactive_frag; 96 96 - Alcotest.(check bool) "allow_refusal" false decoded.flags.allow_refusal; 97 97 - Alcotest.(check bool) "request_length" false decoded.flags.request_length; 98 98 - Alcotest.(check int) "keepalive" 0 decoded.keepalive_interval; 99 99 - Alcotest.(check string) "eid" "" decoded.eid 100 100 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 101 101 - 102 102 - let test_contact_header_all_flags () = 103 103 - let h = 104 104 - Tcpcl.V3. 105 105 - { 106 106 - flags = 107 107 - { 108 108 - request_ack = true; 109 109 - reactive_frag = true; 110 110 - allow_refusal = true; 111 111 - request_length = true; 112 112 - }; 113 113 - keepalive_interval = 65535; 114 114 - eid = "dtn://all-flags/"; 115 115 - } 116 116 - in 117 117 - let encoded = Tcpcl.V3.encode_contact_header h in 118 118 - match Tcpcl.V3.decode_contact_header encoded with 119 119 - | Ok decoded -> 120 120 - Alcotest.(check bool) "request_ack" true decoded.flags.request_ack; 121 121 - Alcotest.(check bool) "reactive_frag" true decoded.flags.reactive_frag; 122 122 - Alcotest.(check bool) "allow_refusal" true decoded.flags.allow_refusal; 123 123 - Alcotest.(check bool) "request_length" true decoded.flags.request_length; 124 124 - Alcotest.(check int) "keepalive" 65535 decoded.keepalive_interval; 125 125 - Alcotest.(check string) "eid" "dtn://all-flags/" decoded.eid 126 126 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 127 127 - 128 128 - let test_contact_header_invalid_magic () = 129 129 - let bad = "bad!\x03\x00\x00\x1e\x00" in 130 130 - match Tcpcl.V3.decode_contact_header bad with 131 131 - | Ok _ -> Alcotest.fail "should reject bad magic" 132 132 - | Error Tcpcl.Invalid_magic -> () 133 133 - | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 134 134 - 135 135 - let test_contact_header_invalid_version () = 136 136 - let bad = "dtn!\x04\x00\x00\x1e\x00" in 137 137 - match Tcpcl.V3.decode_contact_header bad with 138 138 - | Ok _ -> Alcotest.fail "should reject bad version" 139 139 - | Error (Tcpcl.Invalid_version 4) -> () 140 140 - | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 141 141 - 142 142 - let test_contact_header_long_eid () = 143 143 - let eid = String.make 300 'x' in 144 144 - let h = 145 145 - Tcpcl.V3.{ flags = contact_flags_default; keepalive_interval = 10; eid } 146 146 - in 147 147 - let encoded = Tcpcl.V3.encode_contact_header h in 148 148 - match Tcpcl.V3.decode_contact_header encoded with 149 149 - | Ok decoded -> 150 150 - Alcotest.(check int) "eid length" 300 (String.length decoded.eid); 151 151 - Alcotest.(check string) "eid" eid decoded.eid 152 152 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 153 153 - 154 154 - (* {1 Data Segment Tests} *) 155 155 - 156 156 - let test_data_segment_roundtrip () = 157 157 - let data = "Hello, DTN!" in 158 158 - let msg = 159 159 - Tcpcl.V3.Data_segment { flags = { seg_start = true; seg_end = true }; data } 160 160 - in 161 161 - let encoded = Tcpcl.V3.encode_message msg in 162 162 - match Tcpcl.V3.decode_message encoded with 163 163 - | Ok (Tcpcl.V3.Data_segment s, _) -> 164 164 - Alcotest.(check bool) "seg_start" true s.flags.seg_start; 165 165 - Alcotest.(check bool) "seg_end" true s.flags.seg_end; 166 166 - Alcotest.(check string) "data" data s.data 167 167 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 168 168 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 169 169 - 170 170 - let test_data_segment_start_only () = 171 171 - let msg = 172 172 - Tcpcl.V3.Data_segment 173 173 - { flags = { seg_start = true; seg_end = false }; data = "part1" } 174 174 - in 175 175 - let encoded = Tcpcl.V3.encode_message msg in 176 176 - match Tcpcl.V3.decode_message encoded with 177 177 - | Ok (Tcpcl.V3.Data_segment s, _) -> 178 178 - Alcotest.(check bool) "seg_start" true s.flags.seg_start; 179 179 - Alcotest.(check bool) "seg_end" false s.flags.seg_end; 180 180 - Alcotest.(check string) "data" "part1" s.data 181 181 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 182 182 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 183 183 - 184 184 - let test_data_segment_empty () = 185 185 - let msg = 186 186 - Tcpcl.V3.Data_segment 187 187 - { flags = { seg_start = true; seg_end = true }; data = "" } 188 188 - in 189 189 - let encoded = Tcpcl.V3.encode_message msg in 190 190 - match Tcpcl.V3.decode_message encoded with 191 191 - | Ok (Tcpcl.V3.Data_segment s, _) -> Alcotest.(check string) "data" "" s.data 192 192 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 193 193 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 194 194 - 195 195 - (* {1 Ack Segment Tests} *) 196 196 - 197 197 - let test_ack_segment_roundtrip () = 198 198 - let msg = 199 199 - Tcpcl.V3.Ack_segment 200 200 - { flags = { seg_start = true; seg_end = true }; length = 1024L } 201 201 - in 202 202 - let encoded = Tcpcl.V3.encode_message msg in 203 203 - match Tcpcl.V3.decode_message encoded with 204 204 - | Ok (Tcpcl.V3.Ack_segment a, _) -> 205 205 - Alcotest.(check bool) "seg_start" true a.flags.seg_start; 206 206 - Alcotest.(check bool) "seg_end" true a.flags.seg_end; 207 207 - Alcotest.(check int64) "length" 1024L a.length 208 208 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 209 209 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 210 210 - 211 211 - let test_ack_segment_zero () = 212 212 - let msg = 213 213 - Tcpcl.V3.Ack_segment 214 214 - { flags = { seg_start = false; seg_end = false }; length = 0L } 215 215 - in 216 216 - let encoded = Tcpcl.V3.encode_message msg in 217 217 - match Tcpcl.V3.decode_message encoded with 218 218 - | Ok (Tcpcl.V3.Ack_segment a, _) -> 219 219 - Alcotest.(check int64) "length" 0L a.length 220 220 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 221 221 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 222 222 - 223 223 - (* {1 Refuse Bundle Tests} *) 224 224 - 225 225 - let test_refuse_bundle_roundtrip () = 226 226 - let reasons = 227 227 - Tcpcl.V3. 228 228 - [ 229 229 - Refuse_unknown; Refuse_completed; Refuse_no_resources; Refuse_retransmit; 230 230 - ] 231 231 - in 232 232 - List.iter 233 233 - (fun reason -> 234 234 - let msg = Tcpcl.V3.Refuse_bundle reason in 235 235 - let encoded = Tcpcl.V3.encode_message msg in 236 236 - Alcotest.(check int) "length" 1 (String.length encoded); 237 237 - match Tcpcl.V3.decode_message encoded with 238 238 - | Ok (Tcpcl.V3.Refuse_bundle r, _) -> 239 239 - Alcotest.(check int) 240 240 - (Fmt.str "%a" Tcpcl.V3.pp_refuse_reason reason) 241 241 - (Tcpcl.V3.refuse_reason_to_int reason) 242 242 - (Tcpcl.V3.refuse_reason_to_int r) 243 243 - | Ok (msg, _) -> 244 244 - Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 245 245 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e) 246 246 - reasons 247 247 - 248 248 - (* {1 Keepalive Tests} *) 249 249 - 250 250 - let test_keepalive_roundtrip () = 251 251 - let msg = Tcpcl.V3.Keepalive in 252 252 - let encoded = Tcpcl.V3.encode_message msg in 253 253 - Alcotest.(check int) "length" 1 (String.length encoded); 254 254 - match Tcpcl.V3.decode_message encoded with 255 255 - | Ok (Tcpcl.V3.Keepalive, consumed) -> 256 256 - Alcotest.(check int) "consumed" 1 consumed 257 257 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 258 258 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 259 259 - 260 260 - (* {1 Shutdown Tests} *) 261 261 - 262 262 - let test_shutdown_no_fields () = 263 263 - let msg = Tcpcl.V3.Shutdown { reason = None; delay = None } in 264 264 - let encoded = Tcpcl.V3.encode_message msg in 265 265 - Alcotest.(check int) "length" 1 (String.length encoded); 266 266 - match Tcpcl.V3.decode_message encoded with 267 267 - | Ok (Tcpcl.V3.Shutdown s, _) -> 268 268 - Alcotest.(check bool) "reason" true (Option.is_none s.reason); 269 269 - Alcotest.(check bool) "delay" true (Option.is_none s.delay) 270 270 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 271 271 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 272 272 - 273 273 - let test_shutdown_reason_only () = 274 274 - let msg = 275 275 - Tcpcl.V3.Shutdown { reason = Some Tcpcl.V3.Version_mismatch; delay = None } 276 276 - in 277 277 - let encoded = Tcpcl.V3.encode_message msg in 278 278 - match Tcpcl.V3.decode_message encoded with 279 279 - | Ok (Tcpcl.V3.Shutdown s, _) -> 280 280 - (match s.reason with 281 281 - | Some Tcpcl.V3.Version_mismatch -> () 282 282 - | _ -> Alcotest.fail "wrong shutdown reason"); 283 283 - Alcotest.(check bool) "delay" true (Option.is_none s.delay) 284 284 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 285 285 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 286 286 - 287 287 - let test_shutdown_delay_only () = 288 288 - let msg = Tcpcl.V3.Shutdown { reason = None; delay = Some 300 } in 289 289 - let encoded = Tcpcl.V3.encode_message msg in 290 290 - match Tcpcl.V3.decode_message encoded with 291 291 - | Ok (Tcpcl.V3.Shutdown s, _) -> ( 292 292 - Alcotest.(check bool) "reason" true (Option.is_none s.reason); 293 293 - match s.delay with 294 294 - | Some 300 -> () 295 295 - | _ -> Alcotest.fail "wrong delay value") 296 296 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 297 297 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 298 298 - 299 299 - let test_shutdown_both () = 300 300 - let msg = 301 301 - Tcpcl.V3.Shutdown { reason = Some Tcpcl.V3.Busy; delay = Some 60 } 302 302 - in 303 303 - let encoded = Tcpcl.V3.encode_message msg in 304 304 - match Tcpcl.V3.decode_message encoded with 305 305 - | Ok (Tcpcl.V3.Shutdown s, _) -> ( 306 306 - (match s.reason with 307 307 - | Some Tcpcl.V3.Busy -> () 308 308 - | _ -> Alcotest.fail "wrong shutdown reason"); 309 309 - match s.delay with 310 310 - | Some 60 -> () 311 311 - | _ -> Alcotest.fail "wrong delay value") 312 312 - | Ok (msg, _) -> Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 313 313 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e 314 314 - 315 315 - let test_shutdown_all_reasons () = 316 316 - let reasons = Tcpcl.V3.[ Idle; Version_mismatch; Busy ] in 317 317 - List.iter 318 318 - (fun reason -> 319 319 - let msg = Tcpcl.V3.Shutdown { reason = Some reason; delay = None } in 320 320 - let encoded = Tcpcl.V3.encode_message msg in 321 321 - match Tcpcl.V3.decode_message encoded with 322 322 - | Ok (Tcpcl.V3.Shutdown s, _) -> ( 323 323 - match s.reason with 324 324 - | Some r -> 325 325 - Alcotest.(check int) 326 326 - (Fmt.str "%a" Tcpcl.V3.pp_shutdown_reason reason) 327 327 - (Tcpcl.V3.shutdown_reason_to_int reason) 328 328 - (Tcpcl.V3.shutdown_reason_to_int r) 329 329 - | None -> Alcotest.fail "missing reason") 330 330 - | Ok (msg, _) -> 331 331 - Alcotest.failf "wrong message: %a" Tcpcl.V3.pp_message msg 332 332 - | Error e -> Alcotest.failf "decode failed: %a" Tcpcl.pp_error e) 333 333 - reasons 334 334 - 335 335 - (* {1 Pretty-printer Tests} *) 336 336 - 337 337 - let contains s sub = 338 338 - let slen = String.length s in 339 339 - let sublen = String.length sub in 340 340 - if sublen > slen then false 341 341 - else 342 342 - let rec check i = 343 343 - if i > slen - sublen then false 344 344 - else if String.sub s i sublen = sub then true 345 345 - else check (i + 1) 346 346 - in 347 347 - check 0 348 348 - 349 349 - let test_pp_contact_header () = 350 350 - let h = 351 351 - Tcpcl.V3. 352 352 - { 353 353 - flags = 354 354 - { 355 355 - request_ack = true; 356 356 - reactive_frag = false; 357 357 - allow_refusal = false; 358 358 - request_length = false; 359 359 - }; 360 360 - keepalive_interval = 30; 361 361 - eid = "dtn://node1/"; 362 362 - } 363 363 - in 364 364 - let s = Fmt.str "%a" Tcpcl.V3.pp_contact_header h in 365 365 - Alcotest.(check bool) "contains TCPCLv3" true (contains s "TCPCLv3"); 366 366 - Alcotest.(check bool) "contains eid" true (contains s "dtn://node1/") 367 367 - 368 368 - let test_pp_message () = 369 369 - let msgs = 370 370 - Tcpcl.V3. 371 371 - [ 372 372 - Data_segment 373 373 - { flags = { seg_start = true; seg_end = true }; data = "x" }; 374 374 - Ack_segment 375 375 - { flags = { seg_start = true; seg_end = false }; length = 42L }; 376 376 - Refuse_bundle Refuse_completed; 377 377 - Keepalive; 378 378 - Shutdown { reason = Some Busy; delay = Some 10 }; 379 379 - ] 380 380 - in 381 381 - List.iter 382 382 - (fun msg -> 383 383 - let s = Fmt.str "%a" Tcpcl.V3.pp_message msg in 384 384 - Alcotest.(check bool) "non-empty pp output" true (String.length s > 0)) 385 385 - msgs 386 386 - 387 387 - (* {1 Error Handling Tests} *) 388 388 - 389 389 - let test_truncated_message () = 390 390 - match Tcpcl.V3.decode_message "" with 391 391 - | Ok _ -> Alcotest.fail "should fail on empty input" 392 392 - | Error (Tcpcl.Truncated _) -> () 393 393 - | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 394 394 - 395 395 - let test_invalid_message_type () = 396 396 - (* Type 0xF is not a valid v3 message type *) 397 397 - let bad = "\xF0" in 398 398 - match Tcpcl.V3.decode_message bad with 399 399 - | Ok _ -> Alcotest.fail "should reject invalid type" 400 400 - | Error (Tcpcl.Invalid_message_type _) -> () 401 401 - | Error e -> Alcotest.failf "wrong error: %a" Tcpcl.pp_error e 402 402 - 403 403 - (* {1 Test Suite} *) 404 404 - 405 405 - let suite = 406 406 - ( "tcpcl_v3", 407 407 - [ 408 408 - (* SDNV *) 409 409 - Alcotest.test_case "sdnv zero" `Quick test_sdnv_zero; 410 410 - Alcotest.test_case "sdnv small" `Quick test_sdnv_small; 411 411 - Alcotest.test_case "sdnv 128" `Quick test_sdnv_128; 412 412 - Alcotest.test_case "sdnv large" `Quick test_sdnv_large; 413 413 - Alcotest.test_case "sdnv roundtrip" `Quick test_sdnv_roundtrip; 414 414 - (* Contact header *) 415 415 - Alcotest.test_case "contact header roundtrip" `Quick 416 416 - test_contact_header_roundtrip; 417 417 - Alcotest.test_case "contact header default" `Quick 418 418 - test_contact_header_default; 419 419 - Alcotest.test_case "contact header all flags" `Quick 420 420 - test_contact_header_all_flags; 421 421 - Alcotest.test_case "contact header invalid magic" `Quick 422 422 - test_contact_header_invalid_magic; 423 423 - Alcotest.test_case "contact header invalid version" `Quick 424 424 - test_contact_header_invalid_version; 425 425 - Alcotest.test_case "contact header long EID" `Quick 426 426 - test_contact_header_long_eid; 427 427 - (* Data segment *) 428 428 - Alcotest.test_case "data segment roundtrip" `Quick 429 429 - test_data_segment_roundtrip; 430 430 - Alcotest.test_case "data segment start only" `Quick 431 431 - test_data_segment_start_only; 432 432 - Alcotest.test_case "data segment empty" `Quick test_data_segment_empty; 433 433 - (* Ack segment *) 434 434 - Alcotest.test_case "ack segment roundtrip" `Quick 435 435 - test_ack_segment_roundtrip; 436 436 - Alcotest.test_case "ack segment zero" `Quick test_ack_segment_zero; 437 437 - (* Refuse bundle *) 438 438 - Alcotest.test_case "refuse bundle roundtrip" `Quick 439 439 - test_refuse_bundle_roundtrip; 440 440 - (* Keepalive *) 441 441 - Alcotest.test_case "keepalive roundtrip" `Quick test_keepalive_roundtrip; 442 442 - (* Shutdown *) 443 443 - Alcotest.test_case "shutdown no fields" `Quick test_shutdown_no_fields; 444 444 - Alcotest.test_case "shutdown reason only" `Quick test_shutdown_reason_only; 445 445 - Alcotest.test_case "shutdown delay only" `Quick test_shutdown_delay_only; 446 446 - Alcotest.test_case "shutdown both" `Quick test_shutdown_both; 447 447 - Alcotest.test_case "shutdown all reasons" `Quick test_shutdown_all_reasons; 448 448 - (* Pretty-printers *) 449 449 - Alcotest.test_case "pp contact header" `Quick test_pp_contact_header; 450 450 - Alcotest.test_case "pp message" `Quick test_pp_message; 451 451 - (* Error handling *) 452 452 - Alcotest.test_case "truncated message" `Quick test_truncated_message; 453 453 - Alcotest.test_case "invalid message type" `Quick test_invalid_message_type; 454 454 - ] )

-3

ocaml-tcpcl/test/test_tcpcl_v3.mli

reviewed

··· 1 1 - (** Tests for TCPCL v3 (RFC 7242). *) 2 2 - 3 3 - val suite : string * unit Alcotest.test_case list