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

.github/workflows/test.yml

@@ -24,6 +24,7 @@ jobs:
           opam-local-packages: |
             *.opam
             !mirage-crypto-rng-eio.opam
+            !mirage-crypto-rng-miou-unix.opam
           ocaml-compiler: ${{ matrix.ocaml-version }}
 
       - name: Install dependencies
@@ -35,8 +36,8 @@ jobs:
       - name: Test
         run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-lwt,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec,mirage-crypto-rng-async
 
-  build-test-unix-eio:
-    name : Unix (eio)
+  build-test-ocaml-5:
+    name : Tests with OCaml 5
 
     strategy:
       fail-fast: false
@@ -57,13 +58,14 @@ jobs:
             mirage-crypto.opam
             mirage-crypto-rng.opam
             mirage-crypto-rng-eio.opam
+            mirage-crypto-rng-miou-unix.opam
           ocaml-compiler: ${{ matrix.ocaml-version }}
 
       - name: Install dependencies
-        run: opam install --deps-only -t mirage-crypto mirage-crypto-rng mirage-crypto-rng-eio
+        run: opam install --deps-only -t mirage-crypto mirage-crypto-rng mirage-crypto-rng-eio mirage-crypto-rng-miou-unix
 
       - name: Build
-        run: opam exec -- dune build -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-eio
+        run: opam exec -- dune build -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-eio,mirage-crypto-rng-miou-unix
 
       - name: Test
-        run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-eio
+        run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-eio,mirage-crypto-rng-miou-unix

.github/workflows/windows.yml

@@ -28,6 +28,7 @@ jobs:
             *.opam
             !mirage-crypto-rng-async.opam
             !mirage-crypto-rng-eio.opam
+            !mirage-crypto-rng-miou-unix.opam
           ocaml-compiler: ${{ matrix.ocaml-version }}
 
       - name: Install dependencies

bench/dune

@@ -3,3 +3,10 @@
  (modules speed)
  (libraries mirage-crypto mirage-crypto-rng mirage-crypto-rng.unix
    mirage-crypto-pk mirage-crypto-ec))
+
+; marking as "(optional)" leads to OCaml-CI failures
+; marking with "(package mirage-crypto-rng-miou-unix)" only has an effect with a "public_name"
+;(executables
+; (names miou)
+; (modules miou)
+; (libraries mirage-crypto-rng-miou-unix))

bench/miou.ml

@@ -0,0 +1,91 @@
+open Mirage_crypto
+
+module Time = struct
+
+  let time ~n f a =
+    let t1 = Sys.time () in
+    for _ = 1 to n do ignore (f a) done ;
+    let t2 = Sys.time () in
+    (t2 -. t1)
+
+  let warmup () =
+    let x = ref 0 in
+    let rec go start =
+      if Sys.time () -. start < 1. then begin
+        for i = 0 to 10000 do x := !x + i done ;
+        go start
+      end in
+    go (Sys.time ())
+
+end
+
+let burn_period = 2.0
+
+let sizes = [16; 64; 256; 1024; 8192]
+(* let sizes = [16] *)
+
+let burn f n =
+  let buf = Mirage_crypto_rng.generate n in
+  let (t1, i1) =
+    let rec loop it =
+      let t = Time.time ~n:it f buf in
+      if t > 0.2 then (t, it) else loop (it * 10) in
+    loop 10 in
+  let iters = int_of_float (float i1 *. burn_period /. t1) in
+  let time  = Time.time ~n:iters f buf in
+  (iters, time, float (n * iters) /. time)
+
+let mb = 1024. *. 1024.
+
+let throughput title f =
+  Printf.printf "\n* [%s]\n%!" title ;
+  sizes |> List.iter @@ fun size ->
+    Gc.full_major () ;
+    let (iters, time, bw) = burn f size in
+    Printf.printf "    % 5d:  %04f MB/s  (%d iters in %.03f s)\n%!"
+      size (bw /. mb) iters time
+
+let bm name f = (name, fun () -> f name)
+
+let benchmarks = [
+  bm "pfortuna" (fun name ->
+    let open Mirage_crypto_rng_miou_unix.Pfortuna in
+    Miou_unix.run ~domains:2 @@ fun () ->
+    let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+    let g = create () in
+    reseed ~g "abcd" ;
+    throughput name (fun buf ->
+        let buf = Bytes.unsafe_of_string buf in
+        generate_into ~g buf ~off:0 (Bytes.length buf));
+    Mirage_crypto_rng_miou_unix.kill rng) ;
+]
+
+let help () =
+  Printf.printf "available benchmarks:\n  ";
+  List.iter (fun (n, _) -> Printf.printf "%s  " n) benchmarks ;
+  Printf.printf "\n%!"
+
+let runv fs =
+  Format.printf "accel: %a\n%!"
+    (fun ppf -> List.iter @@ fun x ->
+      Format.fprintf ppf "%s " @@
+        match x with `XOR -> "XOR" | `AES -> "AES" | `GHASH -> "GHASH")
+    accelerated;
+  Time.warmup () ;
+  List.iter (fun f -> f ()) fs
+
+
+let () =
+  let seed = "abcd" in
+  let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in
+  Mirage_crypto_rng.set_default_generator g;
+  match Array.to_list Sys.argv with
+  | _::(_::_ as args) -> begin
+      try
+        let fs =
+          args |> List.map @@ fun n ->
+            snd (benchmarks |> List.find @@ fun (n1, _) -> n = n1) in
+        runv fs
+      with Not_found -> help ()
+    end
+  | _ -> help ()

mirage-crypto-rng-miou-unix.opam

@@ -0,0 +1,29 @@
+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.unix-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" {>= "0.2.0"}
+  "logs"
+  "mirage-crypto-rng" {=version}
+  "duration"
+  "mtime"
+  "digestif" {>= "1.2.0"}
+  "ohex" {with-test & >= "0.2.0"}
+]
+description: """
+Mirage-crypto-rng-miou-unix feeds the entropy source for Mirage_crypto_rng-based
+random number generator implementations, in an miou.unix-friendly way.
+"""

rng/fortuna.ml

@@ -1,3 +1,6 @@
+(* NOTE: when modifying this file, please also check whether
+   rng/miou/pfortuna.ml needs to be updated. *)
+
 open Mirage_crypto
 open Mirage_crypto.Uncommon
 

rng/miou/dune

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

rng/miou/mirage_crypto_rng_miou_unix.ml

@@ -0,0 +1,98 @@
+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.async ~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"
+
+let miou_generator_already_launched =
+  "Mirage_crypto_rng_miou.initialize has already been launched \
+   and a task is already seeding the RNG."
+
+type rng = unit Miou.t
+
+let rec compare_and_set ?(backoff= Miou_backoff.default) t a b =
+  if Atomic.compare_and_set t a b = false
+  then compare_and_set ~backoff:(Miou_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 call_if_domain_available fn =
+  let available = Miou.Domain.available () in
+  let current = (Stdlib.Domain.self () :> int) in
+  if current = 0 && available > 0
+  || current <> 0 && available > 1
+  then Miou.call fn
+  else Miou.async fn
+
+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 () =
+      try let _ = default_generator () in
+          Logs.warn (fun m -> m "%s" default_generator_already_set)
+      with No_default_generator -> () in
+    let rng = create ?g ~seed ~time:Mtime_clock.elapsed_ns rng in
+    set_default_generator rng;
+    call_if_domain_available @@ fun () -> switch @@ fun orphans ->
+    rdrand sleep;
+    let source = Entropy.register_source "getrandom" in
+    getrandom (Int64.mul sleep 10L) source;
+    clean_up sleep orphans
+  end else invalid_arg miou_generator_already_launched
+
+let kill prm =
+  Miou.cancel prm;
+  compare_and_set running true false;
+  unset_default_generator ()

rng/miou/mirage_crypto_rng_miou_unix.mli

@@ -0,0 +1,47 @@
+(** {b RNG} seeding on {b Miou_unix}.
+
+    This module initializes a RNG with [getrandom()], and CPU RNG. On BSD system
+    (FreeBSD, OpenBSD, MacOS) [getentropy()] is used instead of [getrandom()].
+    On Windows 10 or higher, [BCryptGenRandom()] is used with the default RNG.
+    Windows 8 or lower are not supported by this library.
+*)
+
+module Pfortuna : Mirage_crypto_rng.Generator
+(** {b Pfortuna}, a {b domain-safe} CSPRNG
+    {{: https://www.schneier.com/fortuna.html} proposed} by Schneier. *)
+
+type rng
+(** Type of tasks seeding the RNG. *)
+
+val initialize : ?g:'a -> ?sleep:int64 -> 'a Mirage_crypto_rng.generator -> rng
+(** [initialize ?g ?sleep (module Generator)] will allow the RNG to operate in a
+    returned task. This task periodically launches sub-tasks that seed the
+    engine (using [getrandom()], [getentropy()] or [BCryptGenRandom()] depending
+    on the system). These sub-tasks must be cleaned periodically (in seconds)
+    according to the [sleep] parameter given (defaults to 1 second).
+
+    The user must then {!val:kill} the returned task at the end of the program
+    to be sure to clean everything. Otherwise, Miou will complain with the
+    exception [Still_has_children].
+
+    We strongly recommend using {!module:Pfortuna} as an RNG engine rather than
+    {!module:Mirage_crypto_rng.Fortuna}. The engine is launched in parallel with
+    the other tasks if at least one domain is available. To ensure that there is
+    no compromise in the values generated by a {i data-race}, [Pfortuna] is an
+    {b domain-safe} implementation of Fortuna.
+
+    The user cannot make any subsequent calls to [initialize]. In other words,
+    you can only initialise a single {!type:rng} task. You must {!val:kill} the
+    returned {!type:rng} if you want to re-initialise the RNG.
+
+    A basic usage of [mirage-crypto-rng-miou-unix] is:
+    {[
+      let () = Miou_unix.run @@ fun () ->
+        let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+        let str = Mirage_crypto_rng.generate 16 in
+        Format.printf "random: %S\n%!" str;
+        Mirage_crypto_rng_miou_unix.kill rng
+    ]} *)
+
+val kill : rng -> unit
+(** [kill rng] terminates the {i background} task which seeds the RNG. *)