unikernel/duniverse/mirage-crypto/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))

unikernel/duniverse/mirage-crypto/rng/miou/mirage_crypto_rng_miou_unix.ml

@@ -0,0 +1,101 @@
+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;
+      Ok (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 ()

unikernel/duniverse/mirage-crypto/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. *)

unikernel/duniverse/mirage-crypto/rng/miou/pfortuna.ml

@@ -0,0 +1,137 @@
+(* Pfortuna is a re-implementation of Fortuna with a mutex. The goal of this
+   module is to provide a global and domain-safe RNG. The implementation use
+   [Miou.Mutex] instead of [Mutex] - [Pfortuna] is only available as part of
+   the [mirage-crypto-rng-miou-unix] package. Thus, in the context of Miou,
+   [Pfortuna] can be used and recommended in place of [Fortuna], so that the
+   user can generate random numbers in parallel in several domains.
+
+   {[
+     let () = Miou_unix.run @@ fun () ->
+       let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+       ...
+       Mirage_crypto_rng_miou_unix.kill rng
+   ]}
+
+   NOTE: when modifying this file, please also check whether rng/fortuna.ml
+   needs to be updated. *)
+
+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

unikernel/duniverse/mirage-crypto/rng/miou/pfortuna.mli

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