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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
(*
 * 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.
 *)

module type S = sig
  type g = Mirage_crypto_rng.g
  module Entropy :
    sig
      type source = Mirage_crypto_rng.Entropy.source
      val sources : unit -> source list
      val pp_source : Format.formatter -> source -> unit
      val register_source : string -> source
    end

  val generate_into : ?g:g -> bytes -> ?off:int -> int -> unit
  val generate : ?g:g -> int -> string

  val accumulate : g option -> Entropy.source -> [`Acc of string -> unit]
end

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

module Make (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = struct
  include 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 ();
            T.sleep_ns delta >>=
            one
          in
          one ())

  let bootstrap_functions () =
    [ Entropy.bootstrap ; Entropy.bootstrap ;
      Entropy.whirlwind_bootstrap ; Entropy.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:M.elapsed_ns rng in
      set_default_generator rng;
      rdrand_task sleep;
      Mirage_runtime.at_enter_iter (Entropy.timer_accumulator None);
      Lwt.return_unit
    end
end