unikernel/duniverse/ocaml-base64/fuzz/fuzz_rfc4648.ml

@@ -0,0 +1,169 @@
+open Crowbar
+
+let pp_chr =
+  let escaped = function ' ' .. '~' as c -> String.make 1 c | _ -> "." in
+  Fmt.using escaped Fmt.string
+
+let pp_scalar :
+    type buffer.
+    get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t =
+ fun ~get ~length ppf b ->
+  let l = length b in
+  for i = 0 to l / 16 do
+    Fmt.pf ppf "%08x: " (i * 16) ;
+    let j = ref 0 in
+    while !j < 16 do
+      if (i * 16) + !j < l
+      then Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j))
+      else Fmt.pf ppf "  " ;
+      if !j mod 2 <> 0 then Fmt.pf ppf " " ;
+      incr j
+    done ;
+    Fmt.pf ppf "  " ;
+    j := 0 ;
+    while !j < 16 do
+      if (i * 16) + !j < l
+      then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j))
+      else Fmt.pf ppf " " ;
+      incr j
+    done ;
+    Fmt.pf ppf "@\n"
+  done
+
+let pp = pp_scalar ~get:String.get ~length:String.length
+
+let ( <.> ) f g x = f (g x)
+
+let char_from_alphabet alphabet : string gen =
+  map [ range 64 ] (String.make 1 <.> String.get (Base64.alphabet alphabet))
+
+let random_string_from_alphabet alphabet len : string gen =
+  let rec add_char_from_alphabet acc = function
+    | 0 -> acc
+    | n ->
+        add_char_from_alphabet
+          (concat_gen_list (const "") [ acc; char_from_alphabet alphabet ])
+          (n - 1) in
+  add_char_from_alphabet (const "") len
+
+let random_string_from_alphabet ~max alphabet =
+  dynamic_bind (range max) @@ fun real_len ->
+  dynamic_bind (random_string_from_alphabet alphabet real_len) @@ fun input ->
+  if real_len <= 1
+  then const (input, 0, real_len)
+  else
+    dynamic_bind (range (real_len / 2)) @@ fun off ->
+    map [ range (real_len - off) ] (fun len -> (input, off, len))
+
+let encode_and_decode (input, off, len) =
+  match Base64.encode ~pad:true ~off ~len input with
+  | Error (`Msg err) -> fail err
+  | Ok result ->
+  match Base64.decode ~pad:true result with
+  | Error (`Msg err) -> fail err
+  | Ok result ->
+      check_eq ~pp ~cmp:String.compare ~eq:String.equal result
+        (String.sub input off len)
+
+let decode_and_encode (input, off, len) =
+  match Base64.decode ~pad:true ~off ~len input with
+  | Error (`Msg err) -> fail err
+  | Ok result ->
+  match Base64.encode ~pad:true result with
+  | Error (`Msg err) -> fail err
+  | Ok result ->
+      check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result
+        (String.sub input off len)
+
+let ( // ) x y =
+  if y < 1 then raise Division_by_zero ;
+  if x > 0 then 1 + ((x - 1) / y) else 0
+  [@@inline]
+
+let canonic alphabet =
+  let dmap = Array.make 256 (-1) in
+  String.iteri (fun i x -> dmap.(Char.code x) <- i) (Base64.alphabet alphabet) ;
+  fun (input, off, len) ->
+    let real_len = String.length input in
+    let input_len = len in
+    let normalized_len = input_len // 4 * 4 in
+    if normalized_len = input_len
+    then (input, off, input_len)
+    else if normalized_len - input_len = 3
+    then (input, off, input_len - 1)
+    else
+      let remainder_len = normalized_len - input_len in
+      let last = input.[off + input_len - 1] in
+      let output = Bytes.make (max real_len (off + normalized_len)) '=' in
+
+      Bytes.blit_string input 0 output 0 (off + input_len) ;
+      if off + normalized_len < real_len
+      then
+        Bytes.blit_string input (off + normalized_len) output
+          (off + normalized_len)
+          (real_len - (off + normalized_len)) ;
+
+      let mask =
+        match remainder_len with 1 -> 0x3c | 2 -> 0x30 | _ -> assert false in
+      let decoded = dmap.(Char.code last) in
+      let canonic = decoded land mask in
+      let encoded = (Base64.alphabet alphabet).[canonic] in
+      Bytes.set output (off + input_len - 1) encoded ;
+      (Bytes.unsafe_to_string output, off, normalized_len)
+
+let isomorphism0 (input, off, len) =
+  (* x0 = decode(input) && x1 = decode(encode(x0)) && x0 = x1 *)
+  match Base64.decode ~pad:false ~off ~len input with
+  | Error (`Msg err) -> fail err
+  | Ok result0 -> (
+      let result1 = Base64.encode_exn result0 in
+      match Base64.decode ~pad:true result1 with
+      | Error (`Msg err) -> fail err
+      | Ok result2 ->
+          check_eq ~pp ~cmp:String.compare ~eq:String.equal result0 result2)
+
+let isomorphism1 (input, off, len) =
+  let result0 = Base64.encode_exn ~off ~len input in
+  match Base64.decode ~pad:true result0 with
+  | Error (`Msg err) -> fail err
+  | Ok result1 ->
+      let result2 = Base64.encode_exn result1 in
+      check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result0
+        result2
+
+let bytes_and_range : (string * int * int) gen =
+  dynamic_bind bytes @@ fun t ->
+  let real_length = String.length t in
+  if real_length <= 1
+  then const (t, 0, real_length)
+  else
+    dynamic_bind (range (real_length / 2)) @@ fun off ->
+    map [ range (real_length - off) ] (fun len -> (t, off, len))
+
+let range_of_max max : (int * int) gen =
+  dynamic_bind (range (max / 2)) @@ fun off ->
+  map [ range (max - off) ] (fun len -> (off, len))
+
+let failf fmt = Fmt.kstr fail fmt
+
+let no_exception pad off len input =
+  try
+    let _ =
+      Base64.decode ?pad ?off ?len ~alphabet:Base64.default_alphabet input in
+    ()
+  with exn -> failf "decode fails with: %s." (Printexc.to_string exn)
+
+let () =
+  add_test ~name:"rfc4648: encode -> decode" [ bytes_and_range ]
+    encode_and_decode ;
+  add_test ~name:"rfc4648: decode -> encode"
+    [ random_string_from_alphabet ~max:1000 Base64.default_alphabet ]
+    (decode_and_encode <.> canonic Base64.default_alphabet) ;
+  add_test ~name:"rfc4648: x = decode(encode(x))"
+    [ random_string_from_alphabet ~max:1000 Base64.default_alphabet ]
+    isomorphism0 ;
+  add_test ~name:"rfc4648: x = encode(decode(x))" [ bytes_and_range ]
+    isomorphism1 ;
+  add_test ~name:"rfc4648: no exception leak"
+    [ option bool; option int; option int; bytes ]
+    no_exception