anil.recoil.org
The unpac monorepo manager self-hosting as a monorepo using unpac
Use ocamlformat 0.14.1
authored by
Thomas Gazagnaire
and committed by
+8
.ocamlformat
+8
.ocamlformat
+13
-18
bench/benchmarks.ml
+13
-18
bench/benchmarks.ml
···
15
let decode ?alphabet input =
16
let length = String.length input in
17
let input =
18
-
if length mod 4 = 0 then input
19
-
else input ^ String.make (4 - (length mod 4)) padding
20
-
in
21
let length = String.length input in
22
let words = length / 4 in
23
let padding =
···
25
| 0 -> 0
26
| _ when input.[length - 2] = padding -> 2
27
| _ when input.[length - 1] = padding -> 1
28
-
| _ -> 0
29
-
in
30
let output = Bytes.make ((words * 3) - padding) '\000' in
31
for i = 0 to words - 1 do
32
let a = of_char ?alphabet input.[(4 * i) + 0]
···
38
and y = (n lsr 8) land 255
39
and z = n land 255 in
40
Bytes.set output ((3 * i) + 0) (char_of_int x) ;
41
-
if i <> words - 1 || padding < 2 then
42
-
Bytes.set output ((3 * i) + 1) (char_of_int y) ;
43
-
if i <> words - 1 || padding < 1 then
44
-
Bytes.set output ((3 * i) + 2) (char_of_int z)
45
done ;
46
Bytes.unsafe_to_string output
47
···
71
for i = 1 to padding_len do
72
Bytes.set output (Bytes.length output - i) padding
73
done ;
74
-
if pad then Bytes.unsafe_to_string output
75
else Bytes.sub_string output 0 (Bytes.length output - padding_len)
76
end
77
···
101
102
let args = [ 0; 10; 50; 100; 500; 1000; 2500; 5000 ]
103
104
-
let test_b64 =
105
-
Test.create_indexed ~name:"Base64"
106
-
~args b64_encode_and_decode
107
108
-
let test_old =
109
-
Test.create_indexed ~name:"Old"
110
-
~args old_encode_and_decode
111
112
-
let command =
113
-
Bench.make_command [ test_b64; test_old ]
114
115
let () = Command.run command
···
15
let decode ?alphabet input =
16
let length = String.length input in
17
let input =
18
+
if length mod 4 = 0
19
+
then input
20
+
else input ^ String.make (4 - (length mod 4)) padding in
21
let length = String.length input in
22
let words = length / 4 in
23
let padding =
···
25
| 0 -> 0
26
| _ when input.[length - 2] = padding -> 2
27
| _ when input.[length - 1] = padding -> 1
28
+
| _ -> 0 in
29
let output = Bytes.make ((words * 3) - padding) '\000' in
30
for i = 0 to words - 1 do
31
let a = of_char ?alphabet input.[(4 * i) + 0]
···
37
and y = (n lsr 8) land 255
38
and z = n land 255 in
39
Bytes.set output ((3 * i) + 0) (char_of_int x) ;
40
+
if i <> words - 1 || padding < 2
41
+
then Bytes.set output ((3 * i) + 1) (char_of_int y) ;
42
+
if i <> words - 1 || padding < 1
43
+
then Bytes.set output ((3 * i) + 2) (char_of_int z)
44
done ;
45
Bytes.unsafe_to_string output
46
···
70
for i = 1 to padding_len do
71
Bytes.set output (Bytes.length output - i) padding
72
done ;
73
+
if pad
74
+
then Bytes.unsafe_to_string output
75
else Bytes.sub_string output 0 (Bytes.length output - padding_len)
76
end
77
···
101
102
let args = [ 0; 10; 50; 100; 500; 1000; 2500; 5000 ]
103
104
+
let test_b64 = Test.create_indexed ~name:"Base64" ~args b64_encode_and_decode
105
106
+
let test_old = Test.create_indexed ~name:"Old" ~args old_encode_and_decode
107
108
+
let command = Bench.make_command [ test_b64; test_old ]
109
110
let () = Command.run command
+31
-25
config/config.ml
+31
-25
config/config.ml
···
1
module Config = Configurator.V1
2
3
-
let pre407 = {ocaml|external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_string_set16u" [@@noalloc]|ocaml}
4
-
let standard = {ocaml|external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_bytes_set16u" [@@noalloc]|ocaml}
5
6
-
type t =
7
-
{ major : int
8
-
; minor : int
9
-
; patch : int option
10
-
; extra : string option }
11
12
-
let v ?patch ?extra major minor = { major; minor; patch; extra; }
13
14
let parse s =
15
-
try Scanf.sscanf s "%d.%d.%d+%s" (fun major minor patch extra -> v ~patch ~extra major minor)
16
-
with End_of_file | Scanf.Scan_failure _ ->
17
-
( try Scanf.sscanf s "%d.%d+%s" (fun major minor extra -> v ~extra major minor)
18
with End_of_file | Scanf.Scan_failure _ ->
19
-
( try Scanf.sscanf s "%d.%d.%d" (fun major minor patch -> v ~patch major minor)
20
-
with End_of_file | Scanf.Scan_failure _ ->
21
-
Scanf.sscanf s "%d.%d" (fun major minor -> v major minor) ) )
22
23
-
let ( >|= ) x f = match x with
24
-
| Some x -> Some (f x )
25
-
| None -> None
26
27
let ocaml_cp ~src ~dst =
28
let ic = open_in src in
29
let oc = open_out dst in
30
let bf = Bytes.create 0x1000 in
31
-
let rec go () = match input ic bf 0 (Bytes.length bf) with
32
| 0 -> ()
33
-
| len -> output oc bf 0 len ; go ()
34
| exception End_of_file -> () in
35
-
go () ; close_in ic ; close_out oc
36
-
;;
37
38
let () =
39
Config.main ~name:"config-base64" @@ fun t ->
40
match Config.ocaml_config_var t "version" >|= parse with
41
| Some version ->
42
-
let dst = "unsafe.ml" in
43
44
-
if (version.major, version.minor) >= (4, 7)
45
-
then ocaml_cp ~src:"unsafe_stable.ml" ~dst
46
-
else ocaml_cp ~src:"unsafe_pre407.ml" ~dst
47
| None -> Config.die "OCaml version is not available"
48
| exception exn -> Config.die "Got an exception: %s" (Printexc.to_string exn)
···
1
module Config = Configurator.V1
2
3
+
let pre407 =
4
+
{ocaml|external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_string_set16u" [@@noalloc]|ocaml}
5
6
+
let standard =
7
+
{ocaml|external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_bytes_set16u" [@@noalloc]|ocaml}
8
9
+
type t = { major : int; minor : int; patch : int option; extra : string option }
10
+
11
+
let v ?patch ?extra major minor = { major; minor; patch; extra }
12
13
let parse s =
14
+
try
15
+
Scanf.sscanf s "%d.%d.%d+%s" (fun major minor patch extra ->
16
+
v ~patch ~extra major minor)
17
+
with End_of_file | Scanf.Scan_failure _ -> (
18
+
try
19
+
Scanf.sscanf s "%d.%d+%s" (fun major minor extra -> v ~extra major minor)
20
+
with End_of_file | Scanf.Scan_failure _ -> (
21
+
try
22
+
Scanf.sscanf s "%d.%d.%d" (fun major minor patch ->
23
+
v ~patch major minor)
24
with End_of_file | Scanf.Scan_failure _ ->
25
+
Scanf.sscanf s "%d.%d" (fun major minor -> v major minor)))
26
27
+
let ( >|= ) x f = match x with Some x -> Some (f x) | None -> None
28
29
let ocaml_cp ~src ~dst =
30
let ic = open_in src in
31
let oc = open_out dst in
32
let bf = Bytes.create 0x1000 in
33
+
let rec go () =
34
+
match input ic bf 0 (Bytes.length bf) with
35
| 0 -> ()
36
+
| len ->
37
+
output oc bf 0 len ;
38
+
go ()
39
| exception End_of_file -> () in
40
+
go () ;
41
+
close_in ic ;
42
+
close_out oc
43
44
let () =
45
Config.main ~name:"config-base64" @@ fun t ->
46
match Config.ocaml_config_var t "version" >|= parse with
47
| Some version ->
48
+
let dst = "unsafe.ml" in
49
50
+
if (version.major, version.minor) >= (4, 7)
51
+
then ocaml_cp ~src:"unsafe_stable.ml" ~dst
52
+
else ocaml_cp ~src:"unsafe_pre407.ml" ~dst
53
| None -> Config.die "OCaml version is not available"
54
| exception exn -> Config.die "Got an exception: %s" (Printexc.to_string exn)
+29
-32
fuzz/fuzz_rfc2045.ml
+29
-32
fuzz/fuzz_rfc2045.ml
···
1
open Crowbar
2
3
exception Encode_error of string
4
exception Decode_error of string
5
6
(** Pretty printers *)
···
9
Printexc.register_printer (function
10
| Encode_error err -> Some (Fmt.strf "(Encoding error: %s)" err)
11
| Decode_error err -> Some (Fmt.strf "(Decoding error: %s)" err)
12
-
| _ -> None )
13
14
let pp_chr =
15
let escaped = function ' ' .. '~' as c -> String.make 1 c | _ -> "." in
16
Fmt.using escaped Fmt.string
17
18
-
let pp_scalar : type buffer.
19
get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t =
20
fun ~get ~length ppf b ->
21
let l = length b in
···
23
Fmt.pf ppf "%08x: " (i * 16) ;
24
let j = ref 0 in
25
while !j < 16 do
26
-
if (i * 16) + !j < l then
27
-
Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j))
28
else Fmt.pf ppf " " ;
29
if !j mod 2 <> 0 then Fmt.pf ppf " " ;
30
incr j
···
32
Fmt.pf ppf " " ;
33
j := 0 ;
34
while !j < 16 do
35
-
if (i * 16) + !j < l then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j))
36
else Fmt.pf ppf " " ;
37
incr j
38
done ;
···
46
let check_encode str =
47
let subs = Astring.String.cuts ~sep:"\r\n" str in
48
let check str =
49
-
if String.length str > 78 then
50
-
raise (Encode_error "too long string returned")
51
-
in
52
-
List.iter check subs ; str
53
54
let encode input =
55
let buf = Buffer.create 80 in
···
57
String.iter
58
(fun c ->
59
let ret = Base64_rfc2045.encode encoder (`Char c) in
60
-
match ret with `Ok -> () | _ -> assert false )
61
(* XXX(dinosaure): [`Partial] can never occur. *)
62
input ;
63
let encode = Base64_rfc2045.encode encoder `End in
···
68
let decode input =
69
let decoder = Base64_rfc2045.decoder (`String input) in
70
let rec go acc =
71
-
if Base64_rfc2045.decoder_dangerous decoder then
72
-
raise (Decode_error "Dangerous input") ;
73
match Base64_rfc2045.decode decoder with
74
| `End -> List.rev acc
75
| `Flush output -> go (output :: acc)
76
| `Malformed _ -> raise (Decode_error "Malformed")
77
| `Wrong_padding -> raise (Decode_error "Wrong padding")
78
-
| _ -> (* XXX(dinosaure): [`Await] can never occur. *) assert false
79
-
in
80
String.concat "" (go [])
81
82
(** String generators *)
···
84
let bytes_fixed_range : string gen = dynamic_bind (range 78) bytes_fixed
85
86
let char_from_alpha alpha : string gen =
87
-
map [range (String.length alpha)] (fun i -> alpha.[i] |> String.make 1)
88
89
let string_from_alpha n =
90
let acc = const "" in
···
93
| 0 -> acc
94
| n ->
95
add_char_from_alpha alpha
96
-
(concat_gen_list (const "") [acc; char_from_alpha alpha])
97
-
(n - 1)
98
-
in
99
add_char_from_alpha alpha acc n
100
101
let random_string_from_alpha n = dynamic_bind (range n) string_from_alpha
···
106
let set_canonic str =
107
let l = String.length str in
108
let to_drop = l * 6 mod 8 in
109
-
if
110
-
to_drop = 6
111
-
(* XXX(clecat): Case when we need to drop 6 bits which means a whole letter *)
112
then String.sub str 0 (l - 1)
113
-
else if
114
-
to_drop <> 0
115
-
(* XXX(clecat): Case when we need to drop 2 or 4 bits: we apply a mask droping the bits *)
116
then (
117
let buf = Bytes.of_string str in
118
let value =
119
-
String.index Base64_rfc2045.default_alphabet (Bytes.get buf (l - 1))
120
-
in
121
let canonic =
122
Base64_rfc2045.default_alphabet.[value land lnot ((1 lsl to_drop) - 1)]
123
in
124
Bytes.set buf (l - 1) canonic ;
125
-
Bytes.unsafe_to_string buf )
126
else str
127
128
let add_padding str =
···
140
141
let d2e inputs end_input =
142
let end_input = add_padding end_input in
143
-
let inputs = inputs @ [end_input] in
144
let input =
145
List.fold_left
146
(fun acc s -> if String.length s <> 0 then acc ^ "\r\n" ^ s else acc)
147
-
(List.hd inputs) (List.tl inputs)
148
-
in
149
let decode = decode input in
150
let encode = encode decode in
151
check_eq ~pp ~cmp:String.compare ~eq:String.equal input encode
152
153
let () =
154
register_printer () ;
155
-
add_test ~name:"rfc2045: encode -> decode" [list bytes_fixed_range] e2d ;
156
add_test ~name:"rfc2045: decode -> encode"
157
-
[list (string_from_alpha 76); random_string_from_alpha 76]
158
d2e
···
1
open Crowbar
2
3
exception Encode_error of string
4
+
5
exception Decode_error of string
6
7
(** Pretty printers *)
···
10
Printexc.register_printer (function
11
| Encode_error err -> Some (Fmt.strf "(Encoding error: %s)" err)
12
| Decode_error err -> Some (Fmt.strf "(Decoding error: %s)" err)
13
+
| _ -> None)
14
15
let pp_chr =
16
let escaped = function ' ' .. '~' as c -> String.make 1 c | _ -> "." in
17
Fmt.using escaped Fmt.string
18
19
+
let pp_scalar :
20
+
type buffer.
21
get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t =
22
fun ~get ~length ppf b ->
23
let l = length b in
···
25
Fmt.pf ppf "%08x: " (i * 16) ;
26
let j = ref 0 in
27
while !j < 16 do
28
+
if (i * 16) + !j < l
29
+
then Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j))
30
else Fmt.pf ppf " " ;
31
if !j mod 2 <> 0 then Fmt.pf ppf " " ;
32
incr j
···
34
Fmt.pf ppf " " ;
35
j := 0 ;
36
while !j < 16 do
37
+
if (i * 16) + !j < l
38
+
then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j))
39
else Fmt.pf ppf " " ;
40
incr j
41
done ;
···
49
let check_encode str =
50
let subs = Astring.String.cuts ~sep:"\r\n" str in
51
let check str =
52
+
if String.length str > 78
53
+
then raise (Encode_error "too long string returned") in
54
+
List.iter check subs ;
55
+
str
56
57
let encode input =
58
let buf = Buffer.create 80 in
···
60
String.iter
61
(fun c ->
62
let ret = Base64_rfc2045.encode encoder (`Char c) in
63
+
match ret with `Ok -> () | _ -> assert false)
64
(* XXX(dinosaure): [`Partial] can never occur. *)
65
input ;
66
let encode = Base64_rfc2045.encode encoder `End in
···
71
let decode input =
72
let decoder = Base64_rfc2045.decoder (`String input) in
73
let rec go acc =
74
+
if Base64_rfc2045.decoder_dangerous decoder
75
+
then raise (Decode_error "Dangerous input") ;
76
match Base64_rfc2045.decode decoder with
77
| `End -> List.rev acc
78
| `Flush output -> go (output :: acc)
79
| `Malformed _ -> raise (Decode_error "Malformed")
80
| `Wrong_padding -> raise (Decode_error "Wrong padding")
81
+
| _ -> (* XXX(dinosaure): [`Await] can never occur. *) assert false in
82
String.concat "" (go [])
83
84
(** String generators *)
···
86
let bytes_fixed_range : string gen = dynamic_bind (range 78) bytes_fixed
87
88
let char_from_alpha alpha : string gen =
89
+
map [ range (String.length alpha) ] (fun i -> alpha.[i] |> String.make 1)
90
91
let string_from_alpha n =
92
let acc = const "" in
···
95
| 0 -> acc
96
| n ->
97
add_char_from_alpha alpha
98
+
(concat_gen_list (const "") [ acc; char_from_alpha alpha ])
99
+
(n - 1) in
100
add_char_from_alpha alpha acc n
101
102
let random_string_from_alpha n = dynamic_bind (range n) string_from_alpha
···
107
let set_canonic str =
108
let l = String.length str in
109
let to_drop = l * 6 mod 8 in
110
+
if to_drop = 6
111
+
(* XXX(clecat): Case when we need to drop 6 bits which means a whole letter *)
112
then String.sub str 0 (l - 1)
113
+
else if to_drop <> 0
114
+
(* XXX(clecat): Case when we need to drop 2 or 4 bits: we apply a mask droping the bits *)
115
then (
116
let buf = Bytes.of_string str in
117
let value =
118
+
String.index Base64_rfc2045.default_alphabet (Bytes.get buf (l - 1)) in
119
let canonic =
120
Base64_rfc2045.default_alphabet.[value land lnot ((1 lsl to_drop) - 1)]
121
in
122
Bytes.set buf (l - 1) canonic ;
123
+
Bytes.unsafe_to_string buf)
124
else str
125
126
let add_padding str =
···
138
139
let d2e inputs end_input =
140
let end_input = add_padding end_input in
141
+
let inputs = inputs @ [ end_input ] in
142
let input =
143
List.fold_left
144
(fun acc s -> if String.length s <> 0 then acc ^ "\r\n" ^ s else acc)
145
+
(List.hd inputs) (List.tl inputs) in
146
let decode = decode input in
147
let encode = encode decode in
148
check_eq ~pp ~cmp:String.compare ~eq:String.equal input encode
149
150
let () =
151
register_printer () ;
152
+
add_test ~name:"rfc2045: encode -> decode" [ list bytes_fixed_range ] e2d ;
153
add_test ~name:"rfc2045: decode -> encode"
154
+
[ list (string_from_alpha 76); random_string_from_alpha 76 ]
155
d2e
+80
-65
fuzz/fuzz_rfc4648.ml
+80
-65
fuzz/fuzz_rfc4648.ml
···
4
let escaped = function ' ' .. '~' as c -> String.make 1 c | _ -> "." in
5
Fmt.using escaped Fmt.string
6
7
-
let pp_scalar : type buffer.
8
get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t =
9
fun ~get ~length ppf b ->
10
let l = length b in
···
12
Fmt.pf ppf "%08x: " (i * 16) ;
13
let j = ref 0 in
14
while !j < 16 do
15
-
if (i * 16) + !j < l then
16
-
Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j))
17
else Fmt.pf ppf " " ;
18
if !j mod 2 <> 0 then Fmt.pf ppf " " ;
19
incr j
···
21
Fmt.pf ppf " " ;
22
j := 0 ;
23
while !j < 16 do
24
-
if (i * 16) + !j < l then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j))
25
else Fmt.pf ppf " " ;
26
incr j
27
done ;
···
30
31
let pp = pp_scalar ~get:String.get ~length:String.length
32
33
-
let (<.>) f g x = f (g x)
34
35
let char_from_alphabet alphabet : string gen =
36
-
map [ range 64 ] (String.make 1 <.> Char.chr <.> Array.unsafe_get (Base64.alphabet alphabet))
37
38
let random_string_from_alphabet alphabet len : string gen =
39
let rec add_char_from_alphabet acc = function
40
-
| 0 -> acc
41
-
| n ->
42
-
add_char_from_alphabet
43
-
(concat_gen_list (const "") [ acc ; char_from_alphabet alphabet ])
44
-
(n - 1) in
45
add_char_from_alphabet (const "") len
46
47
let random_string_from_alphabet ~max alphabet =
48
-
dynamic_bind (range max)
49
-
@@ fun real_len ->
50
-
dynamic_bind (random_string_from_alphabet alphabet real_len)
51
-
@@ fun input ->
52
-
if real_len <= 1 then const (input, 0, real_len)
53
-
else dynamic_bind (range (real_len / 2))
54
-
@@ fun off -> map [ range (real_len - off) ] (fun len -> (input, off, len))
55
56
let encode_and_decode (input, off, len) =
57
match Base64.encode ~pad:true ~off ~len input with
58
| Error (`Msg err) -> fail err
59
| Ok result ->
60
-
match Base64.decode ~pad:true result with
61
-
| Error (`Msg err) -> fail err
62
-
| Ok result ->
63
-
check_eq ~pp ~cmp:String.compare ~eq:String.equal result (String.sub input off len)
64
65
let decode_and_encode (input, off, len) =
66
match Base64.decode ~pad:true ~off ~len input with
67
-
| Error (`Msg err) ->
68
-
fail err
69
| Ok result ->
70
-
match Base64.encode ~pad:true result with
71
-
| Error (`Msg err) -> fail err
72
-
| Ok result ->
73
-
check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result (String.sub input off len)
74
75
-
let (//) x y =
76
if y < 1 then raise Division_by_zero ;
77
if x > 0 then 1 + ((x - 1) / y) else 0
78
-
[@@inline]
79
80
let canonic alphabet =
81
let dmap = Array.make 256 (-1) in
82
-
Array.iteri (fun i x -> Array.set dmap x i) (Base64.alphabet alphabet) ;
83
fun (input, off, len) ->
84
let real_len = String.length input in
85
let input_len = len in
86
-
let normalized_len = (input_len // 4) * 4 in
87
-
if normalized_len = input_len then (input, off, input_len)
88
-
else if normalized_len - input_len = 3 then (input, off, input_len - 1)
89
-
else begin
90
let remainder_len = normalized_len - input_len in
91
-
let last = String.get input (off + input_len - 1) in
92
let output = Bytes.make (max real_len (off + normalized_len)) '=' in
93
94
-
Bytes.blit_string input 0 output 0 (off + input_len);
95
if off + normalized_len < real_len
96
-
then Bytes.blit_string input (off + normalized_len) output (off + normalized_len) (real_len - (off + normalized_len)) ;
97
98
-
let mask = match remainder_len with
99
-
| 1 -> 0x3c
100
-
| 2 -> 0x30
101
-
| _ -> assert false in
102
-
let decoded = Array.get dmap (Char.code last) in
103
-
let canonic = (decoded land mask) in
104
-
let encoded = Array.get (Base64.alphabet alphabet) canonic in
105
Bytes.set output (off + input_len - 1) (Char.chr encoded) ;
106
(Bytes.unsafe_to_string output, off, normalized_len)
107
-
end
108
109
let isomorphism0 (input, off, len) =
110
(* x0 = decode(input) && x1 = decode(encode(x0)) && x0 = x1 *)
111
match Base64.decode ~pad:false ~off ~len input with
112
-
| Error (`Msg err) ->
113
-
fail err
114
-
| Ok result0 ->
115
let result1 = Base64.encode_exn result0 in
116
match Base64.decode ~pad:true result1 with
117
-
| Error (`Msg err) ->
118
-
fail err
119
| Ok result2 ->
120
-
check_eq ~pp ~cmp:String.compare ~eq:String.equal result0 result2
121
122
let isomorphism1 (input, off, len) =
123
let result0 = Base64.encode_exn ~off ~len input in
···
125
| Error (`Msg err) -> fail err
126
| Ok result1 ->
127
let result2 = Base64.encode_exn result1 in
128
-
check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result0 result2
129
130
let bytes_and_range : (string * int * int) gen =
131
-
dynamic_bind bytes
132
-
@@ fun t ->
133
let real_length = String.length t in
134
if real_length <= 1
135
then const (t, 0, real_length)
136
-
else dynamic_bind (range (real_length / 2))
137
-
@@ fun off ->
138
map [ range (real_length - off) ] (fun len -> (t, off, len))
139
140
let range_of_max max : (int * int) gen =
141
-
dynamic_bind (range (max / 2))
142
-
@@ fun off -> map [ range (max - off) ] (fun len -> (off, len))
143
144
let failf fmt = Fmt.kstrf fail fmt
145
146
let no_exception pad off len input =
147
-
try let _ = Base64.decode ?pad ?off ?len ~alphabet:Base64.default_alphabet input in ()
148
with exn -> failf "decode fails with: %s." (Printexc.to_string exn)
149
150
let () =
151
-
add_test ~name:"rfc4648: encode -> decode" [ bytes_and_range ] encode_and_decode ;
152
-
add_test ~name:"rfc4648: decode -> encode" [ random_string_from_alphabet ~max:1000 Base64.default_alphabet ] (decode_and_encode <.> canonic Base64.default_alphabet) ;
153
-
add_test ~name:"rfc4648: x = decode(encode(x))" [ random_string_from_alphabet ~max:1000 Base64.default_alphabet ] isomorphism0 ;
154
-
add_test ~name:"rfc4648: x = encode(decode(x))" [ bytes_and_range ] isomorphism1 ;
155
-
add_test ~name:"rfc4648: no exception leak" [ option bool; option int; option int; bytes ] no_exception
···
4
let escaped = function ' ' .. '~' as c -> String.make 1 c | _ -> "." in
5
Fmt.using escaped Fmt.string
6
7
+
let pp_scalar :
8
+
type buffer.
9
get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t =
10
fun ~get ~length ppf b ->
11
let l = length b in
···
13
Fmt.pf ppf "%08x: " (i * 16) ;
14
let j = ref 0 in
15
while !j < 16 do
16
+
if (i * 16) + !j < l
17
+
then Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j))
18
else Fmt.pf ppf " " ;
19
if !j mod 2 <> 0 then Fmt.pf ppf " " ;
20
incr j
···
22
Fmt.pf ppf " " ;
23
j := 0 ;
24
while !j < 16 do
25
+
if (i * 16) + !j < l
26
+
then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j))
27
else Fmt.pf ppf " " ;
28
incr j
29
done ;
···
32
33
let pp = pp_scalar ~get:String.get ~length:String.length
34
35
+
let ( <.> ) f g x = f (g x)
36
37
let char_from_alphabet alphabet : string gen =
38
+
map [ range 64 ]
39
+
(String.make 1 <.> Char.chr <.> Array.unsafe_get (Base64.alphabet alphabet))
40
41
let random_string_from_alphabet alphabet len : string gen =
42
let rec add_char_from_alphabet acc = function
43
+
| 0 -> acc
44
+
| n ->
45
+
add_char_from_alphabet
46
+
(concat_gen_list (const "") [ acc; char_from_alphabet alphabet ])
47
+
(n - 1) in
48
add_char_from_alphabet (const "") len
49
50
let random_string_from_alphabet ~max alphabet =
51
+
dynamic_bind (range max) @@ fun real_len ->
52
+
dynamic_bind (random_string_from_alphabet alphabet real_len) @@ fun input ->
53
+
if real_len <= 1
54
+
then const (input, 0, real_len)
55
+
else
56
+
dynamic_bind (range (real_len / 2)) @@ fun off ->
57
+
map [ range (real_len - off) ] (fun len -> (input, off, len))
58
59
let encode_and_decode (input, off, len) =
60
match Base64.encode ~pad:true ~off ~len input with
61
| Error (`Msg err) -> fail err
62
| Ok result ->
63
+
match Base64.decode ~pad:true result with
64
+
| Error (`Msg err) -> fail err
65
+
| Ok result ->
66
+
check_eq ~pp ~cmp:String.compare ~eq:String.equal result
67
+
(String.sub input off len)
68
69
let decode_and_encode (input, off, len) =
70
match Base64.decode ~pad:true ~off ~len input with
71
+
| Error (`Msg err) -> fail err
72
| Ok result ->
73
+
match Base64.encode ~pad:true result with
74
+
| Error (`Msg err) -> fail err
75
+
| Ok result ->
76
+
check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result
77
+
(String.sub input off len)
78
79
+
let ( // ) x y =
80
if y < 1 then raise Division_by_zero ;
81
if x > 0 then 1 + ((x - 1) / y) else 0
82
+
[@@inline]
83
84
let canonic alphabet =
85
let dmap = Array.make 256 (-1) in
86
+
Array.iteri (fun i x -> dmap.(x) <- i) (Base64.alphabet alphabet) ;
87
fun (input, off, len) ->
88
let real_len = String.length input in
89
let input_len = len in
90
+
let normalized_len = input_len // 4 * 4 in
91
+
if normalized_len = input_len
92
+
then (input, off, input_len)
93
+
else if normalized_len - input_len = 3
94
+
then (input, off, input_len - 1)
95
+
else
96
let remainder_len = normalized_len - input_len in
97
+
let last = input.[off + input_len - 1] in
98
let output = Bytes.make (max real_len (off + normalized_len)) '=' in
99
100
+
Bytes.blit_string input 0 output 0 (off + input_len) ;
101
if off + normalized_len < real_len
102
+
then
103
+
Bytes.blit_string input (off + normalized_len) output
104
+
(off + normalized_len)
105
+
(real_len - (off + normalized_len)) ;
106
107
+
let mask =
108
+
match remainder_len with 1 -> 0x3c | 2 -> 0x30 | _ -> assert false in
109
+
let decoded = dmap.(Char.code last) in
110
+
let canonic = decoded land mask in
111
+
let encoded = (Base64.alphabet alphabet).(canonic) in
112
Bytes.set output (off + input_len - 1) (Char.chr encoded) ;
113
(Bytes.unsafe_to_string output, off, normalized_len)
114
115
let isomorphism0 (input, off, len) =
116
(* x0 = decode(input) && x1 = decode(encode(x0)) && x0 = x1 *)
117
match Base64.decode ~pad:false ~off ~len input with
118
+
| Error (`Msg err) -> fail err
119
+
| Ok result0 -> (
120
let result1 = Base64.encode_exn result0 in
121
match Base64.decode ~pad:true result1 with
122
+
| Error (`Msg err) -> fail err
123
| Ok result2 ->
124
+
check_eq ~pp ~cmp:String.compare ~eq:String.equal result0 result2)
125
126
let isomorphism1 (input, off, len) =
127
let result0 = Base64.encode_exn ~off ~len input in
···
129
| Error (`Msg err) -> fail err
130
| Ok result1 ->
131
let result2 = Base64.encode_exn result1 in
132
+
check_eq ~pp:Fmt.string ~cmp:String.compare ~eq:String.equal result0
133
+
result2
134
135
let bytes_and_range : (string * int * int) gen =
136
+
dynamic_bind bytes @@ fun t ->
137
let real_length = String.length t in
138
if real_length <= 1
139
then const (t, 0, real_length)
140
+
else
141
+
dynamic_bind (range (real_length / 2)) @@ fun off ->
142
map [ range (real_length - off) ] (fun len -> (t, off, len))
143
144
let range_of_max max : (int * int) gen =
145
+
dynamic_bind (range (max / 2)) @@ fun off ->
146
+
map [ range (max - off) ] (fun len -> (off, len))
147
148
let failf fmt = Fmt.kstrf fail fmt
149
150
let no_exception pad off len input =
151
+
try
152
+
let _ =
153
+
Base64.decode ?pad ?off ?len ~alphabet:Base64.default_alphabet input in
154
+
()
155
with exn -> failf "decode fails with: %s." (Printexc.to_string exn)
156
157
let () =
158
+
add_test ~name:"rfc4648: encode -> decode" [ bytes_and_range ]
159
+
encode_and_decode ;
160
+
add_test ~name:"rfc4648: decode -> encode"
161
+
[ random_string_from_alphabet ~max:1000 Base64.default_alphabet ]
162
+
(decode_and_encode <.> canonic Base64.default_alphabet) ;
163
+
add_test ~name:"rfc4648: x = decode(encode(x))"
164
+
[ random_string_from_alphabet ~max:1000 Base64.default_alphabet ]
165
+
isomorphism0 ;
166
+
add_test ~name:"rfc4648: x = encode(decode(x))" [ bytes_and_range ]
167
+
isomorphism1 ;
168
+
add_test ~name:"rfc4648: no exception leak"
169
+
[ option bool; option int; option int; bytes ]
170
+
no_exception
+182
-155
src/base64.ml
+182
-155
src/base64.ml
···
19
*
20
*)
21
22
-
type alphabet =
23
-
{ emap : int array
24
-
; dmap : int array }
25
26
type sub = string * int * int
27
28
-
let (//) x y =
29
if y < 1 then raise Division_by_zero ;
30
if x > 0 then 1 + ((x - 1) / y) else 0
31
-
[@@inline]
32
33
let unsafe_get_uint8 t off = Char.code (String.unsafe_get t off)
34
let unsafe_set_uint8 t off v = Bytes.unsafe_set t off (Char.chr v)
35
let unsafe_set_uint16 = Unsafe.unsafe_set_uint16
36
37
-
external unsafe_get_uint16 : string -> int -> int = "%caml_string_get16u" [@@noalloc]
38
external swap16 : int -> int = "%bswap16" [@@noalloc]
39
40
-
let none = (-1)
41
42
(* We mostly want to have an optional array for [dmap] (e.g. [int option
43
array]). So we consider the [none] value as [-1]. *)
44
45
let make_alphabet alphabet =
46
-
if String.length alphabet <> 64 then invalid_arg "Length of alphabet must be 64" ;
47
-
if String.contains alphabet '=' then invalid_arg "Alphabet can not contain padding character" ;
48
-
let emap = Array.init (String.length alphabet) (fun i -> Char.code (String.get alphabet i)) in
49
let dmap = Array.make 256 none in
50
-
String.iteri (fun idx chr -> Array.set dmap (Char.code chr) idx) alphabet ;
51
-
{ emap; dmap; }
52
53
let length_alphabet { emap; _ } = Array.length emap
54
let alphabet { emap; _ } = emap
55
56
-
let default_alphabet = make_alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
57
-
let uri_safe_alphabet = make_alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
58
59
let unsafe_set_be_uint16 =
60
if Sys.big_endian
···
65
can raise and avoid appearance of unknown exceptions like an ex-nihilo
66
magic rabbit (or magic money?). *)
67
exception Out_of_bounds
68
exception Too_much_input
69
70
let get_uint8 t off =
···
76
let error_msgf fmt = Format.ksprintf (fun err -> Error (`Msg err)) fmt
77
78
let encode_sub pad { emap; _ } ?(off = 0) ?len input =
79
-
let len = match len with
80
-
| Some len -> len
81
-
| None -> String.length input - off in
82
83
if len < 0 || off < 0 || off > String.length input - len
84
then error_msgf "Invalid bounds"
85
else
86
-
let n = len in
87
-
let n' = n // 3 * 4 in
88
-
let res = Bytes.create n' in
89
90
-
let emap i = Array.unsafe_get emap i in
91
92
-
let emit b1 b2 b3 i =
93
-
unsafe_set_be_uint16 res i
94
-
((emap (b1 lsr 2 land 0x3f) lsl 8)
95
-
lor (emap ((b1 lsl 4) lor (b2 lsr 4) land 0x3f))) ;
96
-
unsafe_set_be_uint16 res (i + 2)
97
-
((emap ((b2 lsl 2) lor (b3 lsr 6) land 0x3f) lsl 8)
98
-
lor (emap (b3 land 0x3f))) in
99
100
-
let rec enc j i =
101
-
if i = n then ()
102
-
else if i = n - 1
103
-
then emit (unsafe_get_uint8 input (off + i)) 0 0 j
104
-
else if i = n - 2
105
-
then emit (unsafe_get_uint8 input (off + i)) (unsafe_get_uint8 input (off + i + 1)) 0 j
106
-
else
107
-
(emit
108
-
(unsafe_get_uint8 input (off + i))
109
-
(unsafe_get_uint8 input (off + i + 1))
110
-
(unsafe_get_uint8 input (off + i + 2))
111
-
j ;
112
-
enc (j + 4) (i + 3)) in
113
114
-
let rec unsafe_fix = function
115
-
| 0 -> ()
116
-
| i -> unsafe_set_uint8 res (n' - i) padding ; unsafe_fix (i - 1) in
117
118
-
enc 0 0 ;
119
120
-
let pad_to_write = ((3 - n mod 3) mod 3) in
121
122
-
if pad
123
-
then begin unsafe_fix pad_to_write ; Ok (Bytes.unsafe_to_string res, 0, n') end
124
-
else Ok (Bytes.unsafe_to_string res, 0, (n' - pad_to_write))
125
(* [pad = false], we don't want to write them. *)
126
127
let encode ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input =
···
143
| Error (`Msg err) -> invalid_arg err
144
145
let decode_sub ?(pad = true) { dmap; _ } ?(off = 0) ?len input =
146
-
let len = match len with
147
-
| Some len -> len
148
-
| None -> String.length input - off in
149
150
if len < 0 || off < 0 || off > String.length input - len
151
then error_msgf "Invalid bounds"
152
else
153
154
-
let n = (len // 4) * 4 in
155
-
let n' = (n // 4) * 3 in
156
-
let res = Bytes.create n' in
157
-
let invalid_pad_overflow = pad in
158
159
-
let get_uint8_or_padding =
160
-
if pad then (fun t i -> if i >= len then raise Out_of_bounds ; get_uint8 t (off + i) )
161
-
else (fun t i -> try if i < len then get_uint8 t (off + i) else padding with Out_of_bounds -> padding ) in
162
163
-
let set_be_uint16 t off v =
164
-
(* can not write 2 bytes. *)
165
-
if off < 0 || off + 1 > Bytes.length t then ()
166
-
(* can not write 1 byte but can write 1 byte *)
167
-
else if off < 0 || off + 2 > Bytes.length t then unsafe_set_uint8 t off (v lsr 8)
168
-
(* can write 2 bytes. *)
169
-
else unsafe_set_be_uint16 t off v in
170
171
-
let set_uint8 t off v =
172
-
if off < 0 || off >= Bytes.length t then ()
173
-
else unsafe_set_uint8 t off v in
174
175
-
let emit a b c d j =
176
-
let x = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in
177
-
set_be_uint16 res j (x lsr 8) ;
178
-
set_uint8 res (j + 2) (x land 0xff) in
179
180
-
let dmap i =
181
-
let x = Array.unsafe_get dmap i in
182
-
if x = none then raise Not_found ; x in
183
-
184
-
let only_padding pad idx =
185
-
186
-
(* because we round length of [res] to the upper bound of how many
187
-
characters we should have from [input], we got at this stage only padding
188
-
characters and we need to delete them, so for each [====], we delete 3
189
-
bytes. *)
190
-
191
-
let pad = ref (pad + 3) in
192
-
let idx = ref idx in
193
194
-
while !idx + 4 < len do
195
-
(* use [unsafe_get_uint16] instead [unsafe_get_uint32] to avoid allocation
196
-
of [int32]. Of course, [3d3d3d3d] is [====]. *)
197
-
if unsafe_get_uint16 input (off + !idx) <> 0x3d3d
198
-
|| unsafe_get_uint16 input (off + !idx + 2) <> 0x3d3d
199
-
then raise Not_found ;
200
-
(* We got something bad, should be a valid character according to
201
-
[alphabet] but outside the scope. *)
202
203
-
idx := !idx + 4 ;
204
-
pad := !pad + 3 ;
205
-
done ;
206
-
while !idx < len do
207
-
if unsafe_get_uint8 input (off + !idx) <> padding
208
-
then raise Not_found ;
209
210
-
incr idx ;
211
-
done ; !pad in
212
213
-
let rec dec j i =
214
-
if i = n then 0
215
-
else begin
216
-
let (d, pad) =
217
-
let x = get_uint8_or_padding input (i + 3) in
218
-
try (dmap x, 0) with Not_found when x = padding -> (0, 1) in
219
-
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
220
-
let (c, pad) =
221
-
let x = get_uint8_or_padding input (i + 2) in
222
-
try (dmap x, pad) with Not_found when x = padding && pad = 1 -> (0, 2) in
223
-
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
224
-
let (b, pad) =
225
-
let x = get_uint8_or_padding input (i + 1) in
226
-
try (dmap x, pad) with Not_found when x = padding && pad = 2 -> (0, 3) in
227
-
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
228
-
let (a, pad) =
229
-
let x = get_uint8_or_padding input i in
230
-
try (dmap x, pad) with Not_found when x = padding && pad = 3 -> (0, 4) in
231
-
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
232
233
-
emit a b c d j ;
234
235
-
if i + 4 = n
236
-
(* end of input in anyway *)
237
-
then match pad with
238
-
| 0 ->
239
-
0
240
-
| 4 ->
241
-
(* assert (invalid_pad_overflow = false) ; *)
242
-
3
243
-
(* [get_uint8] lies and if we get [4], that mean we got one or more (at
244
-
most 4) padding character. In this situation, because we round length
245
-
of [res] (see [n // 4]), we need to delete 3 bytes. *)
246
-
| pad ->
247
-
pad
248
-
else match pad with
249
-
| 0 -> dec (j + 3) (i + 4)
250
-
| 4 ->
251
-
(* assert (invalid_pad_overflow = false) ; *)
252
-
only_padding 3 (i + 4)
253
-
(* Same situation than above but we should get only more padding
254
-
characters then. *)
255
-
| pad ->
256
-
if invalid_pad_overflow = true then raise Too_much_input ;
257
-
only_padding pad (i + 4) end in
258
259
-
match dec 0 0 with
260
-
| 0 -> Ok (Bytes.unsafe_to_string res, 0, n')
261
-
| pad -> Ok (Bytes.unsafe_to_string res, 0, (n' - pad))
262
-
| exception Out_of_bounds -> error_msgf "Wrong padding"
263
-
(* appear only when [pad = true] and when length of input is not a multiple of 4. *)
264
-
| exception Not_found ->
265
-
(* appear when one character of [input] ∉ [alphabet] and this character <> '=' *)
266
-
error_msgf "Malformed input"
267
-
| exception Too_much_input ->
268
-
error_msgf "Too much input"
269
270
let decode ?pad ?(alphabet = default_alphabet) ?off ?len input =
271
match decode_sub ?pad alphabet ?off ?len input with
···
19
*
20
*)
21
22
+
type alphabet = { emap : int array; dmap : int array }
23
24
type sub = string * int * int
25
26
+
let ( // ) x y =
27
if y < 1 then raise Division_by_zero ;
28
if x > 0 then 1 + ((x - 1) / y) else 0
29
+
[@@inline]
30
31
let unsafe_get_uint8 t off = Char.code (String.unsafe_get t off)
32
+
33
let unsafe_set_uint8 t off v = Bytes.unsafe_set t off (Char.chr v)
34
+
35
let unsafe_set_uint16 = Unsafe.unsafe_set_uint16
36
37
+
external unsafe_get_uint16 : string -> int -> int = "%caml_string_get16u"
38
+
[@@noalloc]
39
+
40
external swap16 : int -> int = "%bswap16" [@@noalloc]
41
42
+
let none = -1
43
44
(* We mostly want to have an optional array for [dmap] (e.g. [int option
45
array]). So we consider the [none] value as [-1]. *)
46
47
let make_alphabet alphabet =
48
+
if String.length alphabet <> 64
49
+
then invalid_arg "Length of alphabet must be 64" ;
50
+
if String.contains alphabet '='
51
+
then invalid_arg "Alphabet can not contain padding character" ;
52
+
let emap =
53
+
Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i]) in
54
let dmap = Array.make 256 none in
55
+
String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet ;
56
+
{ emap; dmap }
57
58
let length_alphabet { emap; _ } = Array.length emap
59
+
60
let alphabet { emap; _ } = emap
61
62
+
let default_alphabet =
63
+
make_alphabet
64
+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
65
+
66
+
let uri_safe_alphabet =
67
+
make_alphabet
68
+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
69
70
let unsafe_set_be_uint16 =
71
if Sys.big_endian
···
76
can raise and avoid appearance of unknown exceptions like an ex-nihilo
77
magic rabbit (or magic money?). *)
78
exception Out_of_bounds
79
+
80
exception Too_much_input
81
82
let get_uint8 t off =
···
88
let error_msgf fmt = Format.ksprintf (fun err -> Error (`Msg err)) fmt
89
90
let encode_sub pad { emap; _ } ?(off = 0) ?len input =
91
+
let len =
92
+
match len with Some len -> len | None -> String.length input - off in
93
94
if len < 0 || off < 0 || off > String.length input - len
95
then error_msgf "Invalid bounds"
96
else
97
+
let n = len in
98
+
let n' = n // 3 * 4 in
99
+
let res = Bytes.create n' in
100
101
+
let emap i = Array.unsafe_get emap i in
102
103
+
let emit b1 b2 b3 i =
104
+
unsafe_set_be_uint16 res i
105
+
((emap ((b1 lsr 2) land 0x3f) lsl 8)
106
+
lor emap ((b1 lsl 4) lor (b2 lsr 4) land 0x3f)) ;
107
+
unsafe_set_be_uint16 res (i + 2)
108
+
((emap ((b2 lsl 2) lor (b3 lsr 6) land 0x3f) lsl 8)
109
+
lor emap (b3 land 0x3f)) in
110
+
111
+
let rec enc j i =
112
+
if i = n
113
+
then ()
114
+
else if i = n - 1
115
+
then emit (unsafe_get_uint8 input (off + i)) 0 0 j
116
+
else if i = n - 2
117
+
then
118
+
emit
119
+
(unsafe_get_uint8 input (off + i))
120
+
(unsafe_get_uint8 input (off + i + 1))
121
+
0 j
122
+
else (
123
+
emit
124
+
(unsafe_get_uint8 input (off + i))
125
+
(unsafe_get_uint8 input (off + i + 1))
126
+
(unsafe_get_uint8 input (off + i + 2))
127
+
j ;
128
+
enc (j + 4) (i + 3)) in
129
130
+
let rec unsafe_fix = function
131
+
| 0 -> ()
132
+
| i ->
133
+
unsafe_set_uint8 res (n' - i) padding ;
134
+
unsafe_fix (i - 1) in
135
136
+
enc 0 0 ;
137
138
+
let pad_to_write = (3 - (n mod 3)) mod 3 in
139
140
+
if pad
141
+
then (
142
+
unsafe_fix pad_to_write ;
143
+
Ok (Bytes.unsafe_to_string res, 0, n'))
144
+
else Ok (Bytes.unsafe_to_string res, 0, n' - pad_to_write)
145
146
(* [pad = false], we don't want to write them. *)
147
148
let encode ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input =
···
164
| Error (`Msg err) -> invalid_arg err
165
166
let decode_sub ?(pad = true) { dmap; _ } ?(off = 0) ?len input =
167
+
let len =
168
+
match len with Some len -> len | None -> String.length input - off in
169
170
if len < 0 || off < 0 || off > String.length input - len
171
then error_msgf "Invalid bounds"
172
else
173
+
let n = len // 4 * 4 in
174
+
let n' = n // 4 * 3 in
175
+
let res = Bytes.create n' in
176
+
let invalid_pad_overflow = pad in
177
178
+
let get_uint8_or_padding =
179
+
if pad
180
+
then (fun t i ->
181
+
if i >= len then raise Out_of_bounds ;
182
+
get_uint8 t (off + i))
183
+
else
184
+
fun t i ->
185
+
try if i < len then get_uint8 t (off + i) else padding
186
+
with Out_of_bounds -> padding in
187
188
+
let set_be_uint16 t off v =
189
+
(* can not write 2 bytes. *)
190
+
if off < 0 || off + 1 > Bytes.length t
191
+
then () (* can not write 1 byte but can write 1 byte *)
192
+
else if off < 0 || off + 2 > Bytes.length t
193
+
then unsafe_set_uint8 t off (v lsr 8) (* can write 2 bytes. *)
194
+
else unsafe_set_be_uint16 t off v in
195
196
+
let set_uint8 t off v =
197
+
if off < 0 || off >= Bytes.length t then () else unsafe_set_uint8 t off v
198
+
in
199
200
+
let emit a b c d j =
201
+
let x = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in
202
+
set_be_uint16 res j (x lsr 8) ;
203
+
set_uint8 res (j + 2) (x land 0xff) in
204
205
+
let dmap i =
206
+
let x = Array.unsafe_get dmap i in
207
+
if x = none then raise Not_found ;
208
+
x in
209
210
+
let only_padding pad idx =
211
+
(* because we round length of [res] to the upper bound of how many
212
+
characters we should have from [input], we got at this stage only padding
213
+
characters and we need to delete them, so for each [====], we delete 3
214
+
bytes. *)
215
+
let pad = ref (pad + 3) in
216
+
let idx = ref idx in
217
218
+
while !idx + 4 < len do
219
+
(* use [unsafe_get_uint16] instead [unsafe_get_uint32] to avoid allocation
220
+
of [int32]. Of course, [3d3d3d3d] is [====]. *)
221
+
if unsafe_get_uint16 input (off + !idx) <> 0x3d3d
222
+
|| unsafe_get_uint16 input (off + !idx + 2) <> 0x3d3d
223
+
then raise Not_found ;
224
225
+
(* We got something bad, should be a valid character according to
226
+
[alphabet] but outside the scope. *)
227
+
idx := !idx + 4 ;
228
+
pad := !pad + 3
229
+
done ;
230
+
while !idx < len do
231
+
if unsafe_get_uint8 input (off + !idx) <> padding then raise Not_found ;
232
233
+
incr idx
234
+
done ;
235
+
!pad in
236
237
+
let rec dec j i =
238
+
if i = n
239
+
then 0
240
+
else
241
+
let d, pad =
242
+
let x = get_uint8_or_padding input (i + 3) in
243
+
try (dmap x, 0) with Not_found when x = padding -> (0, 1) in
244
+
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
245
+
let c, pad =
246
+
let x = get_uint8_or_padding input (i + 2) in
247
+
try (dmap x, pad)
248
+
with Not_found when x = padding && pad = 1 -> (0, 2) in
249
+
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
250
+
let b, pad =
251
+
let x = get_uint8_or_padding input (i + 1) in
252
+
try (dmap x, pad)
253
+
with Not_found when x = padding && pad = 2 -> (0, 3) in
254
+
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
255
+
let a, pad =
256
+
let x = get_uint8_or_padding input i in
257
+
try (dmap x, pad)
258
+
with Not_found when x = padding && pad = 3 -> (0, 4) in
259
260
+
(* [Not_found] iff [x ∉ alphabet and x <> '='] can leak. *)
261
+
emit a b c d j ;
262
263
+
if i + 4 = n (* end of input in anyway *)
264
+
then
265
+
match pad with
266
+
| 0 -> 0
267
+
| 4 ->
268
+
(* assert (invalid_pad_overflow = false) ; *)
269
+
3
270
+
(* [get_uint8] lies and if we get [4], that mean we got one or more (at
271
+
most 4) padding character. In this situation, because we round length
272
+
of [res] (see [n // 4]), we need to delete 3 bytes. *)
273
+
| pad -> pad
274
+
else
275
+
match pad with
276
+
| 0 -> dec (j + 3) (i + 4)
277
+
| 4 ->
278
+
(* assert (invalid_pad_overflow = false) ; *)
279
+
only_padding 3 (i + 4)
280
+
(* Same situation than above but we should get only more padding
281
+
characters then. *)
282
+
| pad ->
283
+
if invalid_pad_overflow = true then raise Too_much_input ;
284
+
only_padding pad (i + 4) in
285
286
+
match dec 0 0 with
287
+
| 0 -> Ok (Bytes.unsafe_to_string res, 0, n')
288
+
| pad -> Ok (Bytes.unsafe_to_string res, 0, n' - pad)
289
+
| exception Out_of_bounds ->
290
+
error_msgf "Wrong padding"
291
+
(* appear only when [pad = true] and when length of input is not a multiple of 4. *)
292
+
| exception Not_found ->
293
+
(* appear when one character of [input] ∉ [alphabet] and this character <> '=' *)
294
+
error_msgf "Malformed input"
295
+
| exception Too_much_input -> error_msgf "Too much input"
296
297
let decode ?pad ?(alphabet = default_alphabet) ?off ?len input =
298
match decode_sub ?pad alphabet ?off ?len input with
+40
-13
src/base64.mli
+40
-13
src/base64.mli
···
48
val alphabet : alphabet -> int array
49
(** Returns the alphabet. *)
50
51
-
val decode_exn : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
52
-
(** [decode_exn ?off ?len s] decodes [len] bytes (defaults to [String.length s -
53
-
off]) of the string [s] starting from [off] (defaults to [0]) that is encoded
54
-
in Base64 format. Will leave trailing NULLs on the string, padding it out to
55
-
a multiple of 3 characters. [alphabet] defaults to {!default_alphabet}. [pad
56
-
= true] specifies to check if [s] is padded or not, otherwise, it raises an
57
-
exception.
58
59
Decoder can fail when character of [s] is not a part of [alphabet] or is not
60
[padding] character. If input is not padded correctly, decoder does the
···
62
63
@raise if Invalid_argument [s] is not a valid Base64 string. *)
64
65
-
val decode_sub : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (sub, [> `Msg of string ]) result
66
(** Same as {!decode_exn} but it returns a result type instead to raise an
67
exception. Then, it returns a {!sub} string. Decoded input [(str, off, len)]
68
will starting to [off] and will have [len] bytes - by this way, we ensure to
69
allocate only one time result. *)
70
71
-
val decode : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (string, [> `Msg of string ]) result
72
-
(** Same as {!decode_exn}, but returns an explicit error message {!result} if it fails. *)
73
74
-
val encode : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (string, [> `Msg of string]) result
75
(** [encode s] encodes the string [s] into base64. If [pad] is false, no
76
trailing padding is added. [pad] defaults to [true], and [alphabet] to
77
{!default_alphabet}.
···
83
trailing padding is added. [pad] defaults to [true], and [alphabet] to
84
{!default_alphabet}. *)
85
86
-
val encode_sub : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (sub, [> `Msg of string]) result
87
(** Same as {!encode} but return a {!sub}-string instead a plain result. By this
88
way, we ensure to allocate only one time result. *)
89
90
-
val encode_exn : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
91
(** Same as {!encode} but raises an invalid argument exception if we retrieve an
92
error. *)
···
48
val alphabet : alphabet -> int array
49
(** Returns the alphabet. *)
50
51
+
val decode_exn :
52
+
?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
53
+
(** [decode_exn ?off ?len s] decodes [len] bytes (defaults to
54
+
[String.length s - off]) of the string [s] starting from [off] (defaults to
55
+
[0]) that is encoded in Base64 format. Will leave trailing NULLs on the
56
+
string, padding it out to a multiple of 3 characters. [alphabet] defaults to
57
+
{!default_alphabet}. [pad = true] specifies to check if [s] is padded or
58
+
not, otherwise, it raises an exception.
59
60
Decoder can fail when character of [s] is not a part of [alphabet] or is not
61
[padding] character. If input is not padded correctly, decoder does the
···
63
64
@raise if Invalid_argument [s] is not a valid Base64 string. *)
65
66
+
val decode_sub :
67
+
?pad:bool ->
68
+
?alphabet:alphabet ->
69
+
?off:int ->
70
+
?len:int ->
71
+
string ->
72
+
(sub, [> `Msg of string ]) result
73
(** Same as {!decode_exn} but it returns a result type instead to raise an
74
exception. Then, it returns a {!sub} string. Decoded input [(str, off, len)]
75
will starting to [off] and will have [len] bytes - by this way, we ensure to
76
allocate only one time result. *)
77
78
+
val decode :
79
+
?pad:bool ->
80
+
?alphabet:alphabet ->
81
+
?off:int ->
82
+
?len:int ->
83
+
string ->
84
+
(string, [> `Msg of string ]) result
85
+
(** Same as {!decode_exn}, but returns an explicit error message {!result} if it
86
+
fails. *)
87
88
+
val encode :
89
+
?pad:bool ->
90
+
?alphabet:alphabet ->
91
+
?off:int ->
92
+
?len:int ->
93
+
string ->
94
+
(string, [> `Msg of string ]) result
95
(** [encode s] encodes the string [s] into base64. If [pad] is false, no
96
trailing padding is added. [pad] defaults to [true], and [alphabet] to
97
{!default_alphabet}.
···
103
trailing padding is added. [pad] defaults to [true], and [alphabet] to
104
{!default_alphabet}. *)
105
106
+
val encode_sub :
107
+
?pad:bool ->
108
+
?alphabet:alphabet ->
109
+
?off:int ->
110
+
?len:int ->
111
+
string ->
112
+
(sub, [> `Msg of string ]) result
113
(** Same as {!encode} but return a {!sub}-string instead a plain result. By this
114
way, we ensure to allocate only one time result. *)
115
116
+
val encode_exn :
117
+
?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
118
(** Same as {!encode} but raises an invalid argument exception if we retrieve an
119
error. *)
+161
-135
src/base64_rfc2045.ml
+161
-135
src/base64_rfc2045.ml
···
19
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
20
21
let io_buffer_size = 65536
22
let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt
23
24
let invalid_bounds off len =
25
invalid_arg "Invalid bounds (off: %d, len: %d)" off len
26
27
-
let malformed chr =
28
-
`Malformed (String.make 1 chr)
29
30
let unsafe_byte source off pos = Bytes.unsafe_get source (off + pos)
31
let unsafe_blit = Bytes.unsafe_blit
32
let unsafe_chr = Char.unsafe_chr
33
let unsafe_set_chr source off chr = Bytes.unsafe_set source off chr
34
35
-
type state = {quantum: int; size: int; buffer: Bytes.t}
36
37
-
let continue state (quantum, size) = `Continue {state with quantum; size}
38
-
let flush state = `Flush {state with quantum= 0; size= 0}
39
40
let table =
41
"\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\062\255\255\255\063\052\053\054\055\056\057\058\059\060\061\255\255\255\255\255\255\255\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\255\255\255\255\255\255\026\027\028\029\030\031\032\033\034\035\036\037\038\039\040\041\042\043\044\045\046\047\048\049\050\051\255\255\255\255\255"
42
43
-
let r_repr ({quantum; size; _} as state) chr =
44
(* assert (0 <= off && 0 <= len && off + len <= String.length source); *)
45
(* assert (len >= 1); *)
46
let code = Char.code table.[Char.code chr] in
···
56
flush state
57
| _ -> malformed chr
58
59
-
type src = [`Channel of in_channel | `String of string | `Manual]
60
61
type decode =
62
-
[`Await | `End | `Wrong_padding | `Malformed of string | `Flush of string]
63
64
type input =
65
-
[`Line_break | `Wsp | `Padding | `Malformed of string | `Flush of state]
66
67
-
type decoder =
68
-
{ src: src
69
-
; mutable i: Bytes.t
70
-
; mutable i_off: int
71
-
; mutable i_pos: int
72
-
; mutable i_len: int
73
-
; mutable s: state
74
-
; mutable padding: int
75
-
; mutable unsafe: bool
76
-
; mutable byte_count: int
77
-
; mutable limit_count: int
78
-
; mutable pp: decoder -> input -> decode
79
-
; mutable k: decoder -> decode }
80
81
let i_rem decoder = decoder.i_len - decoder.i_pos + 1
82
···
87
decoder.i_len <- min_int
88
89
let src decoder source off len =
90
-
if off < 0 || len < 0 || off + len > Bytes.length source then
91
-
invalid_bounds off len
92
-
else if len = 0 then end_of_input decoder
93
else (
94
decoder.i <- source ;
95
decoder.i_off <- off ;
96
decoder.i_pos <- 0 ;
97
-
decoder.i_len <- len - 1 )
98
99
let refill k decoder =
100
match decoder.src with
101
| `Manual ->
102
decoder.k <- k ;
103
`Await
104
-
| `String _ -> end_of_input decoder ; k decoder
105
| `Channel ic ->
106
let len = input ic decoder.i 0 (Bytes.length decoder.i) in
107
src decoder decoder.i 0 len ;
108
k decoder
109
110
let dangerous decoder v = decoder.unsafe <- v
111
let reset decoder = decoder.limit_count <- 0
112
113
let ret k v byte_count decoder =
···
117
if decoder.limit_count > 78 then dangerous decoder true ;
118
decoder.pp decoder v
119
120
-
type flush_and_malformed = [`Flush of state | `Malformed of string]
121
122
-
let padding {size; _} padding =
123
match (size, padding) with
124
| 0, 0 -> true
125
| 1, _ -> false
···
127
| 3, 1 -> true
128
| _ -> false
129
130
-
let t_flush {quantum; size; buffer} =
131
match size with
132
-
| 0 | 1 -> `Flush {quantum; size; buffer= Bytes.empty}
133
| 2 ->
134
let quantum = quantum lsr 4 in
135
`Flush
136
-
{ quantum
137
-
; size
138
-
; buffer= Bytes.make 1 (unsafe_chr (quantum land 255)) }
139
| 3 ->
140
let quantum = quantum lsr 2 in
141
unsafe_set_chr buffer 0 (unsafe_chr ((quantum lsr 8) land 255)) ;
142
unsafe_set_chr buffer 1 (unsafe_chr (quantum land 255)) ;
143
-
`Flush {quantum; size; buffer= Bytes.sub buffer 0 2}
144
-
| _ -> assert false (* this branch is impossible, size can only ever be in the range [0..3]. *)
145
146
let wrong_padding decoder =
147
let k _ = `End in
148
-
decoder.k <- k ; `Wrong_padding
149
150
let rec t_decode_base64 chr decoder =
151
-
if decoder.padding = 0 then
152
let rec go pos = function
153
| `Continue state ->
154
if decoder.i_len - (decoder.i_pos + pos) + 1 > 0
155
then (
156
match unsafe_byte decoder.i decoder.i_off (decoder.i_pos + pos) with
157
-
| ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '+' | '/') as chr -> go (succ pos) (r_repr state chr)
158
| '=' ->
159
decoder.padding <- decoder.padding + 1 ;
160
decoder.i_pos <- decoder.i_pos + pos + 1 ;
161
decoder.s <- state ;
162
-
ret decode_base64 `Padding (pos+1) decoder
163
| ' ' | '\t' ->
164
decoder.i_pos <- decoder.i_pos + pos + 1 ;
165
decoder.s <- state ;
···
171
| chr ->
172
decoder.i_pos <- decoder.i_pos + pos + 1 ;
173
decoder.s <- state ;
174
-
ret decode_base64 (malformed chr) (pos+1) decoder
175
-
) else (
176
decoder.i_pos <- decoder.i_pos + pos ;
177
decoder.byte_count <- decoder.byte_count + pos ;
178
decoder.limit_count <- decoder.limit_count + pos ;
179
decoder.s <- state ;
180
-
refill decode_base64 decoder )
181
| #flush_and_malformed as v ->
182
decoder.i_pos <- decoder.i_pos + pos ;
183
-
ret decode_base64 v pos decoder
184
-
in
185
go 1 (r_repr decoder.s chr)
186
else (
187
decoder.i_pos <- decoder.i_pos + 1 ;
···
189
190
and decode_base64_lf_after_cr decoder =
191
let rem = i_rem decoder in
192
-
if rem < 0 then
193
-
ret decode_base64 (malformed '\r') 1 decoder
194
-
else if rem = 0 then refill decode_base64_lf_after_cr decoder
195
else
196
match unsafe_byte decoder.i decoder.i_off decoder.i_pos with
197
| '\n' ->
198
-
decoder.i_pos <- decoder.i_pos + 1 ;
199
-
ret decode_base64 `Line_break 2 decoder
200
-
| _ ->
201
-
ret decode_base64 (malformed '\r') 1 decoder
202
203
and decode_base64 decoder =
204
let rem = i_rem decoder in
205
-
if rem <= 0 then
206
-
if rem < 0 then
207
ret
208
(fun decoder ->
209
-
if padding decoder.s decoder.padding then `End else wrong_padding decoder )
210
(t_flush decoder.s) 0 decoder
211
else refill decode_base64 decoder
212
else
···
228
ret decode_base64 (malformed chr) 1 decoder
229
230
let pp_base64 decoder = function
231
-
| `Line_break -> reset decoder ; decoder.k decoder
232
| `Wsp | `Padding -> decoder.k decoder
233
| `Flush state ->
234
decoder.s <- state ;
···
242
match src with
243
| `Manual -> (Bytes.empty, 0, 1, 0)
244
| `Channel _ -> (Bytes.create io_buffer_size, 0, 1, 0)
245
-
| `String s -> (Bytes.unsafe_of_string s, 0, 0, String.length s - 1)
246
-
in
247
-
{ src
248
-
; i_off
249
-
; i_pos
250
-
; i_len
251
-
; i
252
-
; s= {quantum= 0; size= 0; buffer= Bytes.create 3}
253
-
; padding= 0
254
-
; unsafe= false
255
-
; byte_count= 0
256
-
; limit_count= 0
257
-
; pp
258
-
; k }
259
260
let decode decoder = decoder.k decoder
261
let decoder_byte_count decoder = decoder.byte_count
262
let decoder_src decoder = decoder.src
263
let decoder_dangerous decoder = decoder.unsafe
264
265
(* / *)
266
267
let invalid_encode () = invalid_arg "Expected `Await encode"
268
269
-
type dst = [`Channel of out_channel | `Buffer of Buffer.t | `Manual]
270
-
type encode = [`Await | `End | `Char of char]
271
272
-
type encoder =
273
-
{ dst: dst
274
-
; mutable o: Bytes.t
275
-
; mutable o_off: int
276
-
; mutable o_pos: int
277
-
; mutable o_len: int
278
-
; mutable c_col: int
279
-
; i: Bytes.t
280
-
; mutable s: int
281
-
; t: Bytes.t
282
-
; mutable t_pos: int
283
-
; mutable t_len: int
284
-
; mutable k: encoder -> encode -> [`Ok | `Partial] }
285
286
let o_rem encoder = encoder.o_len - encoder.o_pos + 1
287
288
let dst encoder source off len =
289
-
if off < 0 || len < 0 || off + len > Bytes.length source then
290
-
invalid_bounds off len ;
291
encoder.o <- source ;
292
encoder.o_off <- off ;
293
encoder.o_pos <- 0 ;
···
322
let blit encoder len =
323
unsafe_blit encoder.t encoder.t_pos encoder.o encoder.o_pos len ;
324
encoder.o_pos <- encoder.o_pos + len ;
325
-
encoder.t_pos <- encoder.t_pos + len
326
-
in
327
let rem = o_rem encoder in
328
let len = encoder.t_len - encoder.t_pos + 1 in
329
-
if rem < len then (
330
blit encoder rem ;
331
-
flush (t_flush k) encoder )
332
-
else ( blit encoder len ; k encoder )
333
334
let rec encode_line_break k encoder =
335
let rem = o_rem encoder in
336
let s, j, k =
337
-
if rem < 2 then (
338
t_range encoder 2 ;
339
-
(encoder.t, 0, t_flush k) )
340
else
341
let j = encoder.o_pos in
342
encoder.o_pos <- encoder.o_pos + 2 ;
343
-
(encoder.o, encoder.o_off + j, k)
344
-
in
345
unsafe_set_chr s j '\r' ;
346
unsafe_set_chr s (j + 1) '\n' ;
347
encoder.c_col <- 0 ;
348
k encoder
349
350
and encode_char chr k (encoder : encoder) =
351
-
if encoder.s >= 2 then (
352
-
let a, b, c =
353
-
(unsafe_byte encoder.i 0 0, unsafe_byte encoder.i 0 1, chr)
354
-
in
355
encoder.s <- 0 ;
356
let quantum = (Char.code a lsl 16) + (Char.code b lsl 8) + Char.code c in
357
let a = quantum lsr 18 in
···
360
let d = quantum land 63 in
361
let rem = o_rem encoder in
362
let s, j, k =
363
-
if rem < 4 then (
364
t_range encoder 4 ;
365
-
(encoder.t, 0, t_flush (k 4)) )
366
else
367
let j = encoder.o_pos in
368
encoder.o_pos <- encoder.o_pos + 4 ;
369
-
(encoder.o, encoder.o_off + j, k 4)
370
-
in
371
unsafe_set_chr s j default_alphabet.[a] ;
372
unsafe_set_chr s (j + 1) default_alphabet.[b] ;
373
unsafe_set_chr s (j + 2) default_alphabet.[c] ;
374
unsafe_set_chr s (j + 3) default_alphabet.[d] ;
375
-
flush k encoder )
376
else (
377
unsafe_set_chr encoder.i encoder.s chr ;
378
encoder.s <- encoder.s + 1 ;
379
-
k 0 encoder )
380
381
and encode_trailing k encoder =
382
match encoder.s with
···
389
let d = quantum land 63 in
390
let rem = o_rem encoder in
391
let s, j, k =
392
-
if rem < 4 then (
393
t_range encoder 4 ;
394
-
(encoder.t, 0, t_flush (k 4)) )
395
else
396
let j = encoder.o_pos in
397
encoder.o_pos <- encoder.o_pos + 4 ;
398
-
(encoder.o, encoder.o_off + j, k 4)
399
-
in
400
unsafe_set_chr s j default_alphabet.[b] ;
401
unsafe_set_chr s (j + 1) default_alphabet.[c] ;
402
unsafe_set_chr s (j + 2) default_alphabet.[d] ;
···
410
let d = quantum land 63 in
411
let rem = o_rem encoder in
412
let s, j, k =
413
-
if rem < 4 then (
414
t_range encoder 4 ;
415
-
(encoder.t, 0, t_flush (k 4)) )
416
else
417
let j = encoder.o_pos in
418
encoder.o_pos <- encoder.o_pos + 4 ;
419
-
(encoder.o, encoder.o_off + j, k 4)
420
-
in
421
unsafe_set_chr s j default_alphabet.[c] ;
422
unsafe_set_chr s (j + 1) default_alphabet.[d] ;
423
unsafe_set_chr s (j + 2) '=' ;
···
430
let k col_count encoder =
431
encoder.c_col <- encoder.c_col + col_count ;
432
encoder.k <- encode_base64 ;
433
-
`Ok
434
-
in
435
match v with
436
| `Await -> k 0 encoder
437
| `End ->
438
-
if encoder.c_col = 76 then
439
-
encode_line_break (fun encoder -> encode_base64 encoder v) encoder
440
else encode_trailing k encoder
441
| `Char chr ->
442
let rem = o_rem encoder in
443
-
if rem < 1 then flush (fun encoder -> encode_base64 encoder v) encoder
444
-
else if encoder.c_col = 76 then
445
-
encode_line_break (fun encoder -> encode_base64 encoder v) encoder
446
else encode_char chr k encoder
447
448
let encoder dst =
···
450
match dst with
451
| `Manual -> (Bytes.empty, 1, 0, 0)
452
| `Buffer _ | `Channel _ ->
453
-
(Bytes.create io_buffer_size, 0, 0, io_buffer_size - 1)
454
-
in
455
-
{ dst
456
-
; o_off
457
-
; o_pos
458
-
; o_len
459
-
; o
460
-
; t= Bytes.create 4
461
-
; t_pos= 1
462
-
; t_len= 0
463
-
; c_col= 0
464
-
; i= Bytes.create 3
465
-
; s= 0
466
-
; k= encode_base64 }
467
468
let encode encoder = encoder.k encoder
469
let encoder_dst encoder = encoder.dst
···
19
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
20
21
let io_buffer_size = 65536
22
+
23
let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt
24
25
let invalid_bounds off len =
26
invalid_arg "Invalid bounds (off: %d, len: %d)" off len
27
28
+
let malformed chr = `Malformed (String.make 1 chr)
29
30
let unsafe_byte source off pos = Bytes.unsafe_get source (off + pos)
31
+
32
let unsafe_blit = Bytes.unsafe_blit
33
+
34
let unsafe_chr = Char.unsafe_chr
35
+
36
let unsafe_set_chr source off chr = Bytes.unsafe_set source off chr
37
38
+
type state = { quantum : int; size : int; buffer : Bytes.t }
39
+
40
+
let continue state (quantum, size) = `Continue { state with quantum; size }
41
42
+
let flush state = `Flush { state with quantum = 0; size = 0 }
43
44
let table =
45
"\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\062\255\255\255\063\052\053\054\055\056\057\058\059\060\061\255\255\255\255\255\255\255\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\255\255\255\255\255\255\026\027\028\029\030\031\032\033\034\035\036\037\038\039\040\041\042\043\044\045\046\047\048\049\050\051\255\255\255\255\255"
46
47
+
let r_repr ({ quantum; size; _ } as state) chr =
48
(* assert (0 <= off && 0 <= len && off + len <= String.length source); *)
49
(* assert (len >= 1); *)
50
let code = Char.code table.[Char.code chr] in
···
60
flush state
61
| _ -> malformed chr
62
63
+
type src = [ `Channel of in_channel | `String of string | `Manual ]
64
65
type decode =
66
+
[ `Await | `End | `Wrong_padding | `Malformed of string | `Flush of string ]
67
68
type input =
69
+
[ `Line_break | `Wsp | `Padding | `Malformed of string | `Flush of state ]
70
71
+
type decoder = {
72
+
src : src;
73
+
mutable i : Bytes.t;
74
+
mutable i_off : int;
75
+
mutable i_pos : int;
76
+
mutable i_len : int;
77
+
mutable s : state;
78
+
mutable padding : int;
79
+
mutable unsafe : bool;
80
+
mutable byte_count : int;
81
+
mutable limit_count : int;
82
+
mutable pp : decoder -> input -> decode;
83
+
mutable k : decoder -> decode;
84
+
}
85
86
let i_rem decoder = decoder.i_len - decoder.i_pos + 1
87
···
92
decoder.i_len <- min_int
93
94
let src decoder source off len =
95
+
if off < 0 || len < 0 || off + len > Bytes.length source
96
+
then invalid_bounds off len
97
+
else if len = 0
98
+
then end_of_input decoder
99
else (
100
decoder.i <- source ;
101
decoder.i_off <- off ;
102
decoder.i_pos <- 0 ;
103
+
decoder.i_len <- len - 1)
104
105
let refill k decoder =
106
match decoder.src with
107
| `Manual ->
108
decoder.k <- k ;
109
`Await
110
+
| `String _ ->
111
+
end_of_input decoder ;
112
+
k decoder
113
| `Channel ic ->
114
let len = input ic decoder.i 0 (Bytes.length decoder.i) in
115
src decoder decoder.i 0 len ;
116
k decoder
117
118
let dangerous decoder v = decoder.unsafe <- v
119
+
120
let reset decoder = decoder.limit_count <- 0
121
122
let ret k v byte_count decoder =
···
126
if decoder.limit_count > 78 then dangerous decoder true ;
127
decoder.pp decoder v
128
129
+
type flush_and_malformed = [ `Flush of state | `Malformed of string ]
130
131
+
let padding { size; _ } padding =
132
match (size, padding) with
133
| 0, 0 -> true
134
| 1, _ -> false
···
136
| 3, 1 -> true
137
| _ -> false
138
139
+
let t_flush { quantum; size; buffer } =
140
match size with
141
+
| 0 | 1 -> `Flush { quantum; size; buffer = Bytes.empty }
142
| 2 ->
143
let quantum = quantum lsr 4 in
144
`Flush
145
+
{ quantum; size; buffer = Bytes.make 1 (unsafe_chr (quantum land 255)) }
146
| 3 ->
147
let quantum = quantum lsr 2 in
148
unsafe_set_chr buffer 0 (unsafe_chr ((quantum lsr 8) land 255)) ;
149
unsafe_set_chr buffer 1 (unsafe_chr (quantum land 255)) ;
150
+
`Flush { quantum; size; buffer = Bytes.sub buffer 0 2 }
151
+
| _ -> assert false
152
+
153
+
(* this branch is impossible, size can only ever be in the range [0..3]. *)
154
155
let wrong_padding decoder =
156
let k _ = `End in
157
+
decoder.k <- k ;
158
+
`Wrong_padding
159
160
let rec t_decode_base64 chr decoder =
161
+
if decoder.padding = 0
162
+
then
163
let rec go pos = function
164
| `Continue state ->
165
if decoder.i_len - (decoder.i_pos + pos) + 1 > 0
166
then (
167
match unsafe_byte decoder.i decoder.i_off (decoder.i_pos + pos) with
168
+
| ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '+' | '/') as chr ->
169
+
go (succ pos) (r_repr state chr)
170
| '=' ->
171
decoder.padding <- decoder.padding + 1 ;
172
decoder.i_pos <- decoder.i_pos + pos + 1 ;
173
decoder.s <- state ;
174
+
ret decode_base64 `Padding (pos + 1) decoder
175
| ' ' | '\t' ->
176
decoder.i_pos <- decoder.i_pos + pos + 1 ;
177
decoder.s <- state ;
···
183
| chr ->
184
decoder.i_pos <- decoder.i_pos + pos + 1 ;
185
decoder.s <- state ;
186
+
ret decode_base64 (malformed chr) (pos + 1) decoder)
187
+
else (
188
decoder.i_pos <- decoder.i_pos + pos ;
189
decoder.byte_count <- decoder.byte_count + pos ;
190
decoder.limit_count <- decoder.limit_count + pos ;
191
decoder.s <- state ;
192
+
refill decode_base64 decoder)
193
| #flush_and_malformed as v ->
194
decoder.i_pos <- decoder.i_pos + pos ;
195
+
ret decode_base64 v pos decoder in
196
go 1 (r_repr decoder.s chr)
197
else (
198
decoder.i_pos <- decoder.i_pos + 1 ;
···
200
201
and decode_base64_lf_after_cr decoder =
202
let rem = i_rem decoder in
203
+
if rem < 0
204
+
then ret decode_base64 (malformed '\r') 1 decoder
205
+
else if rem = 0
206
+
then refill decode_base64_lf_after_cr decoder
207
else
208
match unsafe_byte decoder.i decoder.i_off decoder.i_pos with
209
| '\n' ->
210
+
decoder.i_pos <- decoder.i_pos + 1 ;
211
+
ret decode_base64 `Line_break 2 decoder
212
+
| _ -> ret decode_base64 (malformed '\r') 1 decoder
213
214
and decode_base64 decoder =
215
let rem = i_rem decoder in
216
+
if rem <= 0
217
+
then
218
+
if rem < 0
219
+
then
220
ret
221
(fun decoder ->
222
+
if padding decoder.s decoder.padding
223
+
then `End
224
+
else wrong_padding decoder)
225
(t_flush decoder.s) 0 decoder
226
else refill decode_base64 decoder
227
else
···
243
ret decode_base64 (malformed chr) 1 decoder
244
245
let pp_base64 decoder = function
246
+
| `Line_break ->
247
+
reset decoder ;
248
+
decoder.k decoder
249
| `Wsp | `Padding -> decoder.k decoder
250
| `Flush state ->
251
decoder.s <- state ;
···
259
match src with
260
| `Manual -> (Bytes.empty, 0, 1, 0)
261
| `Channel _ -> (Bytes.create io_buffer_size, 0, 1, 0)
262
+
| `String s -> (Bytes.unsafe_of_string s, 0, 0, String.length s - 1) in
263
+
{
264
+
src;
265
+
i_off;
266
+
i_pos;
267
+
i_len;
268
+
i;
269
+
s = { quantum = 0; size = 0; buffer = Bytes.create 3 };
270
+
padding = 0;
271
+
unsafe = false;
272
+
byte_count = 0;
273
+
limit_count = 0;
274
+
pp;
275
+
k;
276
+
}
277
278
let decode decoder = decoder.k decoder
279
+
280
let decoder_byte_count decoder = decoder.byte_count
281
+
282
let decoder_src decoder = decoder.src
283
+
284
let decoder_dangerous decoder = decoder.unsafe
285
286
(* / *)
287
288
let invalid_encode () = invalid_arg "Expected `Await encode"
289
290
+
type dst = [ `Channel of out_channel | `Buffer of Buffer.t | `Manual ]
291
292
+
type encode = [ `Await | `End | `Char of char ]
293
+
294
+
type encoder = {
295
+
dst : dst;
296
+
mutable o : Bytes.t;
297
+
mutable o_off : int;
298
+
mutable o_pos : int;
299
+
mutable o_len : int;
300
+
mutable c_col : int;
301
+
i : Bytes.t;
302
+
mutable s : int;
303
+
t : Bytes.t;
304
+
mutable t_pos : int;
305
+
mutable t_len : int;
306
+
mutable k : encoder -> encode -> [ `Ok | `Partial ];
307
+
}
308
309
let o_rem encoder = encoder.o_len - encoder.o_pos + 1
310
311
let dst encoder source off len =
312
+
if off < 0 || len < 0 || off + len > Bytes.length source
313
+
then invalid_bounds off len ;
314
encoder.o <- source ;
315
encoder.o_off <- off ;
316
encoder.o_pos <- 0 ;
···
345
let blit encoder len =
346
unsafe_blit encoder.t encoder.t_pos encoder.o encoder.o_pos len ;
347
encoder.o_pos <- encoder.o_pos + len ;
348
+
encoder.t_pos <- encoder.t_pos + len in
349
let rem = o_rem encoder in
350
let len = encoder.t_len - encoder.t_pos + 1 in
351
+
if rem < len
352
+
then (
353
blit encoder rem ;
354
+
flush (t_flush k) encoder)
355
+
else (
356
+
blit encoder len ;
357
+
k encoder)
358
359
let rec encode_line_break k encoder =
360
let rem = o_rem encoder in
361
let s, j, k =
362
+
if rem < 2
363
+
then (
364
t_range encoder 2 ;
365
+
(encoder.t, 0, t_flush k))
366
else
367
let j = encoder.o_pos in
368
encoder.o_pos <- encoder.o_pos + 2 ;
369
+
(encoder.o, encoder.o_off + j, k) in
370
unsafe_set_chr s j '\r' ;
371
unsafe_set_chr s (j + 1) '\n' ;
372
encoder.c_col <- 0 ;
373
k encoder
374
375
and encode_char chr k (encoder : encoder) =
376
+
if encoder.s >= 2
377
+
then (
378
+
let a, b, c = (unsafe_byte encoder.i 0 0, unsafe_byte encoder.i 0 1, chr) in
379
encoder.s <- 0 ;
380
let quantum = (Char.code a lsl 16) + (Char.code b lsl 8) + Char.code c in
381
let a = quantum lsr 18 in
···
384
let d = quantum land 63 in
385
let rem = o_rem encoder in
386
let s, j, k =
387
+
if rem < 4
388
+
then (
389
t_range encoder 4 ;
390
+
(encoder.t, 0, t_flush (k 4)))
391
else
392
let j = encoder.o_pos in
393
encoder.o_pos <- encoder.o_pos + 4 ;
394
+
(encoder.o, encoder.o_off + j, k 4) in
395
unsafe_set_chr s j default_alphabet.[a] ;
396
unsafe_set_chr s (j + 1) default_alphabet.[b] ;
397
unsafe_set_chr s (j + 2) default_alphabet.[c] ;
398
unsafe_set_chr s (j + 3) default_alphabet.[d] ;
399
+
flush k encoder)
400
else (
401
unsafe_set_chr encoder.i encoder.s chr ;
402
encoder.s <- encoder.s + 1 ;
403
+
k 0 encoder)
404
405
and encode_trailing k encoder =
406
match encoder.s with
···
413
let d = quantum land 63 in
414
let rem = o_rem encoder in
415
let s, j, k =
416
+
if rem < 4
417
+
then (
418
t_range encoder 4 ;
419
+
(encoder.t, 0, t_flush (k 4)))
420
else
421
let j = encoder.o_pos in
422
encoder.o_pos <- encoder.o_pos + 4 ;
423
+
(encoder.o, encoder.o_off + j, k 4) in
424
unsafe_set_chr s j default_alphabet.[b] ;
425
unsafe_set_chr s (j + 1) default_alphabet.[c] ;
426
unsafe_set_chr s (j + 2) default_alphabet.[d] ;
···
434
let d = quantum land 63 in
435
let rem = o_rem encoder in
436
let s, j, k =
437
+
if rem < 4
438
+
then (
439
t_range encoder 4 ;
440
+
(encoder.t, 0, t_flush (k 4)))
441
else
442
let j = encoder.o_pos in
443
encoder.o_pos <- encoder.o_pos + 4 ;
444
+
(encoder.o, encoder.o_off + j, k 4) in
445
unsafe_set_chr s j default_alphabet.[c] ;
446
unsafe_set_chr s (j + 1) default_alphabet.[d] ;
447
unsafe_set_chr s (j + 2) '=' ;
···
454
let k col_count encoder =
455
encoder.c_col <- encoder.c_col + col_count ;
456
encoder.k <- encode_base64 ;
457
+
`Ok in
458
match v with
459
| `Await -> k 0 encoder
460
| `End ->
461
+
if encoder.c_col = 76
462
+
then encode_line_break (fun encoder -> encode_base64 encoder v) encoder
463
else encode_trailing k encoder
464
| `Char chr ->
465
let rem = o_rem encoder in
466
+
if rem < 1
467
+
then flush (fun encoder -> encode_base64 encoder v) encoder
468
+
else if encoder.c_col = 76
469
+
then encode_line_break (fun encoder -> encode_base64 encoder v) encoder
470
else encode_char chr k encoder
471
472
let encoder dst =
···
474
match dst with
475
| `Manual -> (Bytes.empty, 1, 0, 0)
476
| `Buffer _ | `Channel _ ->
477
+
(Bytes.create io_buffer_size, 0, 0, io_buffer_size - 1) in
478
+
{
479
+
dst;
480
+
o_off;
481
+
o_pos;
482
+
o_len;
483
+
o;
484
+
t = Bytes.create 4;
485
+
t_pos = 1;
486
+
t_len = 0;
487
+
c_col = 0;
488
+
i = Bytes.create 3;
489
+
s = 0;
490
+
k = encode_base64;
491
+
}
492
493
let encode encoder = encoder.k encoder
494
+
495
let encoder_dst encoder = encoder.dst
+9
-9
src/base64_rfc2045.mli
+9
-9
src/base64_rfc2045.mli
···
20
val default_alphabet : string
21
(** A 64-character string specifying the regular Base64 alphabet. *)
22
23
-
(** The type for decoders. *)
24
type decoder
25
26
(** The type for input sources. With a [`Manual] source the client must provide
27
input with {!src}. *)
28
-
type src = [`Manual | `Channel of in_channel | `String of string]
29
30
type decode =
31
-
[`Await | `End | `Flush of string | `Malformed of string | `Wrong_padding]
32
33
val src : decoder -> Bytes.t -> int -> int -> unit
34
(** [src d s j l] provides [d] with [l] bytes to read, starting at [j] in [s].
···
66
still continue to decode even if [decoder_dangerous d] returns [true].
67
Nothing grow automatically internally in this state. *)
68
69
(** The type for output destinations. With a [`Manual] destination the client
70
must provide output storage with {!dst}. *)
71
-
type dst = [`Channel of out_channel | `Buffer of Buffer.t | `Manual]
72
73
-
type encode = [`Await | `End | `Char of char]
74
75
(** The type for Base64 (RFC2045) encoder. *)
76
-
type encoder
77
78
val encoder : dst -> encoder
79
(** [encoder dst] is an encoder for Base64 (RFC2045) that outputs to [dst]. *)
80
81
-
val encode : encoder -> encode -> [`Ok | `Partial]
82
(** [encode e v]: is {ul {- [`Partial] iff [e] has a [`Manual] destination and
83
needs more output storage. The client must use {!dst} to provide a new
84
buffer and then call {!encode} with [`Await] until [`Ok] is returned.} {-
···
99
val dst : encoder -> Bytes.t -> int -> int -> unit
100
(** [dst e s j l] provides [e] with [l] bytes to write, starting at [j] in [s].
101
This byte range is written by calls to {!encode} with [e] until [`Partial]
102
-
is returned. Use {!dst_rem} to know the remaining number of non-written
103
-
free bytes in [s]. *)
104
105
val dst_rem : encoder -> int
106
(** [dst_rem e] is the remaining number of non-written, free bytes in the last
···
20
val default_alphabet : string
21
(** A 64-character string specifying the regular Base64 alphabet. *)
22
23
type decoder
24
+
(** The type for decoders. *)
25
26
+
type src = [ `Manual | `Channel of in_channel | `String of string ]
27
(** The type for input sources. With a [`Manual] source the client must provide
28
input with {!src}. *)
29
30
type decode =
31
+
[ `Await | `End | `Flush of string | `Malformed of string | `Wrong_padding ]
32
33
val src : decoder -> Bytes.t -> int -> int -> unit
34
(** [src d s j l] provides [d] with [l] bytes to read, starting at [j] in [s].
···
66
still continue to decode even if [decoder_dangerous d] returns [true].
67
Nothing grow automatically internally in this state. *)
68
69
+
type dst = [ `Channel of out_channel | `Buffer of Buffer.t | `Manual ]
70
(** The type for output destinations. With a [`Manual] destination the client
71
must provide output storage with {!dst}. *)
72
73
+
type encode = [ `Await | `End | `Char of char ]
74
75
+
type encoder
76
(** The type for Base64 (RFC2045) encoder. *)
77
78
val encoder : dst -> encoder
79
(** [encoder dst] is an encoder for Base64 (RFC2045) that outputs to [dst]. *)
80
81
+
val encode : encoder -> encode -> [ `Ok | `Partial ]
82
(** [encode e v]: is {ul {- [`Partial] iff [e] has a [`Manual] destination and
83
needs more output storage. The client must use {!dst} to provide a new
84
buffer and then call {!encode} with [`Await] until [`Ok] is returned.} {-
···
99
val dst : encoder -> Bytes.t -> int -> int -> unit
100
(** [dst e s j l] provides [e] with [l] bytes to write, starting at [j] in [s].
101
This byte range is written by calls to {!encode} with [e] until [`Partial]
102
+
is returned. Use {!dst_rem} to know the remaining number of non-written free
103
+
bytes in [s]. *)
104
105
val dst_rem : encoder -> int
106
(** [dst_rem e] is the remaining number of non-written, free bytes in the last
+2
-1
src/unsafe_pre407.ml
+2
-1
src/unsafe_pre407.ml
+2
-1
src/unsafe_stable.ml
+2
-1
src/unsafe_stable.ml
+212
-149
test/test.ml
+212
-149
test/test.ml
···
28
BASE64("foobar") = "Zm9vYmFy"
29
*)
30
31
-
let rfc4648_tests = [
32
-
"", "";
33
-
"f", "Zg==";
34
-
"fo", "Zm8=";
35
-
"foo", "Zm9v";
36
-
"foob", "Zm9vYg==";
37
-
"fooba", "Zm9vYmE=";
38
-
"foobar", "Zm9vYmFy";
39
-
]
40
41
-
let hannes_tests = [
42
-
"dummy", "ZHVtbXk=";
43
-
"dummy", "ZHVtbXk";
44
-
"dummy", "ZHVtbXk==";
45
-
"dummy", "ZHVtbXk===";
46
-
"dummy", "ZHVtbXk====";
47
-
"dummy", "ZHVtbXk=====";
48
-
"dummy", "ZHVtbXk======";
49
-
]
50
51
-
let php_tests = [
52
-
"πάντα χωρεῖ καὶ οὐδὲν μένει …", "z4DOrM69z4TOsSDPh8-Jz4HOteG_liDOus6x4b22IM6_4b2QzrThvbLOvSDOvM6tzr3Otc65IOKApg"
53
-
]
54
55
-
let rfc3548_tests = [
56
-
"\x14\xfb\x9c\x03\xd9\x7e", "FPucA9l+";
57
-
"\x14\xfb\x9c\x03\xd9", "FPucA9k=";
58
-
"\x14\xfb\x9c\x03", "FPucAw==";
59
-
]
60
61
-
let cfcs_tests = [
62
-
0, 2, "\004", "BB";
63
-
1, 2, "\004", "ABB";
64
-
1, 2, "\004", "ABBA";
65
-
2, 2, "\004", "AABBA";
66
-
2, 2, "\004", "AABBAA";
67
-
0, 0, "", "BB";
68
-
1, 0, "", "BB";
69
-
2, 0, "", "BB";
70
-
]
71
72
let nocrypto_tests =
73
-
[ "\x00\x5a\x6d\x39\x76", None
74
-
; "\x5a\x6d\x39\x76", Some "\x66\x6f\x6f"
75
-
; "\x5a\x6d\x39\x76\x76", None
76
-
; "\x5a\x6d\x39\x76\x76\x76", None
77
-
; "\x5a\x6d\x39\x76\x76\x76\x76", None
78
-
; "\x5a\x6d\x39\x76\x00", None
79
-
; "\x5a\x6d\x39\x76\x62\x77\x3d\x3d", Some "\x66\x6f\x6f\x6f"
80
-
; "\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00", None
81
-
; "\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01", None
82
-
; "\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01\x02", None
83
-
; "\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01\x02\x03", None
84
-
; "\x5a\x6d\x39\x76\x62\x32\x38\x3d", Some "\x66\x6f\x6f\x6f\x6f"
85
-
; "\x5a\x6d\x39\x76\x62\x32\x39\x76", Some "\x66\x6f\x6f\x6f\x6f\x6f"
86
-
; "YWE=", Some "aa"
87
-
; "YWE==", None
88
-
; "YWE===", None
89
-
; "YWE=====", None
90
-
; "YWE======", None ]
91
92
let alphabet_size () =
93
-
List.iter (fun (name,alphabet) ->
94
-
Alcotest.(check int) (sprintf "Alphabet size %s = 64" name)
95
-
64 (Base64.length_alphabet alphabet))
96
-
["default",Base64.default_alphabet; "uri_safe",Base64.uri_safe_alphabet]
97
98
(* Encode using OpenSSL `base64` utility *)
99
let openssl_encode buf =
100
-
Bos.(OS.Cmd.in_string buf |> OS.Cmd.run_io (Cmd.v "base64") |> OS.Cmd.to_string ~trim:true) |>
101
-
function | Ok r -> prerr_endline r; r | Error (`Msg e) -> raise (Failure (sprintf "OpenSSL decode: %s" e))
102
103
(* Encode using this library *)
104
-
let lib_encode buf =
105
-
Base64.encode_exn ~pad:true buf
106
107
let test_rfc4648 () =
108
-
List.iter (fun (c,r) ->
109
-
(* Base64 vs openssl *)
110
-
Alcotest.(check string) (sprintf "encode %s" c) (openssl_encode c) (lib_encode c);
111
-
(* Base64 vs test cases above *)
112
-
Alcotest.(check string) (sprintf "encode rfc4648 %s" c) r (lib_encode c);
113
-
(* Base64 decode vs library *)
114
-
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn r);
115
-
) rfc4648_tests
116
117
let test_rfc3548 () =
118
-
List.iter (fun (c,r) ->
119
-
(* Base64 vs openssl *)
120
-
Alcotest.(check string) (sprintf "encode %s" c) (openssl_encode c) (lib_encode c);
121
-
(* Base64 vs test cases above *)
122
-
Alcotest.(check string) (sprintf "encode rfc3548 %s" c) r (lib_encode c);
123
-
(* Base64 decode vs library *)
124
-
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn r);
125
-
) rfc3548_tests
126
127
let test_hannes () =
128
-
List.iter (fun (c,r) ->
129
-
(* Base64 vs test cases above *)
130
-
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn ~pad:false r);
131
-
) hannes_tests
132
133
let test_php () =
134
-
List.iter (fun (c,r) ->
135
-
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet r);
136
-
) php_tests
137
138
let test_cfcs () =
139
-
List.iter (fun (off, len, c,r) ->
140
-
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn ~pad:false ~off ~len r);
141
-
) cfcs_tests
142
143
let test_nocrypto () =
144
-
List.iter (fun (input, res) ->
145
-
let res' = match Base64.decode ~pad:true input with
146
-
| Ok v -> Some v
147
-
| Error _ -> None in
148
-
Alcotest.(check (option string)) (sprintf "decode %S" input) res' res ;
149
-
) nocrypto_tests
150
151
exception Malformed
152
exception Wrong_padding
153
154
let strict_base64_rfc2045_of_string x =
155
let decoder = Base64_rfc2045.decoder (`String x) in
156
let res = Buffer.create 16 in
157
158
-
let rec go () = match Base64_rfc2045.decode decoder with
159
-
| `End -> ()
160
-
| `Wrong_padding -> raise Wrong_padding
161
-
| `Malformed _ -> raise Malformed
162
-
| `Flush x -> Buffer.add_string res x ; go ()
163
-
| `Await -> Alcotest.failf "Retrieve impossible case: `Await" in
164
165
Base64_rfc2045.src decoder (Bytes.unsafe_of_string x) 0 (String.length x) ;
166
-
go () ; Buffer.contents res
167
168
let relaxed_base64_rfc2045_of_string x =
169
let decoder = Base64_rfc2045.decoder (`String x) in
170
let res = Buffer.create 16 in
171
172
-
let rec go () = match Base64_rfc2045.decode decoder with
173
-
| `End -> ()
174
-
| `Wrong_padding -> go ()
175
-
| `Malformed _ -> go ()
176
-
| `Flush x -> Buffer.add_string res x ; go ()
177
-
| `Await -> Alcotest.failf "Retrieve impossible case: `Await" in
178
179
Base64_rfc2045.src decoder (Bytes.unsafe_of_string x) 0 (String.length x) ;
180
-
go () ; Buffer.contents res
181
182
let test_strict_rfc2045 =
183
-
[ "c2FsdXQgbGVzIGNvcGFpbnMgZmF1dCBhYnNvbHVtZW50IHF1ZSBqZSBkw6lwYXNzZSBsZXMgODAg\r\n\
184
-
Y2hhcmFjdGVycyBwb3VyIHZvaXIgc2kgbW9uIGVuY29kZXIgZml0cyBiaWVuIGRhbnMgbGVzIGxp\r\n\
185
-
bWl0ZXMgZGUgbGEgUkZDIDIwNDUgLi4u",
186
-
"salut les copains faut absolument que je dépasse les 80 characters pour voir si \
187
-
mon encoder fits bien dans les limites de la RFC 2045 ..."
188
-
; "", ""
189
-
; "Zg==", "f"
190
-
; "Zm8=", "fo"
191
-
; "Zm9v", "foo"
192
-
; "Zm9vYg==", "foob"
193
-
; "Zm9vYmE=", "fooba"
194
-
; "Zm9vYmFy", "foobar" ]
195
196
let test_relaxed_rfc2045 =
197
-
[ "Zg", "f"
198
-
; "Zm\n8", "fo"
199
-
; "Zm\r9v", "foo"
200
-
; "Zm9 vYg", "foob"
201
-
; "Zm9\r\n vYmE", "fooba"
202
-
; "Zm9évYmFy", "foobar" ]
203
204
let strict_base64_rfc2045_to_string x =
205
let res = Buffer.create 16 in
206
let encoder = Base64_rfc2045.encoder (`Buffer res) in
207
String.iter
208
-
(fun chr -> match Base64_rfc2045.encode encoder (`Char chr) with
209
| `Ok -> ()
210
-
| `Partial -> Alcotest.failf "Retrieve impossible case for (`Char %02x): `Partial" (Char.code chr))
211
x ;
212
match Base64_rfc2045.encode encoder `End with
213
| `Ok -> Buffer.contents res
214
| `Partial -> Alcotest.fail "Retrieve impossible case for `End: `Partial"
215
216
let test_strict_with_malformed_input_rfc2045 =
217
-
List.mapi (fun i (has, _) ->
218
-
Alcotest.test_case (Fmt.strf "strict rfc2045 - %02d" i) `Quick @@ fun () ->
219
try
220
let _ = strict_base64_rfc2045_of_string has in
221
Alcotest.failf "Strict parser valids malformed input: %S" has
222
-
with Malformed | Wrong_padding -> () )
223
test_relaxed_rfc2045
224
225
let test_strict_rfc2045 =
226
-
List.mapi (fun i (has, expect) ->
227
-
Alcotest.test_case (Fmt.strf "strict rfc2045 - %02d" i) `Quick @@ fun () ->
228
try
229
let res0 = strict_base64_rfc2045_of_string has in
230
let res1 = strict_base64_rfc2045_to_string res0 in
···
234
test_strict_rfc2045
235
236
let test_relaxed_rfc2045 =
237
-
List.mapi (fun i (has, expect) ->
238
-
Alcotest.test_case (Fmt.strf "relaxed rfc2045 - %02d" i) `Quick @@ fun () ->
239
let res0 = relaxed_base64_rfc2045_of_string has in
240
Alcotest.(check string) "decode(x)" res0 expect)
241
test_relaxed_rfc2045
242
243
-
let test_invariants = [ "Alphabet size", `Quick, alphabet_size ]
244
-
let test_codec = [ "RFC4648 test vectors", `Quick, test_rfc4648
245
-
; "RFC3548 test vectors", `Quick, test_rfc3548
246
-
; "Hannes test vectors", `Quick, test_hannes
247
-
; "Cfcs test vectors", `Quick, test_cfcs
248
-
; "PHP test vectors", `Quick, test_php
249
-
; "Nocrypto test vectors", `Quick, test_nocrypto ]
250
251
-
let () =
252
-
Alcotest.run "Base64" [
253
-
"invariants", test_invariants;
254
-
"codec", test_codec;
255
-
"rfc2045 (0)", test_strict_rfc2045;
256
-
"rfc2045 (1)", test_strict_with_malformed_input_rfc2045;
257
-
"rfc2045 (2)", test_relaxed_rfc2045;
258
]
259
···
28
BASE64("foobar") = "Zm9vYmFy"
29
*)
30
31
+
let rfc4648_tests =
32
+
[
33
+
("", "");
34
+
("f", "Zg==");
35
+
("fo", "Zm8=");
36
+
("foo", "Zm9v");
37
+
("foob", "Zm9vYg==");
38
+
("fooba", "Zm9vYmE=");
39
+
("foobar", "Zm9vYmFy");
40
+
]
41
42
+
let hannes_tests =
43
+
[
44
+
("dummy", "ZHVtbXk=");
45
+
("dummy", "ZHVtbXk");
46
+
("dummy", "ZHVtbXk==");
47
+
("dummy", "ZHVtbXk===");
48
+
("dummy", "ZHVtbXk====");
49
+
("dummy", "ZHVtbXk=====");
50
+
("dummy", "ZHVtbXk======");
51
+
]
52
53
+
let php_tests =
54
+
[
55
+
( "πάντα χωρεῖ καὶ οὐδὲν μένει …",
56
+
"z4DOrM69z4TOsSDPh8-Jz4HOteG_liDOus6x4b22IM6_4b2QzrThvbLOvSDOvM6tzr3Otc65IOKApg"
57
+
);
58
+
]
59
60
+
let rfc3548_tests =
61
+
[
62
+
("\x14\xfb\x9c\x03\xd9\x7e", "FPucA9l+");
63
+
("\x14\xfb\x9c\x03\xd9", "FPucA9k=");
64
+
("\x14\xfb\x9c\x03", "FPucAw==");
65
+
]
66
67
+
let cfcs_tests =
68
+
[
69
+
(0, 2, "\004", "BB");
70
+
(1, 2, "\004", "ABB");
71
+
(1, 2, "\004", "ABBA");
72
+
(2, 2, "\004", "AABBA");
73
+
(2, 2, "\004", "AABBAA");
74
+
(0, 0, "", "BB");
75
+
(1, 0, "", "BB");
76
+
(2, 0, "", "BB");
77
+
]
78
79
let nocrypto_tests =
80
+
[
81
+
("\x00\x5a\x6d\x39\x76", None);
82
+
("\x5a\x6d\x39\x76", Some "\x66\x6f\x6f");
83
+
("\x5a\x6d\x39\x76\x76", None);
84
+
("\x5a\x6d\x39\x76\x76\x76", None);
85
+
("\x5a\x6d\x39\x76\x76\x76\x76", None);
86
+
("\x5a\x6d\x39\x76\x00", None);
87
+
("\x5a\x6d\x39\x76\x62\x77\x3d\x3d", Some "\x66\x6f\x6f\x6f");
88
+
("\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00", None);
89
+
("\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01", None);
90
+
("\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01\x02", None);
91
+
("\x5a\x6d\x39\x76\x62\x77\x3d\x3d\x00\x01\x02\x03", None);
92
+
("\x5a\x6d\x39\x76\x62\x32\x38\x3d", Some "\x66\x6f\x6f\x6f\x6f");
93
+
("\x5a\x6d\x39\x76\x62\x32\x39\x76", Some "\x66\x6f\x6f\x6f\x6f\x6f");
94
+
("YWE=", Some "aa");
95
+
("YWE==", None);
96
+
("YWE===", None);
97
+
("YWE=====", None);
98
+
("YWE======", None);
99
+
]
100
101
let alphabet_size () =
102
+
List.iter
103
+
(fun (name, alphabet) ->
104
+
Alcotest.(check int)
105
+
(sprintf "Alphabet size %s = 64" name)
106
+
64
107
+
(Base64.length_alphabet alphabet))
108
+
[
109
+
("default", Base64.default_alphabet);
110
+
("uri_safe", Base64.uri_safe_alphabet);
111
+
]
112
113
(* Encode using OpenSSL `base64` utility *)
114
let openssl_encode buf =
115
+
Bos.(
116
+
OS.Cmd.in_string buf
117
+
|> OS.Cmd.run_io (Cmd.v "base64")
118
+
|> OS.Cmd.to_string ~trim:true)
119
+
|> function
120
+
| Ok r ->
121
+
prerr_endline r ;
122
+
r
123
+
| Error (`Msg e) -> raise (Failure (sprintf "OpenSSL decode: %s" e))
124
125
(* Encode using this library *)
126
+
let lib_encode buf = Base64.encode_exn ~pad:true buf
127
128
let test_rfc4648 () =
129
+
List.iter
130
+
(fun (c, r) ->
131
+
(* Base64 vs openssl *)
132
+
Alcotest.(check string)
133
+
(sprintf "encode %s" c) (openssl_encode c) (lib_encode c) ;
134
+
(* Base64 vs test cases above *)
135
+
Alcotest.(check string) (sprintf "encode rfc4648 %s" c) r (lib_encode c) ;
136
+
(* Base64 decode vs library *)
137
+
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn r))
138
+
rfc4648_tests
139
140
let test_rfc3548 () =
141
+
List.iter
142
+
(fun (c, r) ->
143
+
(* Base64 vs openssl *)
144
+
Alcotest.(check string)
145
+
(sprintf "encode %s" c) (openssl_encode c) (lib_encode c) ;
146
+
(* Base64 vs test cases above *)
147
+
Alcotest.(check string) (sprintf "encode rfc3548 %s" c) r (lib_encode c) ;
148
+
(* Base64 decode vs library *)
149
+
Alcotest.(check string) (sprintf "decode %s" r) c (Base64.decode_exn r))
150
+
rfc3548_tests
151
152
let test_hannes () =
153
+
List.iter
154
+
(fun (c, r) ->
155
+
(* Base64 vs test cases above *)
156
+
Alcotest.(check string)
157
+
(sprintf "decode %s" r) c
158
+
(Base64.decode_exn ~pad:false r))
159
+
hannes_tests
160
161
let test_php () =
162
+
List.iter
163
+
(fun (c, r) ->
164
+
Alcotest.(check string)
165
+
(sprintf "decode %s" r) c
166
+
(Base64.decode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet r))
167
+
php_tests
168
169
let test_cfcs () =
170
+
List.iter
171
+
(fun (off, len, c, r) ->
172
+
Alcotest.(check string)
173
+
(sprintf "decode %s" r) c
174
+
(Base64.decode_exn ~pad:false ~off ~len r))
175
+
cfcs_tests
176
177
let test_nocrypto () =
178
+
List.iter
179
+
(fun (input, res) ->
180
+
let res' =
181
+
match Base64.decode ~pad:true input with
182
+
| Ok v -> Some v
183
+
| Error _ -> None in
184
+
Alcotest.(check (option string)) (sprintf "decode %S" input) res' res)
185
+
nocrypto_tests
186
187
exception Malformed
188
+
189
exception Wrong_padding
190
191
let strict_base64_rfc2045_of_string x =
192
let decoder = Base64_rfc2045.decoder (`String x) in
193
let res = Buffer.create 16 in
194
195
+
let rec go () =
196
+
match Base64_rfc2045.decode decoder with
197
+
| `End -> ()
198
+
| `Wrong_padding -> raise Wrong_padding
199
+
| `Malformed _ -> raise Malformed
200
+
| `Flush x ->
201
+
Buffer.add_string res x ;
202
+
go ()
203
+
| `Await -> Alcotest.failf "Retrieve impossible case: `Await" in
204
205
Base64_rfc2045.src decoder (Bytes.unsafe_of_string x) 0 (String.length x) ;
206
+
go () ;
207
+
Buffer.contents res
208
209
let relaxed_base64_rfc2045_of_string x =
210
let decoder = Base64_rfc2045.decoder (`String x) in
211
let res = Buffer.create 16 in
212
213
+
let rec go () =
214
+
match Base64_rfc2045.decode decoder with
215
+
| `End -> ()
216
+
| `Wrong_padding -> go ()
217
+
| `Malformed _ -> go ()
218
+
| `Flush x ->
219
+
Buffer.add_string res x ;
220
+
go ()
221
+
| `Await -> Alcotest.failf "Retrieve impossible case: `Await" in
222
223
Base64_rfc2045.src decoder (Bytes.unsafe_of_string x) 0 (String.length x) ;
224
+
go () ;
225
+
Buffer.contents res
226
227
let test_strict_rfc2045 =
228
+
[
229
+
( "c2FsdXQgbGVzIGNvcGFpbnMgZmF1dCBhYnNvbHVtZW50IHF1ZSBqZSBkw6lwYXNzZSBsZXMgODAg\r\n\
230
+
Y2hhcmFjdGVycyBwb3VyIHZvaXIgc2kgbW9uIGVuY29kZXIgZml0cyBiaWVuIGRhbnMgbGVzIGxp\r\n\
231
+
bWl0ZXMgZGUgbGEgUkZDIDIwNDUgLi4u",
232
+
"salut les copains faut absolument que je dépasse les 80 characters \
233
+
pour voir si mon encoder fits bien dans les limites de la RFC 2045 ..."
234
+
);
235
+
("", "");
236
+
("Zg==", "f");
237
+
("Zm8=", "fo");
238
+
("Zm9v", "foo");
239
+
("Zm9vYg==", "foob");
240
+
("Zm9vYmE=", "fooba");
241
+
("Zm9vYmFy", "foobar");
242
+
]
243
244
let test_relaxed_rfc2045 =
245
+
[
246
+
("Zg", "f");
247
+
("Zm\n8", "fo");
248
+
("Zm\r9v", "foo");
249
+
("Zm9 vYg", "foob");
250
+
("Zm9\r\n vYmE", "fooba");
251
+
("Zm9évYmFy", "foobar");
252
+
]
253
254
let strict_base64_rfc2045_to_string x =
255
let res = Buffer.create 16 in
256
let encoder = Base64_rfc2045.encoder (`Buffer res) in
257
String.iter
258
+
(fun chr ->
259
+
match Base64_rfc2045.encode encoder (`Char chr) with
260
| `Ok -> ()
261
+
| `Partial ->
262
+
Alcotest.failf "Retrieve impossible case for (`Char %02x): `Partial"
263
+
(Char.code chr))
264
x ;
265
match Base64_rfc2045.encode encoder `End with
266
| `Ok -> Buffer.contents res
267
| `Partial -> Alcotest.fail "Retrieve impossible case for `End: `Partial"
268
269
let test_strict_with_malformed_input_rfc2045 =
270
+
List.mapi
271
+
(fun i (has, _) ->
272
+
Alcotest.test_case (Fmt.strf "strict rfc2045 - %02d" i) `Quick
273
+
@@ fun () ->
274
try
275
let _ = strict_base64_rfc2045_of_string has in
276
Alcotest.failf "Strict parser valids malformed input: %S" has
277
+
with Malformed | Wrong_padding -> ())
278
test_relaxed_rfc2045
279
280
let test_strict_rfc2045 =
281
+
List.mapi
282
+
(fun i (has, expect) ->
283
+
Alcotest.test_case (Fmt.strf "strict rfc2045 - %02d" i) `Quick
284
+
@@ fun () ->
285
try
286
let res0 = strict_base64_rfc2045_of_string has in
287
let res1 = strict_base64_rfc2045_to_string res0 in
···
291
test_strict_rfc2045
292
293
let test_relaxed_rfc2045 =
294
+
List.mapi
295
+
(fun i (has, expect) ->
296
+
Alcotest.test_case (Fmt.strf "relaxed rfc2045 - %02d" i) `Quick
297
+
@@ fun () ->
298
let res0 = relaxed_base64_rfc2045_of_string has in
299
Alcotest.(check string) "decode(x)" res0 expect)
300
test_relaxed_rfc2045
301
302
+
let test_invariants = [ ("Alphabet size", `Quick, alphabet_size) ]
303
304
+
let test_codec =
305
+
[
306
+
("RFC4648 test vectors", `Quick, test_rfc4648);
307
+
("RFC3548 test vectors", `Quick, test_rfc3548);
308
+
("Hannes test vectors", `Quick, test_hannes);
309
+
("Cfcs test vectors", `Quick, test_cfcs);
310
+
("PHP test vectors", `Quick, test_php);
311
+
("Nocrypto test vectors", `Quick, test_nocrypto);
312
]
313
314
+
let () =
315
+
Alcotest.run "Base64"
316
+
[
317
+
("invariants", test_invariants);
318
+
("codec", test_codec);
319
+
("rfc2045 (0)", test_strict_rfc2045);
320
+
("rfc2045 (1)", test_strict_with_malformed_input_rfc2045);
321
+
("rfc2045 (2)", test_relaxed_rfc2045);
322
+
]