236 lines
8.4 KiB
OCaml
236 lines
8.4 KiB
OCaml
(* RFC 4648, Section 7 - Base 32 with extended hex alphabet *)
|
|
|
|
let make_alphabet alphabet =
|
|
if String.length alphabet <> 32
|
|
then invalid_arg "Length of alphabet must be 32" ;
|
|
if String.contains alphabet '='
|
|
then invalid_arg "Alphabet can not contain padding character" ;
|
|
let emap =
|
|
Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i]) in
|
|
let dmap = Array.make 256 (-1) in
|
|
String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet ;
|
|
(emap, dmap)
|
|
|
|
let alphabet = make_alphabet "0123456789ABCDEFGHIJKLMNOPQRSTUV"
|
|
|
|
let pad_char = '='
|
|
let pad_int = int_of_char pad_char
|
|
|
|
let encode ?(pad = true) str =
|
|
let len = String.length str in
|
|
(* since String.get_uint8 is OCaml >= 4.13 only *)
|
|
let str = Bytes.unsafe_of_string str in
|
|
let out_len = (len + 4) / 5 * 8 in
|
|
let out = Bytes.make out_len pad_char in
|
|
let o1 b1 = b1 lsr 3
|
|
and o2 b1 b2 = (b1 land 0x07) lsl 2 + b2 lsr 6
|
|
and o3 b2 = (b2 land 0x3E) lsr 1
|
|
and o4 b2 b3 = ((b2 land 0x01) lsl 4) + b3 lsr 4
|
|
and o5 b3 b4 = (b3 land 0x0F) lsl 1 + b4 lsr 7
|
|
and o6 b4 = (b4 land 0x7c) lsr 2
|
|
and o7 b4 b5 = (b4 land 0x03) lsl 3 + b5 lsr 5
|
|
and o8 b5 = b5 land 0x1F
|
|
in
|
|
let emit b1 b2 b3 b4 b5 off =
|
|
List.iteri (fun idx v -> Bytes.set_uint8 out (off + idx) ((fst alphabet).(v)))
|
|
[ o1 b1; o2 b1 b2; o3 b2; o4 b2 b3; o5 b3 b4; o6 b4; o7 b4 b5; o8 b5 ]
|
|
in
|
|
let rec enc s_off d_off =
|
|
if s_off = len then
|
|
(* case 1 *) 0
|
|
else if s_off = len - 1 then
|
|
(* case 2 - 6 padding = *)
|
|
let b1 = Bytes.get_uint8 str s_off in
|
|
let p1 = o1 b1 and p2 = o2 b1 0 in
|
|
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
|
|
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
|
|
6
|
|
else if s_off = len - 2 then
|
|
(* case 3 - 4 padding = *)
|
|
let b1 = Bytes.get_uint8 str s_off
|
|
and b2 = Bytes.get_uint8 str (s_off + 1)
|
|
in
|
|
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 0 in
|
|
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
|
|
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
|
|
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
|
|
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
|
|
4
|
|
else if s_off = len - 3 then
|
|
(* case 4 - 3 padding = *)
|
|
let b1 = Bytes.get_uint8 str s_off
|
|
and b2 = Bytes.get_uint8 str (s_off + 1)
|
|
and b3 = Bytes.get_uint8 str (s_off + 2)
|
|
in
|
|
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 b3 and p5 = o5 b3 0 in
|
|
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
|
|
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
|
|
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
|
|
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
|
|
Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5));
|
|
3
|
|
else if s_off = len - 4 then
|
|
(* case 5 - 1 padding = *)
|
|
let b1 = Bytes.get_uint8 str s_off
|
|
and b2 = Bytes.get_uint8 str (s_off + 1)
|
|
and b3 = Bytes.get_uint8 str (s_off + 2)
|
|
and b4 = Bytes.get_uint8 str (s_off + 3)
|
|
in
|
|
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 b3 and p5 = o5 b3 b4 and p6 = o6 b4 and p7 = o7 b4 0 in
|
|
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
|
|
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
|
|
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
|
|
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
|
|
Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5));
|
|
Bytes.set_uint8 out (d_off + 5) ((fst alphabet).(p6));
|
|
Bytes.set_uint8 out (d_off + 6) ((fst alphabet).(p7));
|
|
1
|
|
else
|
|
let b1 = Bytes.get_uint8 str s_off in
|
|
let b2 = Bytes.get_uint8 str (s_off + 1) in
|
|
let b3 = Bytes.get_uint8 str (s_off + 2) in
|
|
let b4 = Bytes.get_uint8 str (s_off + 3) in
|
|
let b5 = Bytes.get_uint8 str (s_off + 4) in
|
|
emit b1 b2 b3 b4 b5 d_off;
|
|
enc (s_off + 5) (d_off + 8)
|
|
in
|
|
let padding_bytes = enc 0 0 in
|
|
let out_s = Bytes.unsafe_to_string out in
|
|
if pad then out_s else String.sub out_s 0 (out_len - padding_bytes)
|
|
|
|
(* RFC 4648 section 10
|
|
BASE32-HEX("") = ""
|
|
BASE32-HEX("f") = "CO======"
|
|
BASE32-HEX("fo") = "CPNG===="
|
|
BASE32-HEX("foo") = "CPNMU==="
|
|
BASE32-HEX("foob") = "CPNMUOG="
|
|
BASE32-HEX("fooba") = "CPNMUOJ1"
|
|
BASE32-HEX("foobar") = "CPNMUOJ1E8======"
|
|
*)
|
|
|
|
let decode ?(unpadded = false) str =
|
|
let ( let* ) = Result.bind in
|
|
let* str =
|
|
let lmod8 = String.length str mod 8 in
|
|
if lmod8 > 0 then
|
|
if unpadded then
|
|
Ok (str ^ String.make (8 - lmod8) pad_char)
|
|
else
|
|
Error (`Msg "invalid input length (not divisible by 8)")
|
|
else
|
|
Ok str
|
|
in
|
|
let len = String.length str in
|
|
let str = Bytes.unsafe_of_string str in
|
|
let out_len = len / 8 * 5 in (* max length *)
|
|
let out = Bytes.create out_len in
|
|
let o1 b1 b2 = b1 lsl 3 + b2 lsr 2
|
|
and o2 b2 b3 b4 = (b2 land 0x03) lsl 6 + b3 lsl 1 + b4 lsr 4
|
|
and o3 b4 b5 = (b4 land 0x0F) lsl 4 + b5 lsr 1
|
|
and o4 b5 b6 b7 = (b5 land 0x01) lsl 7 + b6 lsl 2 + b7 lsr 3
|
|
and o5 b7 b8 = (b7 land 0x07) lsl 5 + b8
|
|
in
|
|
let c ~off idx =
|
|
let r = (snd alphabet).(idx) in
|
|
if r = -1 then
|
|
Error (`Msg ("bad encoding at " ^ string_of_int off))
|
|
else
|
|
Ok r
|
|
in
|
|
let emit s_off v1 v2 v3 v4 v5 v6 v7 v8 off =
|
|
let* b1 = c ~off:s_off v1 in
|
|
let* b2 = c ~off:(s_off + 1) v2 in
|
|
let* b3 = c ~off:(s_off + 2) v3 in
|
|
let* b4 = c ~off:(s_off + 3) v4 in
|
|
let* b5 = c ~off:(s_off + 4) v5 in
|
|
let* b6 = c ~off:(s_off + 5) v6 in
|
|
let* b7 = c ~off:(s_off + 6) v7 in
|
|
let* b8 = c ~off:(s_off + 7) v8 in
|
|
Bytes.set_uint8 out off (o1 b1 b2);
|
|
Bytes.set_uint8 out (off + 1) (o2 b2 b3 b4);
|
|
Bytes.set_uint8 out (off + 2) (o3 b4 b5);
|
|
Bytes.set_uint8 out (off + 3) (o4 b5 b6 b7);
|
|
Bytes.set_uint8 out (off + 4) (o5 b7 b8);
|
|
Ok ()
|
|
in
|
|
let rec dec s_off d_off =
|
|
if s_off = len then
|
|
Ok (0, 0)
|
|
else
|
|
let v1 = Bytes.get_uint8 str s_off
|
|
and v2 = Bytes.get_uint8 str (s_off + 1)
|
|
and v3 = Bytes.get_uint8 str (s_off + 2)
|
|
and v4 = Bytes.get_uint8 str (s_off + 3)
|
|
and v5 = Bytes.get_uint8 str (s_off + 4)
|
|
and v6 = Bytes.get_uint8 str (s_off + 5)
|
|
and v7 = Bytes.get_uint8 str (s_off + 6)
|
|
and v8 = Bytes.get_uint8 str (s_off + 7)
|
|
in
|
|
if v3 = pad_int then
|
|
let* b1 = c ~off:s_off v1 in
|
|
let* b2 = c ~off:(s_off + 1) v2 in
|
|
let p1 = o1 b1 b2 in
|
|
Bytes.set_uint8 out d_off p1;
|
|
Ok (6, 4)
|
|
else if v5 = pad_int then
|
|
let* b1 = c ~off:s_off v1 in
|
|
let* b2 = c ~off:(s_off + 1) v2 in
|
|
let* b3 = c ~off:(s_off + 2) v3 in
|
|
let* b4 = c ~off:(s_off + 3) v4 in
|
|
let p1 = o1 b1 b2
|
|
and p2 = o2 b2 b3 b4
|
|
in
|
|
Bytes.set_uint8 out d_off p1;
|
|
Bytes.set_uint8 out (d_off + 1) p2;
|
|
Ok (4, 3)
|
|
else if v6 = pad_int then
|
|
let* b1 = c ~off:s_off v1 in
|
|
let* b2 = c ~off:(s_off + 1) v2 in
|
|
let* b3 = c ~off:(s_off + 2) v3 in
|
|
let* b4 = c ~off:(s_off + 3) v4 in
|
|
let* b5 = c ~off:(s_off + 4) v5 in
|
|
let p1 = o1 b1 b2
|
|
and p2 = o2 b2 b3 b4
|
|
and p3 = o3 b4 b5
|
|
in
|
|
Bytes.set_uint8 out d_off p1;
|
|
Bytes.set_uint8 out (d_off + 1) p2;
|
|
Bytes.set_uint8 out (d_off + 2) p3;
|
|
Ok (3, 2)
|
|
else if v8 = pad_int then
|
|
let* b1 = c ~off:s_off v1 in
|
|
let* b2 = c ~off:(s_off + 1) v2 in
|
|
let* b3 = c ~off:(s_off + 2) v3 in
|
|
let* b4 = c ~off:(s_off + 3) v4 in
|
|
let* b5 = c ~off:(s_off + 4) v5 in
|
|
let* b6 = c ~off:(s_off + 5) v6 in
|
|
let* b7 = c ~off:(s_off + 6) v7 in
|
|
let p1 = o1 b1 b2
|
|
and p2 = o2 b2 b3 b4
|
|
and p3 = o3 b4 b5
|
|
and p4 = o4 b5 b6 b7
|
|
in
|
|
Bytes.set_uint8 out d_off p1;
|
|
Bytes.set_uint8 out (d_off + 1) p2;
|
|
Bytes.set_uint8 out (d_off + 2) p3;
|
|
Bytes.set_uint8 out (d_off + 3) p4;
|
|
Ok (1, 1)
|
|
else
|
|
let* () = emit s_off v1 v2 v3 v4 v5 v6 v7 v8 d_off in
|
|
dec (s_off + 8) (d_off + 5)
|
|
in
|
|
let* (pad_bytes, to_remove) = dec 0 0 in
|
|
let rec check_pad = function
|
|
| 0 -> Ok ()
|
|
| n ->
|
|
if Bytes.get_uint8 str (len - n) = pad_int then
|
|
check_pad (n - 1)
|
|
else
|
|
Error (`Msg ("expected pad character at " ^ (string_of_int (len - n))))
|
|
in
|
|
let* () = check_pad pad_bytes in
|
|
let out_str = Bytes.unsafe_to_string out in
|
|
if to_remove > 0 then
|
|
Ok (String.sub out_str 0 (out_len - to_remove))
|
|
else
|
|
Ok out_str
|