gazagnaire.org
upstream: https://github.com/mirage/mirage-crypto
1open Crypto.Uncommon
2open Common
3open Result.Syntax
4
5type pub = { p : Z.t; q : Z.t; gg : Z.t; y : Z.t }
6
7let pub ?(fips = false) ~p ~q ~gg ~y () =
8 let* () = guard Z.(one < gg && gg < p) (`Msg "bad generator") in
9 let* () = guard (Z_extra.pseudoprime q) (`Msg "q is not prime") in
10 let* () =
11 guard (Z.is_odd p && Z_extra.pseudoprime p) (`Msg "p is not prime")
12 in
13 let* () = guard Z.(zero < y && y < p) (`Msg "y not in 0..p-1") in
14 let* () = guard (q < p) (`Msg "q is not smaller than p") in
15 let* () = guard Z.(zero = pred p mod q) (`Msg "p - 1 mod q <> 0") in
16 let* () =
17 if fips then
18 match (Z.numbits p, Z.numbits q) with
19 | 1024, 160 | 2048, 224 | 2048, 256 | 3072, 256 -> Ok ()
20 | _ -> Error (`Msg "bit length of p or q not FIPS specified")
21 else Ok ()
22 in
23 Ok { p; q; gg; y }
24
25type priv = { p : Z.t; q : Z.t; gg : Z.t; x : Z.t; y : Z.t }
26
27let priv ?fips ~p ~q ~gg ~x ~y () =
28 let* _ = pub ?fips ~p ~q ~gg ~y () in
29 let* () = guard Z.(zero < x && x < q) (`Msg "x not in 1..q-1") in
30 let* () = guard Z.(y = powm gg x p) (`Msg "y <> g ^ x mod p") in
31 Ok { p; q; gg; x; y }
32
33let pub_of_priv { p; q; gg; y; _ } = { p; q; gg; y }
34
35type keysize = [ `Fips1024 | `Fips2048 | `Fips3072 | `Exactly of int * int ]
36
37let expand_size = function
38 | `Fips1024 -> (1024, 160)
39 | `Fips2048 -> (2048, 256)
40 | `Fips3072 -> (3072, 256)
41 | `Exactly (l, n) ->
42 if 3 <= l && 2 <= n then (l, n)
43 else invalid_arg "Dsa.generate: bits: `Exactly (%d, %d)" l n
44
45type mask = [ `No | `Yes | `Yes_with of Crypto_rng.g ]
46
47let expand_mask = function
48 | `No -> `No
49 | `Yes -> `Yes None
50 | `Yes_with g -> `Yes (Some g)
51
52(*
53 * FIPS.186-4-style derivation:
54 * - p and q are derived using a method numerically like the one described in
55 * A.1.1.2, adapted to use the native rng.
56 * - g is derived as per A.2.1.
57 *)
58let params ?g size =
59 let two = Z.(~$2) in
60 let l, n = expand_size size in
61 let q = Z_extra.prime ?g ~msb:1 n in
62 let p =
63 let q_q = Z.(q * two) in
64 until Z_extra.pseudoprime @@ fun () ->
65 let x = Z_extra.gen_bits ?g ~msb:1 l in
66 Z.(x - (x mod q_q) + one)
67 in
68 let gg =
69 let e = Z.(pred p / q) in
70 until (( <> ) Z.one) @@ fun () ->
71 let h = Z_extra.gen_r ?g two Z.(pred p) in
72 Z.(powm h e p)
73 in
74 (* all checks above are already satisfied *)
75 (p, q, gg)
76
77let generate ?g size =
78 let p, q, gg = params ?g size in
79 let x = Z_extra.gen_r ?g Z.one q in
80 let y = Z.(powm gg x p) in
81 (* checks are satisfied due to construction *)
82 { p; q; gg; x; y }
83
84module K_gen (H : Digestif.S) = struct
85 let drbg : 'a Crypto_rng.generator =
86 let module M = Crypto_rng.Hmac_drbg (H) in
87 (module M)
88
89 let z_gen ~key:{ q; x; _ } z =
90 let repr = Z_extra.to_octets_be ~size:(Z.numbits q // 8) in
91 let g = Crypto_rng.v ~strict:true drbg in
92 Crypto_rng.reseed ~g (repr x ^ repr Z.(z mod q));
93 Z_extra.gen_r ~g Z.one q
94
95 let generate ~key buf =
96 z_gen ~key (Z_extra.of_octets_be ~bits:(Z.numbits key.q) buf)
97end
98
99module K_gen_sha256 = K_gen (Digestif.SHA256)
100
101let sign_z ?(mask = `Yes) ?k:k0 ~key:({ p; q; gg; x; _ } as key) z =
102 let k = match k0 with Some k -> k | None -> K_gen_sha256.z_gen ~key z in
103 let k' = Z.invert k q
104 and b, b' =
105 match expand_mask mask with
106 | `No -> (Z.one, Z.one)
107 | `Yes g ->
108 let m = Z_extra.gen_r ?g Z.one q in
109 (m, Z.invert m q)
110 in
111 let r = Z.(powm_sec gg k p mod q) in
112 (* normal DSA sign is: s = k^-1 * (z + r * x) mod q *)
113 (* we apply blinding where possible and compute:
114 s = k^-1 * b^-1 * (b * z + b * r * x) mod q
115 see https://github.com/openssl/openssl/pull/6524 for further details *)
116 let s =
117 let t1 =
118 let t11 = Z.(b * x mod q) in
119 Z.(t11 * r mod q)
120 in
121 let t2 = Z.(b * z mod q) in
122 let t3 = Z.((t1 + t2) mod q) in
123 let t4 = Z.(k' * t3 mod q) in
124 Z.(b' * t4 mod q)
125 in
126 if r = Z.zero || s = Z.zero then invalid_arg "k unsuitable" else (r, s)
127
128let verify_z ~key:({ p; q; gg; y } : pub) (r, s) z =
129 let v () =
130 let w = Z.invert s q in
131 let u1 = Z.(z * w mod q) and u2 = Z.(r * w mod q) in
132 Z.(powm gg u1 p * powm y u2 p mod p mod q)
133 in
134 Z.zero < r && r < q && Z.zero < s && s < q && v () = r
135
136let sign ?mask ?k ~(key : priv) digest =
137 let bits = Z.numbits key.q in
138 let size = bits // 8 in
139 let r, s = sign_z ?mask ?k ~key (Z_extra.of_octets_be ~bits digest) in
140 Z_extra.(to_octets_be ~size r, to_octets_be ~size s)
141
142let verify ~(key : pub) (r, s) digest =
143 let z = Z_extra.of_octets_be ~bits:(Z.numbits key.q) digest
144 and r, s = Z_extra.(of_octets_be r, of_octets_be s) in
145 verify_z ~key (r, s) z
146
147let rec shift_left_inplace buf = function
148 | 0 -> ()
149 | bits when bits mod 8 = 0 ->
150 let off = bits / 8 in
151 let to_blit = Bytes.length buf - off in
152 Bytes.unsafe_blit buf off buf 0 to_blit;
153 Bytes.unsafe_fill buf to_blit (Bytes.length buf - to_blit) '\x00'
154 | bits when bits < 8 ->
155 let foo = 8 - bits in
156 for i = 0 to Bytes.length buf - 2 do
157 let b1 = Bytes.get_uint8 buf i and b2 = Bytes.get_uint8 buf (i + 1) in
158 Bytes.set_uint8 buf i ((b1 lsl bits) lor (b2 lsr foo))
159 done;
160 Bytes.set_uint8 buf
161 (Bytes.length buf - 1)
162 (Bytes.get_uint8 buf (Bytes.length buf - 1) lsl bits)
163 | bits ->
164 shift_left_inplace buf (8 * (bits / 8));
165 shift_left_inplace buf (bits mod 8)
166
167let ( lsl ) buf bits =
168 let buf' = Bytes.of_string buf in
169 shift_left_inplace buf' bits;
170 Bytes.unsafe_to_string buf'
171
172let massage ~key:({ q; _ } : pub) digest =
173 let bits = Z.numbits q in
174 if bits >= String.length digest * 8 then digest
175 else
176 let buf = Z_extra.(to_octets_be Z.(of_octets_be digest mod q)) in
177 buf lsl ((8 - (bits mod 8)) mod 8)