Ideal `ENTROPY` from the perspective of Fortuna

entropy.ml

(*
 The ideal interface for an entropy-device from the perspective of Fortuna.
*)

module type ENTROPY = sig

  (* With a pull-based design, there is the problem of wasted work. Since the
   * client of the entropy does not know how often there is something worth
   * checking, it might do it too frequently / infrequently. If it stalls, there
   * is the added problem of accumulating unbounded entropy in the provider (we
   * probably can't access hashes at this level, plus, that would be a RNG-level
   * thing to do).
   *
   * Instead, an entropy device should signal that it has **some** (no
   * guarantees here) bits to announce and hand them off the whoever is
   * listening. The frequency of this is in tune with the system's actual
   * ability to collect new noise - our handler can be called from various
   * parts of the system and get, for example, their internal timings etc.
   *
   * The `source` distinguished sources. It's expected to be a small number
   * (around a byte) and it plays in with fortuna's internal entropy gathering
   * logic.
   *
   * The Cstruct.t is whatever bits of noise the source can muster. It's up to
   * the handler to convert those into usable RNG.
   *
   * The contract is that the handler is non-blocking and actually *fast*, so
   * that it can frequently be fed with odd bits of noise from various sources
   * in the system.
   *
   *)

  type handler : source:int -> Cstruct.t -> unit
  val handler : handler -> unit

  val start : unit -> unit Lwt.t

end

(* On unix, we can easily mock the entire arrangement with /dev/urandom. *)

module Unix_entropy (T : V1_LWT.TIME) : ENTROPY = struct

  let period = 1.
  and source = "/dev/urandom"

  let h = ref None

  let handler f = h := Some f

  let refeed fd =
    match !h with
    | None   -> ()
    | Some f ->
        let cs = Cstruct.create 17 in
        Lwt_cstruct.(complete (read fd) cs) >>= fun _ ->
          f (Cstruct.get_uint8 cs 0) (Cstruct.sub cs 1 16) ;

  let start () =
    let rec loop fd = refeed fd >> T.sleep period >> loop fd
    in
    lwt fd = Lwt_unix.openfile [Unix.O_RDONLY] 0 source in
    refeed fd >> async (loop fd)

end