Add an implementation of mirage-crypto-rng-miou to initialize the RNG…

… with Miou

mirage-crypto-rng-miou.opam

@@ -0,0 +1,28 @@
+opam-version: "2.0"
+homepage:     "https://github.com/mirage/mirage-crypto"
+dev-repo:     "git+https://github.com/mirage/mirage-crypto.git"
+bug-reports:  "https://github.com/mirage/mirage-crypto/issues"
+doc:          "https://mirage.github.io/mirage-crypto/doc"
+authors:      ["Romain Calascibetta <romain.calascibetta@gmail.com>" ]
+maintainer:   "Romain Calascibetta <romain.calascibetta@gmail.com>"
+license:      "ISC"
+synopsis:     "Feed the entropy source in an miou-friendly way"
+
+build: [ ["dune" "subst"] {dev}
+         ["dune" "build" "-p" name "-j" jobs ]
+         ["dune" "runtest" "-p" name "-j" jobs] {with-test} ]
+
+depends: [
+  "ocaml" {>= "5.0.0"}
+  "dune" {>= "2.7"}
+  "miou"
+  "logs"
+  "mirage-crypto-rng" {=version}
+  "duration"
+  "mtime"
+  "ohex" {with-test & >= "0.2.0"}
+]
+description: """
+Mirage-crypto-rng-miou feeds the entropy source for Mirage_crypto_rng-based
+random number generator implementations, in an miou-friendly way.
+"""

rng/miou/dune

@@ -0,0 +1,5 @@
+(library
+ (name mirage_crypto_rng_miou)
+ (public_name mirage-crypto-rng-miou)
+ (libraries miou miou.unix miou.backoff mirage-crypto mirage-crypto-rng mirage-crypto-rng.unix digestif duration mtime.clock.os logs)
+ (modules mirage_crypto_rng_miou pfortuna))

rng/miou/mirage_crypto_rng_miou.ml

@@ -0,0 +1,85 @@
+open Mirage_crypto_rng
+
+module Pfortuna = Pfortuna
+
+type _ Effect.t += Spawn : (unit -> unit) -> unit Effect.t
+external reraise : exn -> 'a = "%reraise"
+
+let periodic fn delta =
+  let rec one () =
+    fn ();
+    Miou_unix.sleep (Duration.to_f delta);
+    one () in
+  Effect.perform (Spawn one)
+
+let getrandom delta source =
+  let fn () =
+    let per_pool = 8 in
+    let size = per_pool * pools None in
+    let random = Mirage_crypto_rng_unix.getrandom size in
+    let idx = ref 0 in
+    let fn () = incr idx; String.sub random (per_pool * (pred !idx)) per_pool in
+    Entropy.feed_pools None source fn in
+  periodic fn delta
+
+let getrandom_init i =
+  let data = Mirage_crypto_rng_unix.getrandom 128 in
+  Entropy.header i data
+
+let rdrand delta =
+  match Entropy.cpu_rng with
+  | Error `Not_supported -> ()
+  | Ok cpu_rng -> periodic (cpu_rng None) delta
+
+let running = Atomic.make false
+
+let switch fn =
+  let orphans = Miou.orphans () in
+  let open Effect.Deep in
+  let retc = Fun.id in
+  let exnc = reraise in
+  let effc : type c. c Effect.t -> ((c, 'r) continuation -> 'r) option
+    = function
+    | Spawn fn ->
+      ignore (Miou.call_cc ~orphans fn);
+      Some (fun k -> continue k ())
+    | _ -> None in
+  match_with fn orphans { retc; exnc; effc }
+
+let default_generator_already_set =
+  "Mirage_crypto_rng.default_generator has already \
+   been set (but not via Mirage_crypto_rng_miou). Please check \
+   that this is intentional"
+
+type rng = unit Miou.t
+
+let rec compare_and_set ?(backoff= Backoff.default) t a b =
+  if Atomic.compare_and_set t a b = false
+  then compare_and_set ~backoff:(Backoff.once backoff) t a b
+
+let rec clean_up sleep orphans = match Miou.care orphans with
+  | Some None | None -> Miou_unix.sleep (Duration.to_f sleep); clean_up sleep orphans
+  | Some (Some prm) -> Miou.await_exn prm; clean_up sleep orphans
+
+let initialize (type a) ?g ?(sleep= Duration.of_sec 1) (rng : a generator) =
+  if Atomic.compare_and_set running false true
+  then begin
+    let seed =
+      let init = Entropy.[ bootstrap; whirlwind_bootstrap; bootstrap; getrandom_init ] in
+      List.mapi (fun i fn -> fn i) init |> String.concat "" in
+    let rng = create ?g ~seed ~time:Mtime_clock.elapsed_ns rng in
+    set_default_generator rng;
+    Miou.call @@ fun () ->
+    let finally () = compare_and_set running true false in
+    Fun.protect ~finally @@ fun () -> switch @@ fun orphans ->
+    let () =
+      try let _ = default_generator () in
+          Logs.warn (fun m -> m "%s" default_generator_already_set)
+      with No_default_generator -> () in
+    rdrand sleep;
+    let source = Entropy.register_source "getrandom" in
+    getrandom (Int64.mul sleep 10L) source;
+    clean_up sleep orphans
+  end else invalid_arg ""
+
+let kill prm = Miou.cancel prm

rng/miou/pfortuna.ml

@@ -0,0 +1,120 @@
+open Mirage_crypto
+open Mirage_crypto.Uncommon
+
+module SHAd256 = struct
+  open Digestif
+  type ctx = SHA256.ctx
+  let empty     = SHA256.empty
+  let get t     = SHA256.(get t |> to_raw_string |> digest_string |> to_raw_string)
+  let digesti i = SHA256.(digesti_string i |> to_raw_string |> digest_string |> to_raw_string)
+  let feedi     = SHA256.feedi_string
+end
+
+let block = 16
+
+(* the minimal amount of bytes in a pool to trigger a reseed *)
+let min_pool_size = 64
+(* the minimal duration between two reseeds *)
+let min_time_duration = 1_000_000_000L
+(* number of pools *)
+let pools = 32
+
+type t =
+  { ctr          : AES.CTR.ctr
+  ; secret       : string
+  ; key          : AES.CTR.key
+  ; pools        : SHAd256.ctx array
+  ; pool0_size   : int
+  ; reseed_count : int
+  ; last_reseed  : int64
+  ; time         : (unit -> int64) option
+  }
+
+type g = Miou.Mutex.t * t ref
+
+let update (m, g) fn = Miou.Mutex.protect m @@ fun () -> g := fn !g
+let get (m, g) fn = Miou.Mutex.protect m @@ fun () -> fn !g
+
+let create ?time () =
+  let secret = String.make 32 '\000' in
+  let m = Miou.Mutex.create () in
+  let t =
+    { ctr= (0L, 0L); secret; key= AES.CTR.of_secret secret
+    ; pools= Array.make pools SHAd256.empty
+    ; pool0_size= 0
+    ; reseed_count= 0
+    ; last_reseed= 0L
+    ; time } in
+  (m, { contents= t })
+
+let seeded ~t =
+  let lo, hi = t.ctr in
+  not (Int64.equal lo 0L && Int64.equal hi 0L)
+
+let set_key ~t secret =
+  { t with secret; key= AES.CTR.of_secret secret }
+
+let reseedi ~t iter =
+  let t = set_key ~t (SHAd256.digesti (fun fn -> fn t.secret; iter fn)) in
+  { t with ctr= AES.CTR.add_ctr t.ctr 1L }
+
+let iter1 a f = f a
+let reseed ~t cs = reseedi ~t (iter1 cs)
+
+let generate_rekey ~t buf ~off len =
+  let b = len // block* 2 in
+  let n = b * block in
+  let r = AES.CTR.stream ~key:t.key ~ctr:t.ctr n in
+  Bytes.unsafe_blit_string r 0 buf off len;
+  let r2 = String.sub r (n - 32) 32 in
+  let t = set_key ~t r2 in
+  { t with ctr= AES.CTR.add_ctr t.ctr (Int64.of_int b) }
+
+let add_pool_entropy t =
+  if t.pool0_size > min_pool_size then
+    let should_reseed, now = match t.time with
+      | None -> true, 0L
+      | Some fn ->
+        let now = fn () in
+        Int64.(sub now t.last_reseed > min_time_duration), now in
+  if should_reseed then begin
+    let t = { t with reseed_count= t.reseed_count + 1
+                   ; last_reseed= now
+                   ; pool0_size= 0 } in
+    reseedi ~t @@ fun add ->
+    for i = 0 to pools - 1 do
+      if t.reseed_count land ((1 lsl i) - 1) = 0
+      then (SHAd256.get t.pools.(i) |> add; t.pools.(i) <- SHAd256.empty)
+    done
+  end else t else t
+
+let generate_into ~t buf ~off len =
+  let t = add_pool_entropy t in
+  if not (seeded ~t) then raise Mirage_crypto_rng.Unseeded_generator;
+  let rec chunk t off = function
+    | i when i <= 0 -> t
+    | n ->
+      let n' = imin n 0x10000 in
+      let t = generate_rekey ~t buf ~off n' in
+      chunk t (off + n') (n - n') in
+  chunk t off len
+
+let add ~t source ~pool data =
+  let buf = Bytes.create 2
+  and pool = pool land (pools - 1)
+  and source = Mirage_crypto_rng.Entropy.id source land 0xff in
+  Bytes.set_uint8 buf 0 source;
+  Bytes.set_uint8 buf 1 (String.length data);
+  t.pools.(pool) <- SHAd256.feedi t.pools.(pool) (iter2 (Bytes.unsafe_to_string buf) data);
+  if pool = 0 then { t with pool0_size= t.pool0_size + String.length data } else t
+
+let accumulate ~g source =
+  let pool = ref 0 in
+  `Acc (fun buf ->
+     update g @@ fun t ->
+     let t = add ~t source ~pool:!pool buf in
+     incr pool; t)
+
+let reseed ~g cs = update g @@ fun t -> reseed ~t cs
+let generate_into ~g buf ~off len = update g @@ fun t -> generate_into ~t buf ~off len
+let seeded ~g = get g @@ fun t -> seeded ~t

rng/miou/pfortuna.mli

@@ -0,0 +1 @@
+include Mirage_crypto_rng.Generator

tests/dune

@@ -65,3 +65,9 @@
  (modules   test_eio_rng test_eio_entropy_collection)
  (libraries mirage-crypto-rng-eio duration eio_main ohex)
  (package   mirage-crypto-rng-eio))
+
+(tests
+ (names     test_miou_rng test_miou_entropy_collection)
+ (modules   test_miou_rng test_miou_entropy_collection)
+ (libraries mirage-crypto-rng-miou duration ohex)
+ (package   mirage-crypto-rng-miou))

tests/test_miou_entropy_collection.ml

@@ -0,0 +1,31 @@
+module Printing_rng = struct
+  type g = unit
+
+  let block = 16
+  let create ?time:_ () = ()
+  let generate_into ~g:_ _buf ~off:_ _len = assert false
+  let seeded ~g:_ = true
+  let pools = 1
+
+  let reseed ~g:_ data =
+    Format.printf "reseeding:@.%a@.%!" (Ohex.pp_hexdump ()) data
+
+  let accumulate ~g:_ source =
+    let print data =
+      Format.printf "accumulate: (src: %a) %a@.%!"
+        Mirage_crypto_rng.Entropy.pp_source source Ohex.pp data
+    in
+    `Acc print
+end
+
+let () =
+  Miou_unix.run @@ fun () ->
+  let rng = Mirage_crypto_rng_miou.initialize (module Printing_rng) in
+  Format.printf "entropy sources: %a@,%!"
+    (fun ppf -> List.iter (fun x ->
+         Mirage_crypto_rng.Entropy.pp_source ppf x;
+         Format.pp_print_space ppf ()))
+    (Mirage_crypto_rng.Entropy.sources ());
+  let sleep = Duration.(of_sec 2 |> to_f) in
+  Miou_unix.sleep sleep;
+  Mirage_crypto_rng_miou.kill rng

tests/test_miou_rng.ml

@@ -0,0 +1,9 @@
+let () = Miou_unix.run @@ fun () ->
+  let rng = Mirage_crypto_rng_miou.initialize (module Mirage_crypto_rng_miou.Pfortuna) in
+  let random_num = Mirage_crypto_rng.generate 32 in
+  assert (String.length random_num = 32);
+  Printf.printf "32 bit random number: %S\n%!" random_num;
+  let random_num = Mirage_crypto_rng.generate 16 in
+  assert (String.length random_num = 16);
+  Printf.printf "16 bit random number: %S\n%!" random_num;
+  Mirage_crypto_rng_miou.kill rng