diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c1a8bb0e..ca16e909 100644 --- a/.github/workflows/test.yml +++ b/.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 diff --git a/.github/workflows/windows.yml b/.github/workflows/windows.yml index 4f97944f..3bf05ee7 100644 --- a/.github/workflows/windows.yml +++ b/.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 diff --git a/bench/dune b/bench/dune index 63558d89..dec1e4f9 100644 --- a/bench/dune +++ b/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)) diff --git a/bench/miou.ml b/bench/miou.ml new file mode 100644 index 00000000..27120c32 --- /dev/null +++ b/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 () diff --git a/mirage-crypto-rng-miou-unix.opam b/mirage-crypto-rng-miou-unix.opam new file mode 100644 index 00000000..4a04a259 --- /dev/null +++ b/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 " ] +maintainer: "Romain Calascibetta " +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. +""" diff --git a/rng/fortuna.ml b/rng/fortuna.ml index db494da2..e83feab5 100644 --- a/rng/fortuna.ml +++ b/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 diff --git a/rng/miou/dune b/rng/miou/dune new file mode 100644 index 00000000..7c97c9e9 --- /dev/null +++ b/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)) diff --git a/rng/miou/mirage_crypto_rng_miou_unix.ml b/rng/miou/mirage_crypto_rng_miou_unix.ml new file mode 100644 index 00000000..82ecdbf7 --- /dev/null +++ b/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 () diff --git a/rng/miou/mirage_crypto_rng_miou_unix.mli b/rng/miou/mirage_crypto_rng_miou_unix.mli new file mode 100644 index 00000000..057afbc8 --- /dev/null +++ b/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. *) diff --git a/rng/miou/pfortuna.ml b/rng/miou/pfortuna.ml new file mode 100644 index 00000000..fa1ec409 --- /dev/null +++ b/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 diff --git a/rng/miou/pfortuna.mli b/rng/miou/pfortuna.mli new file mode 100644 index 00000000..398c3c05 --- /dev/null +++ b/rng/miou/pfortuna.mli @@ -0,0 +1 @@ +include Mirage_crypto_rng.Generator diff --git a/rng/mirage_crypto_rng.mli b/rng/mirage_crypto_rng.mli index fd171f52..3c7855a6 100644 --- a/rng/mirage_crypto_rng.mli +++ b/rng/mirage_crypto_rng.mli @@ -25,7 +25,8 @@ {{!Mirage_crypto_rng_async}mirage-crypto-rng-async} (for Async), {{!Mirage_crypto_rng_mirage}mirage-crypto-rng-mirage} (for MirageOS), {{!Mirage_crypto_rng_unix}mirage-crypto-rng.unix}, - and {{!Mirage_crypto_rng_eio}mirage-crypto-rng-eio} (for Eio). + {{!Mirage_crypto_rng_eio}mirage-crypto-rng-eio} (for Eio), + and {{!Mirage_crypto_rng_miou_unix}mirage-crypto-miou-unix} (for Miou_unix). The intention is that "initialize" in the respective sub-library is called once, which sets the default generator and registers entropy diff --git a/tests/dune b/tests/dune index 05ae7adb..b06e9201 100644 --- a/tests/dune +++ b/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-unix duration ohex) + (package mirage-crypto-rng-miou-unix)) diff --git a/tests/test_miou_entropy_collection.ml b/tests/test_miou_entropy_collection.ml new file mode 100644 index 00000000..57ad3eab --- /dev/null +++ b/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_unix.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_unix.kill rng diff --git a/tests/test_miou_rng.ml b/tests/test_miou_rng.ml new file mode 100644 index 00000000..1cd5dcb8 --- /dev/null +++ b/tests/test_miou_rng.ml @@ -0,0 +1,16 @@ +let () = Miou_unix.run @@ fun () -> + let rng = Mirage_crypto_rng_miou_unix.(initialize (module 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%!" (Ohex.encode 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%!" (Ohex.encode random_num); + (* NOTE(dinosaure): the test below shows that [Pfortuna] is domain-safe when + run with TSan. If we use the Fortuna engine, TSan will report invalid + accesses between the domain that seeds the RNG and [dom0]. *) + for _ = 0 to 4 do + let _ = Mirage_crypto_rng.generate 16 in + Miou_unix.sleep 0.5; + done; + Mirage_crypto_rng_miou_unix.kill rng