anil.recoil.org
forked from
gazagnaire.org/ocaml-crypto
upstream: https://github.com/mirage/mirage-crypto
1type error =
2 [ `Invalid_format
3 | `Invalid_length
4 | `Invalid_range
5 | `Not_on_curve
6 | `At_infinity
7 | `Low_order ]
8
9let error_to_string = function
10 | `Invalid_format -> "invalid format"
11 | `Not_on_curve -> "point is not on curve"
12 | `At_infinity -> "point is at infinity"
13 | `Invalid_length -> "invalid length"
14 | `Invalid_range -> "invalid range"
15 | `Low_order -> "low order"
16
17let pp_error fmt e =
18 Format.fprintf fmt "Cannot parse point: %s" (error_to_string e)
19
20let rev_string buf =
21 let len = String.length buf in
22 let res = Bytes.create len in
23 for i = 0 to len - 1 do
24 Bytes.set res (len - 1 - i) (String.get buf i)
25 done;
26 Bytes.unsafe_to_string res
27
28exception Message_too_long
29
30let bit_at buf i =
31 let byte_num = i / 8 in
32 let bit_num = i mod 8 in
33 let byte = String.get_uint8 buf byte_num in
34 byte land (1 lsl bit_num) <> 0
35
36module type Dh = sig
37 type secret
38
39 val secret_of_octets :
40 ?compress:bool -> string -> (secret * string, error) result
41
42 val secret_to_octets : secret -> string
43 val gen_key : ?compress:bool -> ?g:Crypto_rng.g -> unit -> secret * string
44 val key_exchange : secret -> string -> (string, error) result
45end
46
47module type Dsa = sig
48 type priv
49 type pub
50
51 val byte_length : int
52 val bit_length : int
53 val priv_of_octets : string -> (priv, error) result
54 val priv_to_octets : priv -> string
55 val pub_of_octets : string -> (pub, error) result
56 val pub_to_octets : ?compress:bool -> pub -> string
57 val pub_of_priv : priv -> pub
58 val generate : ?g:Crypto_rng.g -> unit -> priv * pub
59 val sign : key:priv -> ?k:string -> string -> string * string
60 val verify : key:pub -> string * string -> string -> bool
61
62 module K_gen (H : Digestif.S) : sig
63 val generate : key:priv -> string -> string
64 end
65
66 module Precompute : sig
67 val generator_tables : unit -> string array array array
68 end
69end
70
71module type Point = sig
72 type point
73 type scalar
74
75 val of_octets : string -> (point, error) result
76 val to_octets : ?compress:bool -> point -> string
77 val scalar_of_octets : string -> (scalar, error) result
78 val scalar_to_octets : scalar -> string
79 val generator : point
80 val add : point -> point -> point
81 val scalar_mult : scalar -> point -> point
82end
83
84module type Dh_dsa = sig
85 module Dh : Dh
86 module Dsa : Dsa
87 module Point : Point
88end
89
90type field_element = string
91type out_field_element = bytes
92
93module type Parameters = sig
94 val a : field_element
95 val b : field_element
96 val g_x : field_element
97 val g_y : field_element
98 val p : field_element
99 val n : field_element
100 val pident : string
101 val byte_length : int
102 val bit_length : int
103 val fe_length : int
104 val first_byte_bits : int option
105end
106
107type point = { f_x : field_element; f_y : field_element; f_z : field_element }
108
109type out_point = {
110 m_f_x : out_field_element;
111 m_f_y : out_field_element;
112 m_f_z : out_field_element;
113}
114
115type scalar = Scalar of string
116
117module type Foreign = sig
118 val mul : out_field_element -> field_element -> field_element -> unit
119 val sub : out_field_element -> field_element -> field_element -> unit
120 val add : out_field_element -> field_element -> field_element -> unit
121 val to_montgomery : out_field_element -> field_element -> unit
122 val from_octets : out_field_element -> string -> unit
123 val set_one : out_field_element -> unit
124 val nz : field_element -> bool
125 val sqr : out_field_element -> field_element -> unit
126 val from_montgomery : out_field_element -> field_element -> unit
127 val to_octets : bytes -> field_element -> unit
128 val inv : out_field_element -> field_element -> unit
129
130 val select_c :
131 out_field_element -> bool -> field_element -> field_element -> unit
132
133 val double_c : out_point -> point -> unit
134 val add_c : out_point -> point -> point -> unit
135 val scalar_mult_base_c : out_point -> string -> unit
136end
137
138module type Field_element = sig
139 val mul : field_element -> field_element -> field_element
140 val sub : field_element -> field_element -> field_element
141 val add : field_element -> field_element -> field_element
142 val from_montgomery : field_element -> field_element
143 val zero : field_element
144 val one : field_element
145 val nz : field_element -> bool
146 val sqr : field_element -> field_element
147 val inv : field_element -> field_element
148
149 val select :
150 bool -> then_:field_element -> else_:field_element -> field_element
151
152 val from_be_octets : string -> field_element
153 val to_octets : field_element -> string
154 val double_point : point -> point
155 val add_point : point -> point -> point
156 val scalar_mult_base_point : scalar -> point
157end
158
159module Make_field_element (P : Parameters) (F : Foreign) : Field_element =
160struct
161 let b_uts b = Bytes.unsafe_to_string b
162 let create () = Bytes.create P.fe_length
163
164 let mul a b =
165 let tmp = create () in
166 F.mul tmp a b;
167 b_uts tmp
168
169 let sub a b =
170 let tmp = create () in
171 F.sub tmp a b;
172 b_uts tmp
173
174 let add a b =
175 let tmp = create () in
176 F.add tmp a b;
177 b_uts tmp
178
179 let from_montgomery a =
180 let tmp = create () in
181 F.from_montgomery tmp a;
182 b_uts tmp
183
184 let zero =
185 let b = Bytes.make P.fe_length '\000' in
186 b_uts b
187
188 let one =
189 let fe = create () in
190 F.set_one fe;
191 b_uts fe
192
193 let nz a = F.nz a
194
195 let sqr a =
196 let tmp = create () in
197 F.sqr tmp a;
198 b_uts tmp
199
200 let inv a =
201 let tmp = create () in
202 F.inv tmp a;
203 b_uts tmp
204
205 let select bit ~then_ ~else_ =
206 let tmp = create () in
207 F.select_c tmp bit then_ else_;
208 b_uts tmp
209
210 let from_be_octets buf =
211 let buf_rev = rev_string buf in
212 let tmp = create () in
213 F.from_octets tmp buf_rev;
214 F.to_montgomery tmp (b_uts tmp);
215 b_uts tmp
216
217 let create_octets () = Bytes.create P.byte_length
218
219 let to_octets fe =
220 let tmp = create_octets () in
221 F.to_octets tmp fe;
222 b_uts tmp
223
224 let out_point () = { m_f_x = create (); m_f_y = create (); m_f_z = create () }
225
226 let out_p_to_p p =
227 { f_x = b_uts p.m_f_x; f_y = b_uts p.m_f_y; f_z = b_uts p.m_f_z }
228
229 let double_point p =
230 let tmp = out_point () in
231 F.double_c tmp p;
232 out_p_to_p tmp
233
234 let add_point a b =
235 let tmp = out_point () in
236 F.add_c tmp a b;
237 out_p_to_p tmp
238
239 let scalar_mult_base_point (Scalar d) =
240 let tmp = out_point () in
241 F.scalar_mult_base_c tmp d;
242 out_p_to_p tmp
243end
244
245module type Point_ops = sig
246 val at_infinity : unit -> point
247 val is_infinity : point -> bool
248 val add : point -> point -> point
249 val double : point -> point
250 val of_octets : string -> (point, error) result
251 val to_octets : compress:bool -> point -> string
252 val to_affine_raw : point -> (field_element * field_element) option
253 val x_of_finite_point : point -> string
254 val params_g : point
255 val select : bool -> then_:point -> else_:point -> point
256 val scalar_mult_base : scalar -> point
257end
258
259module Make_point_ops (P : Parameters) (F : Foreign) : Point_ops = struct
260 module Fe = Make_field_element (P) (F)
261
262 let at_infinity () =
263 let f_x = Fe.one in
264 let f_y = Fe.one in
265 let f_z = Fe.zero in
266 { f_x; f_y; f_z }
267
268 let is_infinity (p : point) = not (Fe.nz p.f_z)
269
270 let is_solution_to_curve_equation =
271 let a = Fe.from_be_octets P.a in
272 let b = Fe.from_be_octets P.b in
273 fun ~x ~y ->
274 let x3 = Fe.mul x x in
275 let x3 = Fe.mul x3 x in
276 let ax = Fe.mul a x in
277 let y2 = Fe.mul y y in
278 let sum = Fe.add x3 ax in
279 let sum = Fe.add sum b in
280 let sum = Fe.sub sum y2 in
281 not (Fe.nz sum)
282
283 let check_coordinate buf =
284 (* ensure buf < p: *)
285 match Eqaf.compare_be_with_len ~len:P.byte_length buf P.p >= 0 with
286 | true -> None
287 | exception Invalid_argument _ -> None
288 | false -> Some (Fe.from_be_octets buf)
289
290 (** Convert coordinates to a finite point ensuring:
291 - x < p
292 - y < p
293 - y^2 = ax^3 + ax + b *)
294 let validate_finite_point ~x ~y =
295 match (check_coordinate x, check_coordinate y) with
296 | Some f_x, Some f_y ->
297 if is_solution_to_curve_equation ~x:f_x ~y:f_y then
298 let f_z = Fe.one in
299 Ok { f_x; f_y; f_z }
300 else Error `Not_on_curve
301 | _ -> Error `Invalid_range
302
303 let to_affine_raw p =
304 if is_infinity p then None
305 else
306 let z1 = Fe.from_montgomery p.f_z in
307 let z2 = Fe.inv z1 in
308 let z1 = Fe.sqr z2 in
309 let z1 = Fe.from_montgomery z1 in
310 let x = Fe.mul p.f_x z1 in
311 let z1 = Fe.mul z1 z2 in
312 let y = Fe.mul p.f_y z1 in
313 Some (x, y)
314
315 let to_affine p =
316 Option.map
317 (fun (x, y) -> (Fe.to_octets x, Fe.to_octets y))
318 (to_affine_raw p)
319
320 let to_octets ~compress p =
321 let buf =
322 match to_affine p with
323 | None -> String.make 1 '\000'
324 | Some (x, y) ->
325 let len_x = String.length x and len_y = String.length y in
326 let res = Bytes.create (1 + len_x + len_y) in
327 Bytes.set res 0 '\004';
328 let rev_x = rev_string x and rev_y = rev_string y in
329 Bytes.unsafe_blit_string rev_x 0 res 1 len_x;
330 Bytes.unsafe_blit_string rev_y 0 res (1 + len_x) len_y;
331 Bytes.unsafe_to_string res
332 in
333 if compress then (
334 let out = Bytes.create (P.byte_length + 1) in
335 let ident = 2 + (String.get_uint8 buf (P.byte_length * 2) land 1) in
336 Bytes.unsafe_blit_string buf 1 out 1 P.byte_length;
337 Bytes.set_uint8 out 0 ident;
338 Bytes.unsafe_to_string out)
339 else buf
340
341 let double p = Fe.double_point p
342 let add p q = Fe.add_point p q
343
344 let x_of_finite_point p =
345 match to_affine p with None -> assert false | Some (x, _) -> rev_string x
346
347 let params_g =
348 match validate_finite_point ~x:P.g_x ~y:P.g_y with
349 | Ok p -> p
350 | Error _ -> assert false
351
352 let select bit ~then_ ~else_ =
353 {
354 f_x = Fe.select bit ~then_:then_.f_x ~else_:else_.f_x;
355 f_y = Fe.select bit ~then_:then_.f_y ~else_:else_.f_y;
356 f_z = Fe.select bit ~then_:then_.f_z ~else_:else_.f_z;
357 }
358
359 let pow x exp =
360 let r0 = ref Fe.one in
361 let r1 = ref x in
362 for i = (P.byte_length * 8) - 1 downto 0 do
363 let bit = bit_at exp i in
364 let multiplied = Fe.mul !r0 !r1 in
365 let r0_sqr = Fe.sqr !r0 in
366 let r1_sqr = Fe.sqr !r1 in
367 r0 := Fe.select bit ~then_:multiplied ~else_:r0_sqr;
368 r1 := Fe.select bit ~then_:r1_sqr ~else_:multiplied
369 done;
370 !r0
371
372 let decompress =
373 (* When p = 4*k+3, as is the case of NIST-P256, there is an efficient square
374 root algorithm to recover the y, as follows:
375
376 Given the compact representation of Q as x,
377 y2 = x^3 + a*x + b
378 y' = y2^((p+1)/4)
379 y = min(y',p-y')
380 Q=(x,y) is the canonical representation of the point
381 *)
382 let pident =
383 P.pident
384 (* (Params.p + 1) / 4*)
385 in
386 let a = Fe.from_be_octets P.a in
387 let b = Fe.from_be_octets P.b in
388 let p = Fe.from_be_octets P.p in
389 fun pk ->
390 let x = Fe.from_be_octets (String.sub pk 1 P.byte_length) in
391 let x3 = Fe.mul x x in
392 let x3 = Fe.mul x3 x in
393 (* x3 *)
394 let ax = Fe.mul a x in
395 (* ax *)
396 let sum = Fe.add x3 ax in
397 let sum = Fe.add sum b in
398 (* y^2 *)
399 let y = pow sum pident in
400 (* https://tools.ietf.org/id/draft-jivsov-ecc-compact-00.xml#sqrt point 4.3*)
401 let y' = Fe.sub p y in
402 let y = Fe.from_montgomery y in
403 let y_struct = Fe.to_octets y in
404 (* number must not be in montgomery domain*)
405 let y_struct = rev_string y_struct in
406 let y' = Fe.from_montgomery y' in
407 let y_struct2 = Fe.to_octets y' in
408 (* number must not be in montgomery domain*)
409 let y_struct2 = rev_string y_struct2 in
410 let ident = String.get_uint8 pk 0 in
411 let signY = 2 + (String.get_uint8 y_struct (P.byte_length - 1) land 1) in
412 let res = if Int.equal signY ident then y_struct else y_struct2 in
413 let out = Bytes.create ((P.byte_length * 2) + 1) in
414 Bytes.set out 0 '\004';
415 Bytes.unsafe_blit_string pk 1 out 1 P.byte_length;
416 Bytes.unsafe_blit_string res 0 out (P.byte_length + 1) P.byte_length;
417 Bytes.unsafe_to_string out
418
419 let of_octets buf =
420 let len = P.byte_length in
421 if String.length buf = 0 then Error `Invalid_format
422 else
423 let of_octets buf =
424 let x = String.sub buf 1 len in
425 let y = String.sub buf (1 + len) len in
426 validate_finite_point ~x ~y
427 in
428 match String.get_uint8 buf 0 with
429 | 0x00 when String.length buf = 1 -> Ok (at_infinity ())
430 | (0x02 | 0x03) when String.length P.pident > 0 ->
431 let decompressed = decompress buf in
432 of_octets decompressed
433 | 0x04 when String.length buf = 1 + len + len -> of_octets buf
434 | 0x00 | 0x04 -> Error `Invalid_length
435 | _ -> Error `Invalid_format
436
437 let scalar_mult_base = Fe.scalar_mult_base_point
438end
439
440module type Scalar = sig
441 val not_zero : string -> bool
442 val is_in_range : string -> bool
443 val of_octets : string -> (scalar, error) result
444 val to_octets : scalar -> string
445 val scalar_mult : scalar -> point -> point
446 val scalar_mult_base : scalar -> point
447 val generator_tables : unit -> field_element array array array
448end
449
450module Make_scalar (Param : Parameters) (P : Point_ops) : Scalar = struct
451 let not_zero =
452 let zero = String.make Param.byte_length '\000' in
453 fun buf -> not (Eqaf.equal buf zero)
454
455 let is_in_range buf =
456 not_zero buf
457 && Eqaf.compare_be_with_len ~len:Param.byte_length Param.n buf > 0
458
459 let of_octets buf =
460 match is_in_range buf with
461 | exception Invalid_argument _ -> Error `Invalid_length
462 | true -> Ok (Scalar (rev_string buf))
463 | false -> Error `Invalid_range
464
465 let to_octets (Scalar buf) = rev_string buf
466
467 (* Branchless Montgomery ladder method *)
468 let scalar_mult (Scalar s) p =
469 let r0 = ref (P.at_infinity ()) in
470 let r1 = ref p in
471 for i = (Param.byte_length * 8) - 1 downto 0 do
472 let bit = bit_at s i in
473 let sum = P.add !r0 !r1 in
474 let r0_double = P.double !r0 in
475 let r1_double = P.double !r1 in
476 r0 := P.select bit ~then_:sum ~else_:r0_double;
477 r1 := P.select bit ~then_:r1_double ~else_:sum
478 done;
479 !r0
480
481 (* Specialization of [scalar_mult d p] when [p] is the generator *)
482 let scalar_mult_base = P.scalar_mult_base
483
484 (* Pre-compute multiples of the generator point
485 returns the tables along with the number of significant bytes *)
486 let generator_tables () =
487 let len = Param.fe_length * 2 in
488 let one_table _ = Array.init 15 (fun _ -> P.at_infinity ()) in
489 let table = Array.init len one_table in
490 let base = ref P.params_g in
491 for i = 0 to len - 1 do
492 table.(i).(0) <- !base;
493 for j = 1 to 14 do
494 table.(i).(j) <- P.add !base table.(i).(j - 1)
495 done;
496 base := P.double !base;
497 base := P.double !base;
498 base := P.double !base;
499 base := P.double !base
500 done;
501 let convert { f_x; f_y; f_z } = [| f_x; f_y; f_z |] in
502 Array.map (Array.map convert) table
503end
504
505module Make_dh (Param : Parameters) (P : Point_ops) (S : Scalar) : Dh = struct
506 let point_of_octets c =
507 match P.of_octets c with
508 | Ok p when not (P.is_infinity p) -> Ok p
509 | Ok _ -> Error `At_infinity
510 | Error _ as e -> e
511
512 let point_to_octets = P.to_octets
513
514 type secret = scalar
515
516 let share ?(compress = false) private_key =
517 let public_key = S.scalar_mult_base private_key in
518 point_to_octets ~compress public_key
519
520 let secret_of_octets ?compress s =
521 match S.of_octets s with
522 | Ok p -> Ok (p, share ?compress p)
523 | Error _ as e -> e
524
525 let secret_to_octets s = S.to_octets s
526
527 let rec generate_private_key ?g () =
528 let candidate = Crypto_rng.generate ?g Param.byte_length in
529 match S.of_octets candidate with
530 | Ok secret -> secret
531 | Error _ -> generate_private_key ?g ()
532
533 let gen_key ?compress ?g () =
534 let private_key = generate_private_key ?g () in
535 (private_key, share ?compress private_key)
536
537 let key_exchange secret received =
538 match point_of_octets received with
539 | Error _ as err -> err
540 | Ok shared -> Ok (P.x_of_finite_point (S.scalar_mult secret shared))
541end
542
543module type Foreign_n = sig
544 val mul : out_field_element -> field_element -> field_element -> unit
545 val add : out_field_element -> field_element -> field_element -> unit
546 val inv : out_field_element -> field_element -> unit
547 val one : out_field_element -> unit
548 val from_bytes : out_field_element -> string -> unit
549 val to_bytes : bytes -> field_element -> unit
550 val from_montgomery : out_field_element -> field_element -> unit
551 val to_montgomery : out_field_element -> field_element -> unit
552end
553
554module type Fn = sig
555 val from_be_octets : string -> field_element
556 val to_be_octets : field_element -> string
557 val mul : field_element -> field_element -> field_element
558 val add : field_element -> field_element -> field_element
559 val inv : field_element -> field_element
560 val one : field_element
561 val from_montgomery : field_element -> field_element
562 val to_montgomery : field_element -> field_element
563end
564
565module Make_Fn (P : Parameters) (F : Foreign_n) : Fn = struct
566 let b_uts = Bytes.unsafe_to_string
567 let create () = Bytes.create P.fe_length
568 let create_octets () = Bytes.create P.byte_length
569
570 let from_be_octets v =
571 let v' = create () in
572 F.from_bytes v' (rev_string v);
573 F.to_montgomery v' (b_uts v');
574 b_uts v'
575
576 let to_be_octets v =
577 let buf = create_octets () in
578 F.to_bytes buf v;
579 rev_string (b_uts buf)
580
581 let mul a b =
582 let tmp = create () in
583 F.mul tmp a b;
584 b_uts tmp
585
586 let add a b =
587 let tmp = create () in
588 F.add tmp a b;
589 b_uts tmp
590
591 let inv a =
592 let tmp = create () in
593 F.inv tmp a;
594 F.to_montgomery tmp (b_uts tmp);
595 b_uts tmp
596
597 let one =
598 let tmp = create () in
599 F.one tmp;
600 b_uts tmp
601
602 let from_montgomery a =
603 let tmp = create () in
604 F.from_montgomery tmp a;
605 b_uts tmp
606
607 let to_montgomery a =
608 let tmp = create () in
609 F.to_montgomery tmp a;
610 b_uts tmp
611end
612
613module Make_dsa
614 (Param : Parameters)
615 (F : Fn)
616 (P : Point_ops)
617 (S : Scalar)
618 (H : Digestif.S) =
619struct
620 type priv = scalar
621
622 let byte_length = Param.byte_length
623 let bit_length = Param.bit_length
624 let priv_of_octets = S.of_octets
625 let priv_to_octets = S.to_octets
626
627 let padded msg =
628 let l = String.length msg in
629 let bl = Param.byte_length in
630 let first_byte_ok () =
631 match Param.first_byte_bits with
632 | None -> true
633 | Some m -> String.get_uint8 msg 0 land (0xFF land lnot m) = 0
634 in
635 if l > bl || (l = bl && not (first_byte_ok ())) then raise Message_too_long
636 else if l = bl then msg
637 else
638 let res = Bytes.make bl '\000' in
639 Bytes.unsafe_blit_string msg 0 res (bl - l) l;
640 Bytes.unsafe_to_string res
641
642 (* RFC 6979: compute a deterministic k *)
643 module K_gen (H : Digestif.S) = struct
644 let drbg : 'a Crypto_rng.generator =
645 let module M = Crypto_rng.Hmac_drbg (H) in
646 (module M)
647
648 let g ~key msg =
649 let g = Crypto_rng.create ~strict:true drbg in
650 Crypto_rng.reseed ~g (S.to_octets key ^ msg);
651 g
652
653 (* Defined in RFC 6979 sec 2.3.2 with
654 - blen = 8 * Param.byte_length
655 - qlen = Param.bit_length *)
656 let bits2int r =
657 (* keep qlen *leftmost* bits *)
658 let shift = (8 * Param.byte_length) - Param.bit_length in
659 if shift = 0 then Bytes.unsafe_to_string r
660 else
661 (* Assuming shift is < 8 *)
662 let r' = Bytes.create Param.byte_length in
663 let p = ref 0x00 in
664 for i = 0 to Param.byte_length - 1 do
665 let x = Bytes.get_uint8 r i in
666 let v = (x lsr shift) lor (!p lsl (8 - shift)) in
667 p := x;
668 Bytes.set_uint8 r' i v
669 done;
670 Bytes.unsafe_to_string r'
671
672 (* take qbit length, and ensure it is suitable for ECDSA (> 0 & < n) *)
673 let gen g =
674 let rec go () =
675 let b = Bytes.create Param.byte_length in
676 Crypto_rng.generate_into ~g b Param.byte_length;
677 (* truncate to the desired number of bits *)
678 let r = bits2int b in
679 if S.is_in_range r then r else go ()
680 in
681 go ()
682
683 let generate ~key buf = gen (g ~key (padded buf))
684 end
685
686 module K_gen_default = K_gen (H)
687
688 type pub = point
689
690 let pub_of_octets = P.of_octets
691 let pub_to_octets ?(compress = false) pk = P.to_octets ~compress pk
692
693 let generate ?g () =
694 (* FIPS 186-4 B 4.2 *)
695 let d =
696 let rec one () =
697 match S.of_octets (Crypto_rng.generate ?g Param.byte_length) with
698 | Ok x -> x
699 | Error _ -> one ()
700 in
701 one ()
702 in
703 let q = S.scalar_mult_base d in
704 (d, q)
705
706 let x_of_finite_point_mod_n p =
707 match P.to_affine_raw p with
708 | None -> None
709 | Some (x, _) ->
710 let x = F.to_montgomery x in
711 let x = F.mul x F.one in
712 let x = F.from_montgomery x in
713 Some (F.to_be_octets x)
714
715 let sign ~key ?k msg =
716 let msg = padded msg in
717 let e = F.from_be_octets msg in
718 let g = K_gen_default.g ~key msg in
719 let rec do_sign g =
720 let again () =
721 match k with
722 | None -> do_sign g
723 | Some _ -> invalid_arg "k not suitable"
724 in
725 let k' = match k with None -> K_gen_default.gen g | Some k -> k in
726 let ksc =
727 match S.of_octets k' with
728 | Ok ksc -> ksc
729 | Error _ -> invalid_arg "k not in range"
730 (* if no k is provided, this cannot happen since K_gen_*.gen already preserves the Scalar invariants *)
731 in
732 let point = S.scalar_mult_base ksc in
733 match x_of_finite_point_mod_n point with
734 | None -> again ()
735 | Some r ->
736 let r_mon = F.from_be_octets r in
737 let kmon = F.from_be_octets k' in
738 let kinv = F.inv kmon in
739 let dmon = F.from_be_octets (S.to_octets key) in
740 let rd = F.mul r_mon dmon in
741 let cmon = F.add e rd in
742 let smon = F.mul kinv cmon in
743 let s = F.from_montgomery smon in
744 let s = F.to_be_octets s in
745 if S.not_zero s && S.not_zero r then (r, s) else again ()
746 in
747 do_sign g
748
749 let pub_of_priv priv = S.scalar_mult_base priv
750
751 let verify ~key (r, s) msg =
752 try
753 let r = padded r and s = padded s in
754 if not (S.is_in_range r && S.is_in_range s) then false
755 else
756 let msg = padded msg in
757 let z = F.from_be_octets msg in
758 let s_mon = F.from_be_octets s in
759 let s_inv = F.inv s_mon in
760 let u1 = F.mul z s_inv in
761 let r_mon = F.from_be_octets r in
762 let u2 = F.mul r_mon s_inv in
763 let u1 = F.from_montgomery u1 in
764 let u2 = F.from_montgomery u2 in
765 match
766 (S.of_octets (F.to_be_octets u1), S.of_octets (F.to_be_octets u2))
767 with
768 | Ok u1, Ok u2 ->
769 let point = P.add (S.scalar_mult_base u1) (S.scalar_mult u2 key) in
770 begin match x_of_finite_point_mod_n point with
771 | None -> false (* point is infinity *)
772 | Some r' -> String.equal r r'
773 end
774 | Error _, _ | _, Error _ -> false
775 with Message_too_long -> false
776
777 module Precompute = struct
778 let generator_tables = S.generator_tables
779 end
780end
781
782module Make_point (P : Point_ops) (S : Scalar) :
783 Point with type point = point and type scalar = scalar = struct
784 type nonrec point = point
785 type nonrec scalar = scalar
786
787 let of_octets = P.of_octets
788 let to_octets ?(compress = false) p = P.to_octets ~compress p
789 let scalar_of_octets = S.of_octets
790 let scalar_to_octets = S.to_octets
791 let generator = P.params_g
792 let add = P.add
793 let scalar_mult = S.scalar_mult
794end
795
796module P256 : Dh_dsa = struct
797 module Params = struct
798 let a =
799 "\xFF\xFF\xFF\xFF\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFC"
800
801 let b =
802 "\x5A\xC6\x35\xD8\xAA\x3A\x93\xE7\xB3\xEB\xBD\x55\x76\x98\x86\xBC\x65\x1D\x06\xB0\xCC\x53\xB0\xF6\x3B\xCE\x3C\x3E\x27\xD2\x60\x4B"
803
804 let g_x =
805 "\x6B\x17\xD1\xF2\xE1\x2C\x42\x47\xF8\xBC\xE6\xE5\x63\xA4\x40\xF2\x77\x03\x7D\x81\x2D\xEB\x33\xA0\xF4\xA1\x39\x45\xD8\x98\xC2\x96"
806
807 let g_y =
808 "\x4F\xE3\x42\xE2\xFE\x1A\x7F\x9B\x8E\xE7\xEB\x4A\x7C\x0F\x9E\x16\x2B\xCE\x33\x57\x6B\x31\x5E\xCE\xCB\xB6\x40\x68\x37\xBF\x51\xF5"
809
810 let p =
811 "\xFF\xFF\xFF\xFF\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"
812
813 let n =
814 "\xFF\xFF\xFF\xFF\x00\x00\x00\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xBC\xE6\xFA\xAD\xA7\x17\x9E\x84\xF3\xB9\xCA\xC2\xFC\x63\x25\x51"
815
816 let pident =
817 "\x3F\xFF\xFF\xFF\xC0\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"
818 |> rev_string (* (Params.p + 1) / 4*)
819
820 let byte_length = 32
821 let bit_length = 256
822 let fe_length = 32
823 let first_byte_bits = None
824 end
825
826 module Foreign = struct
827 external mul : out_field_element -> field_element -> field_element -> unit
828 = "mc_p256_mul"
829 [@@noalloc]
830
831 external sub : out_field_element -> field_element -> field_element -> unit
832 = "mc_p256_sub"
833 [@@noalloc]
834
835 external add : out_field_element -> field_element -> field_element -> unit
836 = "mc_p256_add"
837 [@@noalloc]
838
839 external to_montgomery : out_field_element -> field_element -> unit
840 = "mc_p256_to_montgomery"
841 [@@noalloc]
842
843 external from_octets : out_field_element -> string -> unit
844 = "mc_p256_from_bytes"
845 [@@noalloc]
846
847 external set_one : out_field_element -> unit = "mc_p256_set_one" [@@noalloc]
848 external nz : field_element -> bool = "mc_p256_nz" [@@noalloc]
849
850 external sqr : out_field_element -> field_element -> unit = "mc_p256_sqr"
851 [@@noalloc]
852
853 external from_montgomery : out_field_element -> field_element -> unit
854 = "mc_p256_from_montgomery"
855 [@@noalloc]
856
857 external to_octets : bytes -> field_element -> unit = "mc_p256_to_bytes"
858 [@@noalloc]
859
860 external inv : out_field_element -> field_element -> unit = "mc_p256_inv"
861 [@@noalloc]
862
863 external select_c :
864 out_field_element -> bool -> field_element -> field_element -> unit
865 = "mc_p256_select"
866 [@@noalloc]
867
868 external double_c : out_point -> point -> unit = "mc_p256_point_double"
869 [@@noalloc]
870
871 external add_c : out_point -> point -> point -> unit = "mc_p256_point_add"
872 [@@noalloc]
873
874 external scalar_mult_base_c : out_point -> string -> unit
875 = "mc_p256_scalar_mult_base"
876 [@@noalloc]
877 end
878
879 module Foreign_n = struct
880 external mul : out_field_element -> field_element -> field_element -> unit
881 = "mc_np256_mul"
882 [@@noalloc]
883
884 external add : out_field_element -> field_element -> field_element -> unit
885 = "mc_np256_add"
886 [@@noalloc]
887
888 external inv : out_field_element -> field_element -> unit = "mc_np256_inv"
889 [@@noalloc]
890
891 external one : out_field_element -> unit = "mc_np256_one" [@@noalloc]
892
893 external from_bytes : out_field_element -> string -> unit
894 = "mc_np256_from_bytes"
895 [@@noalloc]
896
897 external to_bytes : bytes -> field_element -> unit = "mc_np256_to_bytes"
898 [@@noalloc]
899
900 external from_montgomery : out_field_element -> field_element -> unit
901 = "mc_np256_from_montgomery"
902 [@@noalloc]
903
904 external to_montgomery : out_field_element -> field_element -> unit
905 = "mc_np256_to_montgomery"
906 [@@noalloc]
907 end
908
909 module P = Make_point_ops (Params) (Foreign)
910 module S = Make_scalar (Params) (P)
911 module Dh = Make_dh (Params) (P) (S)
912 module Fn = Make_Fn (Params) (Foreign_n)
913 module Dsa = Make_dsa (Params) (Fn) (P) (S) (Digestif.SHA256)
914 module Point = Make_point (P) (S)
915end
916
917module P384 : Dh_dsa = struct
918 module Params = struct
919 let a =
920 "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFE\xFF\xFF\xFF\xFF\x00\x00\x00\x00\x00\x00\x00\x00\xFF\xFF\xFF\xFC"
921
922 let b =
923 "\xB3\x31\x2F\xA7\xE2\x3E\xE7\xE4\x98\x8E\x05\x6B\xE3\xF8\x2D\x19\x18\x1D\x9C\x6E\xFE\x81\x41\x12\x03\x14\x08\x8F\x50\x13\x87\x5A\xC6\x56\x39\x8D\x8A\x2E\xD1\x9D\x2A\x85\xC8\xED\xD3\xEC\x2A\xEF"
924
925 let g_x =
926 "\xAA\x87\xCA\x22\xBE\x8B\x05\x37\x8E\xB1\xC7\x1E\xF3\x20\xAD\x74\x6E\x1D\x3B\x62\x8B\xA7\x9B\x98\x59\xF7\x41\xE0\x82\x54\x2A\x38\x55\x02\xF2\x5D\xBF\x55\x29\x6C\x3A\x54\x5E\x38\x72\x76\x0A\xB7"
927
928 let g_y =
929 "\x36\x17\xde\x4a\x96\x26\x2c\x6f\x5d\x9e\x98\xbf\x92\x92\xdc\x29\xf8\xf4\x1d\xbd\x28\x9a\x14\x7c\xe9\xda\x31\x13\xb5\xf0\xb8\xc0\x0a\x60\xb1\xce\x1d\x7e\x81\x9d\x7a\x43\x1d\x7c\x90\xea\x0e\x5f"
930
931 let p =
932 "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFE\xFF\xFF\xFF\xFF\x00\x00\x00\x00\x00\x00\x00\x00\xFF\xFF\xFF\xFF"
933
934 let n =
935 "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xC7\x63\x4D\x81\xF4\x37\x2D\xDF\x58\x1A\x0D\xB2\x48\xB0\xA7\x7A\xEC\xEC\x19\x6A\xCC\xC5\x29\x73"
936
937 let pident =
938 "\x3F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xBF\xFF\xFF\xFF\xC0\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00"
939 |> rev_string (* (Params.p + 1) / 4*)
940
941 let byte_length = 48
942 let bit_length = 384
943 let fe_length = 48
944 let first_byte_bits = None
945 end
946
947 module Foreign = struct
948 external mul : out_field_element -> field_element -> field_element -> unit
949 = "mc_p384_mul"
950 [@@noalloc]
951
952 external sub : out_field_element -> field_element -> field_element -> unit
953 = "mc_p384_sub"
954 [@@noalloc]
955
956 external add : out_field_element -> field_element -> field_element -> unit
957 = "mc_p384_add"
958 [@@noalloc]
959
960 external to_montgomery : out_field_element -> field_element -> unit
961 = "mc_p384_to_montgomery"
962 [@@noalloc]
963
964 external from_octets : out_field_element -> string -> unit
965 = "mc_p384_from_bytes"
966 [@@noalloc]
967
968 external set_one : out_field_element -> unit = "mc_p384_set_one" [@@noalloc]
969 external nz : field_element -> bool = "mc_p384_nz" [@@noalloc]
970
971 external sqr : out_field_element -> field_element -> unit = "mc_p384_sqr"
972 [@@noalloc]
973
974 external from_montgomery : out_field_element -> field_element -> unit
975 = "mc_p384_from_montgomery"
976 [@@noalloc]
977
978 external to_octets : bytes -> field_element -> unit = "mc_p384_to_bytes"
979 [@@noalloc]
980
981 external inv : out_field_element -> field_element -> unit = "mc_p384_inv"
982 [@@noalloc]
983
984 external select_c :
985 out_field_element -> bool -> field_element -> field_element -> unit
986 = "mc_p384_select"
987 [@@noalloc]
988
989 external double_c : out_point -> point -> unit = "mc_p384_point_double"
990 [@@noalloc]
991
992 external add_c : out_point -> point -> point -> unit = "mc_p384_point_add"
993 [@@noalloc]
994
995 external scalar_mult_base_c : out_point -> string -> unit
996 = "mc_p384_scalar_mult_base"
997 [@@noalloc]
998 end
999
1000 module Foreign_n = struct
1001 external mul : out_field_element -> field_element -> field_element -> unit
1002 = "mc_np384_mul"
1003 [@@noalloc]
1004
1005 external add : out_field_element -> field_element -> field_element -> unit
1006 = "mc_np384_add"
1007 [@@noalloc]
1008
1009 external inv : out_field_element -> field_element -> unit = "mc_np384_inv"
1010 [@@noalloc]
1011
1012 external one : out_field_element -> unit = "mc_np384_one" [@@noalloc]
1013
1014 external from_bytes : out_field_element -> string -> unit
1015 = "mc_np384_from_bytes"
1016 [@@noalloc]
1017
1018 external to_bytes : bytes -> field_element -> unit = "mc_np384_to_bytes"
1019 [@@noalloc]
1020
1021 external from_montgomery : out_field_element -> field_element -> unit
1022 = "mc_np384_from_montgomery"
1023 [@@noalloc]
1024
1025 external to_montgomery : out_field_element -> field_element -> unit
1026 = "mc_np384_to_montgomery"
1027 [@@noalloc]
1028 end
1029
1030 module P = Make_point_ops (Params) (Foreign)
1031 module S = Make_scalar (Params) (P)
1032 module Dh = Make_dh (Params) (P) (S)
1033 module Fn = Make_Fn (Params) (Foreign_n)
1034 module Dsa = Make_dsa (Params) (Fn) (P) (S) (Digestif.SHA384)
1035 module Point = Make_point (P) (S)
1036end
1037
1038module P521 : Dh_dsa = struct
1039 module Params = struct
1040 let a =
1041 "\x01\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFC"
1042
1043 let b =
1044 "\x00\x51\x95\x3E\xB9\x61\x8E\x1C\x9A\x1F\x92\x9A\x21\xA0\xB6\x85\x40\xEE\xA2\xDA\x72\x5B\x99\xB3\x15\xF3\xB8\xB4\x89\x91\x8E\xF1\x09\xE1\x56\x19\x39\x51\xEC\x7E\x93\x7B\x16\x52\xC0\xBD\x3B\xB1\xBF\x07\x35\x73\xDF\x88\x3D\x2C\x34\xF1\xEF\x45\x1F\xD4\x6B\x50\x3F\x00"
1045
1046 let g_x =
1047 "\x00\xC6\x85\x8E\x06\xB7\x04\x04\xE9\xCD\x9E\x3E\xCB\x66\x23\x95\xB4\x42\x9C\x64\x81\x39\x05\x3F\xB5\x21\xF8\x28\xAF\x60\x6B\x4D\x3D\xBA\xA1\x4B\x5E\x77\xEF\xE7\x59\x28\xFE\x1D\xC1\x27\xA2\xFF\xA8\xDE\x33\x48\xB3\xC1\x85\x6A\x42\x9B\xF9\x7E\x7E\x31\xC2\xE5\xBD\x66"
1048
1049 let g_y =
1050 "\x01\x18\x39\x29\x6a\x78\x9a\x3b\xc0\x04\x5c\x8a\x5f\xb4\x2c\x7d\x1b\xd9\x98\xf5\x44\x49\x57\x9b\x44\x68\x17\xaf\xbd\x17\x27\x3e\x66\x2c\x97\xee\x72\x99\x5e\xf4\x26\x40\xc5\x50\xb9\x01\x3f\xad\x07\x61\x35\x3c\x70\x86\xa2\x72\xc2\x40\x88\xbe\x94\x76\x9f\xd1\x66\x50"
1051
1052 let p =
1053 "\x01\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"
1054
1055 let n =
1056 "\x01\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFA\x51\x86\x87\x83\xBF\x2F\x96\x6B\x7F\xCC\x01\x48\xF7\x09\xA5\xD0\x3B\xB5\xC9\xB8\x89\x9C\x47\xAE\xBB\x6F\xB7\x1E\x91\x38\x64\x09"
1057
1058 let pident =
1059 "\x01\x7f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"
1060 |> rev_string
1061
1062 let byte_length = 66
1063 let bit_length = 521
1064
1065 let fe_length =
1066 if Sys.word_size == 64 then 72
1067 else 68 (* TODO: is this congruent with C code? *)
1068
1069 let first_byte_bits = Some 0x01
1070 end
1071
1072 module Foreign = struct
1073 external mul : out_field_element -> field_element -> field_element -> unit
1074 = "mc_p521_mul"
1075 [@@noalloc]
1076
1077 external sub : out_field_element -> field_element -> field_element -> unit
1078 = "mc_p521_sub"
1079 [@@noalloc]
1080
1081 external add : out_field_element -> field_element -> field_element -> unit
1082 = "mc_p521_add"
1083 [@@noalloc]
1084
1085 external to_montgomery : out_field_element -> field_element -> unit
1086 = "mc_p521_to_montgomery"
1087 [@@noalloc]
1088
1089 external from_octets : out_field_element -> string -> unit
1090 = "mc_p521_from_bytes"
1091 [@@noalloc]
1092
1093 external set_one : out_field_element -> unit = "mc_p521_set_one" [@@noalloc]
1094 external nz : field_element -> bool = "mc_p521_nz" [@@noalloc]
1095
1096 external sqr : out_field_element -> field_element -> unit = "mc_p521_sqr"
1097 [@@noalloc]
1098
1099 external from_montgomery : out_field_element -> field_element -> unit
1100 = "mc_p521_from_montgomery"
1101 [@@noalloc]
1102
1103 external to_octets : bytes -> field_element -> unit = "mc_p521_to_bytes"
1104 [@@noalloc]
1105
1106 external inv : out_field_element -> field_element -> unit = "mc_p521_inv"
1107 [@@noalloc]
1108
1109 external select_c :
1110 out_field_element -> bool -> field_element -> field_element -> unit
1111 = "mc_p521_select"
1112 [@@noalloc]
1113
1114 external double_c : out_point -> point -> unit = "mc_p521_point_double"
1115 [@@noalloc]
1116
1117 external add_c : out_point -> point -> point -> unit = "mc_p521_point_add"
1118 [@@noalloc]
1119
1120 external scalar_mult_base_c : out_point -> string -> unit
1121 = "mc_p521_scalar_mult_base"
1122 [@@noalloc]
1123 end
1124
1125 module Foreign_n = struct
1126 external mul : out_field_element -> field_element -> field_element -> unit
1127 = "mc_np521_mul"
1128 [@@noalloc]
1129
1130 external add : out_field_element -> field_element -> field_element -> unit
1131 = "mc_np521_add"
1132 [@@noalloc]
1133
1134 external inv : out_field_element -> field_element -> unit = "mc_np521_inv"
1135 [@@noalloc]
1136
1137 external one : out_field_element -> unit = "mc_np521_one" [@@noalloc]
1138
1139 external from_bytes : out_field_element -> string -> unit
1140 = "mc_np521_from_bytes"
1141 [@@noalloc]
1142
1143 external to_bytes : bytes -> field_element -> unit = "mc_np521_to_bytes"
1144 [@@noalloc]
1145
1146 external from_montgomery : out_field_element -> field_element -> unit
1147 = "mc_np521_from_montgomery"
1148 [@@noalloc]
1149
1150 external to_montgomery : out_field_element -> field_element -> unit
1151 = "mc_np521_to_montgomery"
1152 [@@noalloc]
1153 end
1154
1155 module P = Make_point_ops (Params) (Foreign)
1156 module S = Make_scalar (Params) (P)
1157 module Dh = Make_dh (Params) (P) (S)
1158 module Fn = Make_Fn (Params) (Foreign_n)
1159 module Dsa = Make_dsa (Params) (Fn) (P) (S) (Digestif.SHA512)
1160 module Point = Make_point (P) (S)
1161end
1162
1163module X25519 = struct
1164 (* RFC 7748 *)
1165 external x25519_scalar_mult_generic : bytes -> string -> string -> unit
1166 = "mc_x25519_scalar_mult_generic"
1167 [@@noalloc]
1168
1169 let key_len = 32
1170
1171 let scalar_mult in_ base =
1172 let out = Bytes.create key_len in
1173 x25519_scalar_mult_generic out in_ base;
1174 Bytes.unsafe_to_string out
1175
1176 type secret = string
1177
1178 let basepoint = String.init key_len (function 0 -> '\009' | _ -> '\000')
1179 let public priv = scalar_mult priv basepoint
1180
1181 let gen_key ?compress:_ ?g () =
1182 let secret = Crypto_rng.generate ?g key_len in
1183 (secret, public secret)
1184
1185 let secret_of_octets ?compress:_ s =
1186 if String.length s = key_len then Ok (s, public s)
1187 else Error `Invalid_length
1188
1189 let secret_to_octets s = s
1190
1191 let is_zero =
1192 let zero = String.make key_len '\000' in
1193 fun buf -> String.equal zero buf
1194
1195 let key_exchange secret public =
1196 if String.length public = key_len then
1197 let res = scalar_mult secret public in
1198 if is_zero res then Error `Low_order else Ok res
1199 else Error `Invalid_length
1200end
1201
1202module Ed25519 = struct
1203 external scalar_mult_base_to_bytes : bytes -> string -> unit
1204 = "mc_25519_scalar_mult_base"
1205 [@@noalloc]
1206
1207 external reduce_l : bytes -> unit = "mc_25519_reduce_l" [@@noalloc]
1208
1209 external muladd : bytes -> string -> string -> string -> unit
1210 = "mc_25519_muladd"
1211 [@@noalloc]
1212
1213 external double_scalar_mult : bytes -> string -> string -> string -> bool
1214 = "mc_25519_double_scalar_mult"
1215 [@@noalloc]
1216
1217 external pub_ok : string -> bool = "mc_25519_pub_ok" [@@noalloc]
1218
1219 let key_len = 32
1220
1221 let scalar_mult_base_to_bytes p =
1222 let tmp = Bytes.create key_len in
1223 scalar_mult_base_to_bytes tmp p;
1224 Bytes.unsafe_to_string tmp
1225
1226 let muladd a b c =
1227 let tmp = Bytes.create key_len in
1228 muladd tmp a b c;
1229 Bytes.unsafe_to_string tmp
1230
1231 let double_scalar_mult a b c =
1232 let tmp = Bytes.create key_len in
1233 let s = double_scalar_mult tmp a b c in
1234 (s, Bytes.unsafe_to_string tmp)
1235
1236 type pub = string
1237 type priv = string
1238
1239 let sha512 datas =
1240 let open Digestif.SHA512 in
1241 let buf = Bytes.create digest_size in
1242 let ctx = List.fold_left (feed_string ?off:None ?len:None) empty datas in
1243 get_into_bytes ctx buf;
1244 buf
1245
1246 (* RFC 8032 *)
1247 let public secret =
1248 (* section 5.1.5 *)
1249 (* step 1 *)
1250 let h = sha512 [ secret ] in
1251 (* step 2 *)
1252 let s, rest =
1253 ( Bytes.sub h 0 key_len,
1254 Bytes.unsafe_to_string (Bytes.sub h key_len (Bytes.length h - key_len))
1255 )
1256 in
1257 Bytes.set_uint8 s 0 (Bytes.get_uint8 s 0 land 248);
1258 Bytes.set_uint8 s 31 (Bytes.get_uint8 s 31 land 127 lor 64);
1259 let s = Bytes.unsafe_to_string s in
1260 (* step 3 and 4 *)
1261 let public = scalar_mult_base_to_bytes s in
1262 (public, (s, rest))
1263
1264 let pub_of_priv secret = fst (public secret)
1265
1266 let priv_of_octets buf =
1267 if String.length buf = key_len then Ok buf else Error `Invalid_length
1268
1269 let priv_to_octets (priv : priv) = priv
1270
1271 let pub_of_octets buf =
1272 if String.length buf = key_len then
1273 if pub_ok buf then Ok buf else Error `Not_on_curve
1274 else Error `Invalid_length
1275
1276 let pub_to_octets pub = pub
1277
1278 let generate ?g () =
1279 let secret = Crypto_rng.generate ?g key_len in
1280 (secret, pub_of_priv secret)
1281
1282 let sign ~key msg =
1283 (* section 5.1.6 *)
1284 let pub, (s, prefix) = public key in
1285 let r = sha512 [ prefix; msg ] in
1286 reduce_l r;
1287 let r = Bytes.unsafe_to_string r in
1288 let r_big = scalar_mult_base_to_bytes r in
1289 let k = sha512 [ r_big; pub; msg ] in
1290 reduce_l k;
1291 let k = Bytes.unsafe_to_string k in
1292 let s_out = muladd k s r in
1293 let res = Bytes.create (key_len + key_len) in
1294 Bytes.unsafe_blit_string r_big 0 res 0 key_len;
1295 Bytes.unsafe_blit_string s_out 0 res key_len key_len;
1296 Bytes.unsafe_to_string res
1297
1298 let verify ~key signature ~msg =
1299 (* section 5.1.7 *)
1300 if String.length signature = 2 * key_len then
1301 let r, s =
1302 (String.sub signature 0 key_len, String.sub signature key_len key_len)
1303 in
1304 let s_smaller_l =
1305 (* check s within 0 <= s < L *)
1306 let s' = Bytes.make (key_len * 2) '\000' in
1307 Bytes.unsafe_blit_string s 0 s' 0 key_len;
1308 reduce_l s';
1309 let s' = Bytes.unsafe_to_string s' in
1310 let s'' = s ^ String.make key_len '\000' in
1311 String.equal s'' s'
1312 in
1313 if s_smaller_l then begin
1314 let k = sha512 [ r; key; msg ] in
1315 reduce_l k;
1316 let k = Bytes.unsafe_to_string k in
1317 let success, r' = double_scalar_mult k key s in
1318 success && String.equal r r'
1319 end
1320 else false
1321 else false
1322end