DSA, with fries and modules

dsa.ml

module Dsa = struct

  open Nocrypto
  open Nocrypto.Uncommon

  type priv = { p : Z.t ; q : Z.t ; gg : Z.t ; x : Z.t ; y : Z.t }
  type pub  = { p : Z.t ; q : Z.t ; gg : Z.t ; y : Z.t }

  let pub_of_priv ({ p; q; gg; y }: priv) : pub = { p; q; gg; y}

  let expand_size = function
    | `Fips1024 -> (1024, 160)
    | `Fips2048 -> (2048, 256)
    | `Fips3072 -> (3072, 256)
    | `LN (l, n) -> (l, n)

  let expand_mask = function
    | `No         -> `No
    | `Yes        -> `Yes None
    | `Yes_with g -> `Yes (Some g)

  let params ?g size =
    let (l, n) = expand_size size in

    let rec p_scan q a =
      let p = Z.(q * a + ~$1) in
      if pseudoprime p then (p, a) else p_scan q Z.(a + ~$2) in

    let rec g_scan p a =
      let seed = Rng.Z.gen_r ?g Z.one p in
      let gg   = Z.(powm seed a p) in
      if gg <> Z.one then gg else g_scan p a in

    let q = Rng.prime ?g ~msb:1 ~bits:n in
    let (p, a) = p_scan q @@ Z.((lsl) ~$3) (l - n - 1) in
    let gg     = g_scan p a in
    (p, q, gg)

  let generate ?g size =
    let (p, q, gg) = params ?g size in
    let x = Rng.Z.gen_r ?g Z.one q in
    let y = Z.(powm gg x p) in
    { p; q; gg; x; y }

  module Hmac_drgb_256 = Hmac_drgb (Hash.SHA256)
  module Hmac_num      = Rng.Numeric_of (Hmac_drgb_256)

  let rec gen_r ~g a b =
    Hmac_num.overdrive 1;
    let x = Hmac_num.Z.gen ~g b in
    if x < a then gen_r ~g a b else x

  let rec k_hmac_drgb ~key z =
    let { q; x; _ } = key in
    let xh1 =
      let repr = Numeric.Z.(to_cstruct_be ~size:(cdiv (bits q) 8)) in
      Cs.(repr x <> repr Z.(z mod q)) in
    let g = Hmac_drgb_256.create () in
    Hmac_drgb_256.reseed ~g xh1;
    gen_r ~g Z.one q

  let rec sign_z ?k:k0 ?(mask = `Yes) ~key z =
    let { p; q; gg; x } = key in
    let k  = match k0 with Some k -> k | None -> k_hmac_drgb ~key z in
    let k' = Z.invert k q
    and r  = match expand_mask mask with
(*       | `Yes ->
          let (m1, m2) = Rng.Z.(gen_r ?g Z.one q, gen_r ?g Z.one q) in
          Z.(powm gg (k + m1 * q + m2) p * powm gg (q - m2) p mod p mod q) in *)
      | `No    -> Z.(powm gg k p mod q)
      | `Yes g ->
          let m  = Rng.Z.gen_r ?g Z.one q in
          let m' = Z.invert m q in
          Z.(powm (powm gg m p) (m' * k mod q) p mod q) in
    let s  = Z.(k' * (z + x * r) mod q) in
    if r = Z.zero || s = Z.zero then
      sign_z ?k:k0 ~key z
    else (r, s)

  let verify_z ~key:({ p; q; gg; y }: priv ) (r, s) z =
    let v () =
      let w  = Z.invert s q in
      let u1 = Z.(z * w mod q)
      and u2 = Z.(r * w mod q) in
      Z.((powm gg u1 p * powm y u2 p) mod p mod q) in
    Z.zero < r && r < q && Z.zero < s && s < q && v () = r

  let sign ?mask ?k ~(key : priv) msg =
    sign_z ?mask ?k ~key Numeric.Z.(of_bits_be msg (bits key.q))

  let verify ~key rs msg =
    verify_z ~key rs Numeric.Z.(of_bits_be msg (bits key.q))

end

hmac_drgb.ml

module Hmac_drgb (H : Nocrypto.Hash.T) = struct

  open Nocrypto
  open Nocrypto.Uncommon

  type g =
    { mutable k : Cstruct.t
    ; mutable v : Cstruct.t
    }

  let block_size = H.digest_size

  let (bx00, bx01) = Cstruct.(of_string "\000", of_string "\001")

  let create () =
    { k = Cs.create_with H.digest_size 0x00
    ; v = Cs.create_with H.digest_size 0x01
    }

  let reseed ~g cs =
    let (k, v) = (g.k, g.v) in
    let k = H.hmac ~key:k @@ Cs.concat [v; bx00; cs] in
    let v = H.hmac ~key:k v in
    let k = H.hmac ~key:k @@ Cs.concat [v; bx01; cs] in
    let v = H.hmac ~key:k v in
    g.k <- k; g.v <- v

  let generate ?g bytes =
    let g = match g with Some g -> g | None -> assert false in (* XXX *)
    let rec go acc k v = function
      | 0 -> (v, Cs.concat @@ List.rev acc)
      | i -> let v = H.hmac ~key:k v in go (v::acc) k v (pred i) in
    let (v, cs) = go [] g.k g.v (cdiv bytes H.digest_size) in
    g.k <- H.hmac ~key:g.k Cs.(v <> bx00);
    g.v <- H.hmac ~key:g.k v;
    Cstruct.sub cs 0 bytes
    
end

k_alternatives.ml

let k_random ?g ~key: ({ q } : priv) = Rng.Z.gen_r ?g Z.one q

let k_fortuna ~key:({ q; x } : priv) z =
  let g = Fortuna.create () in
  Fortuna.reseedv ~g Numeric.Z.([ to_cstruct_be x; to_cstruct_be z ]);
  Rng.Z.gen_r ~g Z.one q

let k_rfc6979_direct ~key:({ q; x; } : priv) z =
  let open Hash.SHA256 in
  let qlen = Numeric.Z.bits q in
  let (bx00, bx01) = Cs.(create_with 1 0, create_with 1 1) in
  let (x_s, h1_s) =
    let repr = Numeric.Z.to_cstruct_be ~size:(cdiv qlen 8) in
    (repr x, repr Z.(z mod q)) in
  let (k, v) =
    let n = 8 * cdiv digest_size 8 in
    Cs.(create_with n 0x00, create_with n 0x01) in
  let k = hmac ~key:k @@ Cs.concat [ v; bx00; x_s; h1_s ] in
  let v = hmac ~key:k v in
  let k = hmac ~key:k @@ Cs.concat [ v; bx01; x_s; h1_s ] in
  let v = hmac ~key:k v
  in
  let rec collect acc k v = function
    | 0 -> (v, Cs.concat (List.rev acc))
    | i -> let v = hmac ~key:k v in collect (v::acc) k v (pred i)
  and attempt k v =
    let (v, cs) = collect [] k v (cdiv digest_size qlen) in
    let kk = Numeric.Z.of_bits_be cs qlen in
    if Z.zero < kk && kk < q then kk else
      let k = hmac ~key:k Cs.(v <> bx00) in
      let v = hmac ~key:k v in
      attempt k v in
  attempt k v