anil.recoil.org
forked from
gazagnaire.org/ocaml-crypto
upstream: https://github.com/mirage/mirage-crypto
1open Uncommon
2
3let block_size = 16
4let flags bit6 len1 len2 = (bit6 lsl 6) + (len1 lsl 3) + len2
5
6let encode_len buf ~off size value =
7 let rec ass num = function
8 | 0 -> Bytes.set_uint8 buf off num
9 | m ->
10 Bytes.set_uint8 buf (off + m) (num land 0xff);
11 (ass [@tailcall]) (num lsr 8) (pred m)
12 in
13 ass value (pred size)
14
15let set_format buf ?(off = 0) nonce flag_val value =
16 let n = String.length nonce in
17 let small_q = 15 - n in
18 (* first octet block:
19 0 : flags
20 1..15 - q : N
21 16 - q..15 : Q *)
22 Bytes.set_uint8 buf off flag_val;
23 Bytes.unsafe_blit_string nonce 0 buf (off + 1) n;
24 encode_len buf ~off:(off + n + 1) small_q value
25
26let gen_adata a =
27 let llen, set_llen =
28 match String.length a with
29 | x when x < (1 lsl 16) - (1 lsl 8) ->
30 (2, fun buf off -> Bytes.set_uint16_be buf off x)
31 | x when Sys.int_size < 32 || x < 1 lsl 32 ->
32 ( 6,
33 fun buf off ->
34 Bytes.set_uint16_be buf off 0xfffe;
35 Bytes.set_int32_be buf (off + 2) (Int32.of_int x) )
36 | x ->
37 ( 10,
38 fun buf off ->
39 Bytes.set_uint16_be buf off 0xffff;
40 Bytes.set_int64_be buf (off + 2) (Int64.of_int x) )
41 in
42 let to_pad =
43 let leftover = (llen + String.length a) mod block_size in
44 block_size - leftover
45 in
46 ( llen + String.length a + to_pad,
47 fun buf off ->
48 set_llen buf off;
49 Bytes.unsafe_blit_string a 0 buf (off + llen) (String.length a);
50 Bytes.unsafe_fill buf (off + llen + String.length a) to_pad '\000' )
51
52let gen_ctr nonce i =
53 let n = String.length nonce in
54 let small_q = 15 - n in
55 let flag_val = flags 0 0 (small_q - 1) in
56 let buf = Bytes.create 16 in
57 set_format buf nonce flag_val i;
58 buf
59
60let prepare_header nonce adata plen tlen =
61 let small_q = 15 - String.length nonce in
62 let b6 = if String.length adata = 0 then 0 else 1 in
63 let flag_val = flags b6 ((tlen - 2) / 2) (small_q - 1) in
64 if String.length adata = 0 then (
65 let hdr = Bytes.create 16 in
66 set_format hdr nonce flag_val plen;
67 hdr)
68 else
69 let len, set = gen_adata adata in
70 let buf = Bytes.create (16 + len) in
71 set_format buf nonce flag_val plen;
72 set buf 16;
73 buf
74
75type mode = Encrypt | Decrypt
76
77let crypto_core_into ~cipher ~mode ~key ~nonce ~adata src ~src_off dst ~dst_off
78 len =
79 let cbcheader = prepare_header nonce adata len block_size in
80
81 let small_q = 15 - String.length nonce in
82 let ctr_flag_val = flags 0 0 (small_q - 1) in
83 let ctrblock i block dst_off =
84 Bytes.set_uint8 block dst_off ctr_flag_val;
85 Bytes.unsafe_blit_string nonce 0 block (dst_off + 1) (String.length nonce);
86 encode_len block ~off:(dst_off + String.length nonce + 1) small_q i;
87 cipher ~key (Bytes.unsafe_to_string block) ~src_off:dst_off block ~dst_off
88 in
89
90 let cbc iv src_off block dst_off =
91 unsafe_xor_into iv ~src_off block ~dst_off block_size;
92 cipher ~key (Bytes.unsafe_to_string block) ~src_off:dst_off block ~dst_off
93 in
94
95 let iv =
96 let rec doit iv iv_off block block_off =
97 match Bytes.length block - block_off with
98 | 0 -> Bytes.sub iv iv_off block_size
99 | _ ->
100 cbc (Bytes.unsafe_to_string iv) iv_off block block_off;
101 (doit [@tailcall]) block block_off block (block_off + block_size)
102 in
103 doit (Bytes.make block_size '\x00') 0 cbcheader 0
104 in
105
106 let rec loop ctr src src_off dst dst_off len =
107 let cbcblock, cbc_off =
108 match mode with
109 | Encrypt -> (src, src_off)
110 | Decrypt -> (Bytes.unsafe_to_string dst, dst_off)
111 in
112 if len = 0 then ()
113 else if len < block_size then begin
114 let buf = Bytes.make block_size '\x00' in
115 Bytes.unsafe_blit dst dst_off buf 0 len;
116 ctrblock ctr buf 0;
117 Bytes.unsafe_blit buf 0 dst dst_off len;
118 unsafe_xor_into src ~src_off dst ~dst_off len;
119 Bytes.unsafe_blit_string cbcblock cbc_off buf 0 len;
120 Bytes.unsafe_fill buf len (block_size - len) '\x00';
121 cbc (Bytes.unsafe_to_string buf) 0 iv 0
122 end
123 else begin
124 ctrblock ctr dst dst_off;
125 unsafe_xor_into src ~src_off dst ~dst_off block_size;
126 cbc cbcblock cbc_off iv 0;
127 (loop [@tailcall]) (succ ctr) src (src_off + block_size) dst
128 (dst_off + block_size) (len - block_size)
129 end
130 in
131 loop 1 src src_off dst dst_off len;
132 iv
133
134let crypto_core ~cipher ~mode ~key ~nonce ~adata data =
135 let datalen = String.length data in
136 let dst = Bytes.create datalen in
137 let t =
138 crypto_core_into ~cipher ~mode ~key ~nonce ~adata data ~src_off:0 dst
139 ~dst_off:0 datalen
140 in
141 (dst, t)
142
143let crypto_t t nonce cipher key =
144 let ctr = gen_ctr nonce 0 in
145 cipher ~key (Bytes.unsafe_to_string ctr) ~src_off:0 ctr ~dst_off:0;
146 unsafe_xor_into
147 (Bytes.unsafe_to_string ctr)
148 ~src_off:0 t ~dst_off:0 (Bytes.length t)
149
150let unsafe_generation_encryption_into ~cipher ~key ~nonce ~adata src ~src_off
151 dst ~dst_off ~tag_off len =
152 let t =
153 crypto_core_into ~cipher ~mode:Encrypt ~key ~nonce ~adata src ~src_off dst
154 ~dst_off len
155 in
156 crypto_t t nonce cipher key;
157 Bytes.unsafe_blit t 0 dst tag_off block_size
158
159let unsafe_decryption_verification_into ~cipher ~key ~nonce ~adata src ~src_off
160 ~tag_off dst ~dst_off len =
161 let tag = String.sub src tag_off block_size in
162 let t =
163 crypto_core_into ~cipher ~mode:Decrypt ~key ~nonce ~adata src ~src_off dst
164 ~dst_off len
165 in
166 crypto_t t nonce cipher key;
167 Eqaf.equal tag (Bytes.unsafe_to_string t)