Source file `mirage_crypto_rng_mirage.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
(*
 * Copyright (c) 2014 Hannes Mehnert
 * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
 * Copyright (c) 2014-2016 David Kaloper Meršinjak
 * Copyright (c) 2015 Citrix Systems Inc
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * * Redistributions of source code must retain the above copyright notice, this
 *   list of conditions and the following disclaimer.
 *
 * * Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
 * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
 * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

let src = Logs.Src.create "mirage-crypto-rng-mirage" ~doc:"Mirage crypto RNG mirage"
module Log = (val Logs.src_log src : Logs.LOG)

open Mirage_crypto_rng

let rdrand_task delta =
  match Entropy.cpu_rng with
  | Error `Not_supported -> ()
  | Ok cpu_rng ->
    let open Lwt.Infix in
    let rdrand = cpu_rng None in
    Lwt.async (fun () ->
        let rec one () =
          rdrand ();
          Mirage_sleep.ns delta >>=
          one
        in
        one ())

let bootstrap_functions () =
  Entropy.[ bootstrap ; bootstrap ; whirlwind_bootstrap ; bootstrap ]

let running = ref false

let initialize (type a) ?g ?(sleep = Duration.of_sec 1) (rng : a generator) =
  if !running then
    Lwt.fail_with "entropy collection already running"
  else begin
    (try
       let _ = default_generator () in
       Log.warn (fun m -> m "Mirage_crypto_rng.default_generator has already \
                             been set, check that this call is intentional");
     with
       No_default_generator -> ());
    running := true;
    let seed =
      List.mapi (fun i f -> f i) (bootstrap_functions ()) |> String.concat ""
    in
    let rng = create ?g ~seed ~time:Mirage_mtime.elapsed_ns rng in
    set_default_generator rng;
    rdrand_task sleep;
    Mirage_runtime.at_enter_iter (Entropy.timer_accumulator None);
    Lwt.return_unit
  end