unikernel/duniverse/ocaml-base64/fuzz/dune

@@ -0,0 +1,13 @@
+(executable
+ (name fuzz_rfc2045)
+ (enabled_if
+  (= %{profile} fuzz))
+ (modules fuzz_rfc2045)
+ (libraries astring crowbar fmt base64.rfc2045))
+
+(executable
+ (name fuzz_rfc4648)
+ (enabled_if
+  (= %{profile} fuzz))
+ (modules fuzz_rfc4648)
+ (libraries astring crowbar fmt base64))

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

@@ -0,0 +1,155 @@
+open Crowbar
+
+exception Encode_error of string
+
+exception Decode_error of string
+
+(** Pretty printers *)
+
+let register_printer () =
+  Printexc.register_printer (function
+    | Encode_error err -> Some (Fmt.str "(Encoding error: %s)" err)
+    | Decode_error err -> Some (Fmt.str "(Decoding error: %s)" err)
+    | _ -> None)
+
+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
+
+(** Encoding and decoding *)
+
+let check_encode str =
+  let subs = Astring.String.cuts ~sep:"\r\n" str in
+  let check str =
+    if String.length str > 78
+    then raise (Encode_error "too long string returned") in
+  List.iter check subs ;
+  str
+
+let encode input =
+  let buf = Buffer.create 80 in
+  let encoder = Base64_rfc2045.encoder (`Buffer buf) in
+  String.iter
+    (fun c ->
+      let ret = Base64_rfc2045.encode encoder (`Char c) in
+      match ret with `Ok -> () | _ -> assert false)
+    (* XXX(dinosaure): [`Partial] can never occur. *)
+    input ;
+  let encode = Base64_rfc2045.encode encoder `End in
+  match encode with
+  | `Ok -> Buffer.contents buf |> check_encode
+  | _ -> (* XXX(dinosaure): [`Partial] can never occur. *) assert false
+
+let decode input =
+  let decoder = Base64_rfc2045.decoder (`String input) in
+  let rec go acc =
+    if Base64_rfc2045.decoder_dangerous decoder
+    then raise (Decode_error "Dangerous input") ;
+    match Base64_rfc2045.decode decoder with
+    | `End -> List.rev acc
+    | `Flush output -> go (output :: acc)
+    | `Malformed _ -> raise (Decode_error "Malformed")
+    | `Wrong_padding -> raise (Decode_error "Wrong padding")
+    | _ -> (* XXX(dinosaure): [`Await] can never occur. *) assert false in
+  String.concat "" (go [])
+
+(** String generators *)
+
+let bytes_fixed_range : string gen = dynamic_bind (range 78) bytes_fixed
+
+let char_from_alpha alpha : string gen =
+  map [ range (String.length alpha) ] (fun i -> alpha.[i] |> String.make 1)
+
+let string_from_alpha n =
+  let acc = const "" in
+  let alpha = Base64_rfc2045.default_alphabet in
+  let rec add_char_from_alpha alpha acc = function
+    | 0 -> acc
+    | n ->
+        add_char_from_alpha alpha
+          (concat_gen_list (const "") [ acc; char_from_alpha alpha ])
+          (n - 1) in
+  add_char_from_alpha alpha acc n
+
+let random_string_from_alpha n = dynamic_bind (range n) string_from_alpha
+
+let bytes_fixed_range_from_alpha : string gen =
+  dynamic_bind (range 78) bytes_fixed
+
+let set_canonic str =
+  let l = String.length str in
+  let to_drop = l * 6 mod 8 in
+  if to_drop = 6
+     (* XXX(clecat): Case when we need to drop 6 bits which means a whole letter *)
+  then String.sub str 0 (l - 1)
+  else if to_drop <> 0
+          (* XXX(clecat): Case when we need to drop 2 or 4 bits: we apply a mask droping the bits *)
+  then (
+    let buf = Bytes.of_string str in
+    let value =
+      String.index Base64_rfc2045.default_alphabet (Bytes.get buf (l - 1)) in
+    let canonic =
+      Base64_rfc2045.default_alphabet.[value land lnot ((1 lsl to_drop) - 1)]
+    in
+    Bytes.set buf (l - 1) canonic ;
+    Bytes.unsafe_to_string buf)
+  else str
+
+let add_padding str =
+  let str = set_canonic str in
+  let str = str ^ "===" in
+  String.sub str 0 (String.length str / 4 * 4)
+
+(** Tests *)
+
+let e2d inputs =
+  let input = String.concat "\r\n" inputs in
+  let encode = encode input in
+  let decode = decode encode in
+  check_eq ~pp ~cmp:String.compare ~eq:String.equal input decode
+
+let d2e inputs end_input =
+  let end_input = add_padding end_input in
+  let inputs = inputs @ [ end_input ] in
+  let input =
+    List.fold_left
+      (fun acc s -> if String.length s <> 0 then acc ^ "\r\n" ^ s else acc)
+      (List.hd inputs) (List.tl inputs) in
+  let decode = decode input in
+  let encode = encode decode in
+  check_eq ~pp ~cmp:String.compare ~eq:String.equal input encode
+
+let () =
+  register_printer () ;
+  add_test ~name:"rfc2045: encode -> decode" [ list bytes_fixed_range ] e2d ;
+  add_test ~name:"rfc2045: decode -> encode"
+    [ list (string_from_alpha 76); random_string_from_alpha 76 ]
+    d2e

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