137 lines
4.4 KiB
OCaml
137 lines
4.4 KiB
OCaml
(* 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
|