Windows fixes

_tags

@@ -14,6 +14,14 @@ true: package(bytes cstruct)
 <lwt>: include
 <lwt/*.ml{,i}>: package(lwt.unix cstruct.lwt)
 
+<windows>: include
+<windows/*.ml{,i}>: package(unix bytes)
+<windows/*.c>: ccopt(-lbcrypt -disable-shared -enable-static)
+<windows/*.cm{,x}a>: link_stubs(windows/libwindows_stubs)
+
+<lwt_windows>: include
+<lwt_windows/*.ml{,i}>: package(lwt lwt.unix cstruct.lwt)
+
 <mirage>: include
 <mirage/*.ml{,i}>: package(lwt mirage-entropy)
 

lwt_windows/nocrypto_entropy_lwt.ml

@@ -0,0 +1,54 @@
+open Lwt
+open Nocrypto
+
+let chunk  = 32
+and period = 30
+and device = Nocrypto_entropy_unix.sys_rng
+
+
+let mvar_map v f =
+  Lwt_mvar.take v >>= fun x ->
+    catch (fun () -> f x >>= Lwt_mvar.put v)
+          (fun exn -> Lwt_mvar.put v x >>= fun () -> fail exn)
+
+let some x = Some x
+
+type t = {
+  remove : (unit -> unit) Lwt_sequence.node ;
+  g      : Rng.g
+}
+
+let background ~period f =
+  let last   = ref Unix.(gettimeofday ())
+  and live   = ref false
+  and period = float period in
+  fun () ->
+    let t1 = !last
+    and t2 = Unix.gettimeofday () in
+    if (not !live) && (t2 -. t1 >= period) then begin
+      last := t2 ;
+      live := true ;
+      async @@ fun () -> f () >|= fun () -> live := false
+    end
+
+let attach ~period ?(device = device) g =
+  let seed () =
+    Lwt.return (Nocrypto_entropy_unix.read_cs chunk) >|= fun buf -> Rng.reseed ~g buf in
+  let remove =
+      Lwt_sequence.add_r (background ~period seed) Lwt_main.enter_iter_hooks in
+  Lwt.return { g ; remove }
+
+let stop t =
+  Lwt_sequence.remove t.remove ;
+  catch (fun () -> return_unit)
+    Unix.(function Unix_error (EBADF, _, _) -> return_unit | exn -> fail exn)
+
+let active = Lwt_mvar.create None
+
+let initialize () =
+  Nocrypto_entropy_unix.initialize () ;
+  let g = !Rng.generator in
+  mvar_map active @@ function
+    | Some t when t.g == g -> return (Some t)
+    | Some t               -> stop t >>= fun () -> attach ~period g >|= some
+    | None                 -> attach ~period g >|= some

lwt_windows/nocrypto_entropy_lwt.mli

@@ -0,0 +1,61 @@
+(** {b RNG} seeding on {b Lwt/Unix}.
+
+    This module provides RNG seeding from the Unix kernel RNG, typically
+    {[/dev/urandom]}. It uses {!Lwt} for periodic background reseeding.
+
+    Calling {{!initialize}initialize} is enough to bring the RNG into a working
+    state. In addition, a background task is set up to periodically reseed the
+    RNG.
+
+    [initialize] is idempotent as long as the default generator is unchanged.
+    It is harmless to call it several times.
+
+    Note that [initialize] returns a thread. While the reseeding task has only
+    been created once this thread completes, the initial seeding is done before
+    the function returns. Is is safe to use the RNG immediately after the
+    invocation.
+
+    {1 Usage}
+
+    Seed during module initialization, not waiting for the background seeding to
+    start:
+{[let _ = Nocrypto_entropy_lwt.initialize () ]}
+
+    Seed just before the main function, not waiting for the background seeding
+    to start:
+{[let () =
+  ignore (Nocrypto_entropy_lwt.initialize ());
+  Lwt_main.run (main ()) ]}
+
+    Seed just before the main function, and wait for the background seeding to
+    start before proceeding:
+{[let () =
+  Lwt_main.run (Nocrypto_entropy_lwt.initialize () >>= main) ]}
+
+*)
+
+
+(** {1 Default generator initialization} *)
+
+val initialize : unit -> unit Lwt.t
+(** Immediately seeds the current defalt generator using
+    {!Nocrypto_entropy_unix.initialize}. The initial seeding is finished before
+    the function returns.
+
+    It then invokes {{!attach}attach}. Once the returned thread completes, a
+    background reseeding task has been attached to the defalt generator. *)
+
+(** {1 Background seeding} *)
+
+type t
+(** Represents background reseeding task. *)
+
+val attach : period:int -> ?device:string -> Nocrypto.Rng.g -> t Lwt.t
+(** [attach ~period ~device g] instruments the lwt event loop to mix in bytes
+    from [device] into [g] whenever external events cause the loop to wake up,
+    but no more often than once every [period] seconds.
+
+    [device] defaults to {!Nocrypto_entropy_unix.sys_rng}. *)
+
+val stop : t -> unit Lwt.t
+(** Stops the reseeding task associated with [t]. Idempotent. *)

lwt_windows/nocrypto_lwt.mllib

@@ -0,0 +1 @@
+Nocrypto_entropy_lwt

pkg/pkg.ml

@@ -43,11 +43,15 @@ let () =
     and xen  = Conf.value c xen
     and fs   = Conf.value c fs in
     let mir  = Conf.value c mir in
-    Ok [ Pkg.clib "src/libnocrypto_stubs.clib";
+    let unix_module = if Sys.win32 then "windows/nocrypto_unix.mllib" else "unix/nocrypto_unix.mllib" in
+    let lwt_module = if Sys.win32 then "lwt_windows/nocrypto_lwt.mllib" else "lwt/nocrypto_lwt.mllib" in
+    let windows_stubs = if Sys.win32 then [ Pkg.clib "windows/libwindows_stubs.clib" ] else [] in
+    Ok ( 
+       [ Pkg.clib "src/libnocrypto_stubs.clib";
          Pkg.mllib "src/nocrypto.mllib";
-         Pkg.mllib ~cond:unix "unix/nocrypto_unix.mllib";
-         Pkg.mllib ~cond:lwt "lwt/nocrypto_lwt.mllib";
+         Pkg.mllib ~cond:unix unix_module;
+         Pkg.mllib ~cond:lwt lwt_module;
          Pkg.mllib ~cond:mir "mirage/nocrypto_mirage.mllib";
          Pkg.test "tests/testrunner";
          Pkg.test ~run:false "bench/speed";
-         mirage ~xen ~fs "src/libnocrypto_stubs.clib"; ]
+         mirage ~xen ~fs "src/libnocrypto_stubs.clib"; ] @ windows_stubs )

src/native/endian.h

@@ -1,29 +1,124 @@
-#if defined(__FreeBSD__) || defined(__DragonFly__) || defined(__NetBSD__) || defined(__OpenBSD__)
+//
+// endian.h
+//
+// https://gist.github.com/panzi/6856583
+//
+// I, Mathias Panzenböck, place this file hereby into the public domain. Use
+// it at your own risk for whatever you like. In case there are
+// jurisdictions that don't support putting things in the public domain you
+// can also consider it to be "dual licensed" under the BSD, MIT and Apache
+// licenses, if you want to. This code is trivial anyway. Consider it an
+// example on how to get the endian conversion functions on different
+// platforms.
 
-#include <sys/endian.h>
+#ifndef PORTABLE_ENDIAN_H__
+#define PORTABLE_ENDIAN_H__
+
+#if (defined(_WIN16) || defined(_WIN32) || defined(_WIN64)) && !defined(__WINDOWS__)
+
+#	define __WINDOWS__
+
+#endif
+
+#if defined(__linux__) || defined(__CYGWIN__)
+
+#	include <endian.h>
 
 #elif defined(__APPLE__)
 
-/* OS X endian.h doesn't provide be|le macros  */
-#include <machine/endian.h>
-#include <libkern/OSByteOrder.h>
-
-#define htobe16(x) OSSwapHostToBigInt16(x)
-#define htole16(x) OSSwapHostToLittleInt16(x)
-#define be16toh(x) OSSwapBigToHostInt16(x)
-#define le16toh(x) OSSwapLittleToHostInt16(x)
-#define htobe32(x) OSSwapHostToBigInt32(x)
-#define htole32(x) OSSwapHostToLittleInt32(x)
-#define be32toh(x) OSSwapBigToHostInt32(x)
-#define le32toh(x) OSSwapLittleToHostInt32(x)
-#define htobe64(x) OSSwapHostToBigInt64(x)
-#define htole64(x) OSSwapHostToLittleInt64(x)
-#define be64toh(x) OSSwapBigToHostInt64(x)
-#define le64toh(x) OSSwapLittleToHostInt64(x)
+#	include <libkern/OSByteOrder.h>
+
+#	define htobe16(x) OSSwapHostToBigInt16(x)
+#	define htole16(x) OSSwapHostToLittleInt16(x)
+#	define be16toh(x) OSSwapBigToHostInt16(x)
+#	define le16toh(x) OSSwapLittleToHostInt16(x)
+
+#	define htobe32(x) OSSwapHostToBigInt32(x)
+#	define htole32(x) OSSwapHostToLittleInt32(x)
+#	define be32toh(x) OSSwapBigToHostInt32(x)
+#	define le32toh(x) OSSwapLittleToHostInt32(x)
+
+#	define htobe64(x) OSSwapHostToBigInt64(x)
+#	define htole64(x) OSSwapHostToLittleInt64(x)
+#	define be64toh(x) OSSwapBigToHostInt64(x)
+#	define le64toh(x) OSSwapLittleToHostInt64(x)
+
+#	define __BYTE_ORDER    BYTE_ORDER
+#	define __BIG_ENDIAN    BIG_ENDIAN
+#	define __LITTLE_ENDIAN LITTLE_ENDIAN
+#	define __PDP_ENDIAN    PDP_ENDIAN
+
+#elif defined(__OpenBSD__)
+
+#	include <sys/endian.h>
+
+#elif defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__)
+
+#	include <sys/endian.h>
+
+#	define be16toh(x) betoh16(x)
+#	define le16toh(x) letoh16(x)
+
+#	define be32toh(x) betoh32(x)
+#	define le32toh(x) letoh32(x)
+
+#	define be64toh(x) betoh64(x)
+#	define le64toh(x) letoh64(x)
+
+#elif defined(__WINDOWS__)
+
+#	include <winsock2.h>
+#	include <sys/param.h>
+
+#	if BYTE_ORDER == LITTLE_ENDIAN
+#		define htobe16(x) htons(x)
+#		define htole16(x) (x)
+#		define be16toh(x) ntohs(x)
+#		define le16toh(x) (x)
+
+#		define htobe32(x) htonl(x)
+#		define htole32(x) (x)
+#		define be32toh(x) ntohl(x)
+#		define le32toh(x) (x)
+
+#		define htobe64(x) (x)
+#		define htole64(x) (x)
+#		define be64toh(x) (x)
+#		define le64toh(x) (x)
+
+#	elif BYTE_ORDER == BIG_ENDIAN
+
+		/* that would be xbox 360 */
+#		define htobe16(x) (x)
+#		define htole16(x) __builtin_bswap16(x)
+#		define be16toh(x) (x)
+#		define le16toh(x) __builtin_bswap16(x)
+
+#		define htobe32(x) (x)
+#		define htole32(x) __builtin_bswap32(x)
+#		define be32toh(x) (x)
+#		define le32toh(x) __builtin_bswap32(x)
+
+#		define htobe64(x) (x)
+#		define htole64(x) __builtin_bswap64(x)
+#		define be64toh(x) (x)
+#		define le64toh(x) __builtin_bswap64(x)
+
+#	else
+
+#		error byte order not supported
+
+#	endif
+
+#	define __BYTE_ORDER    BYTE_ORDER
+#	define __BIG_ENDIAN    BIG_ENDIAN
+#	define __LITTLE_ENDIAN LITTLE_ENDIAN
+#	define __PDP_ENDIAN    PDP_ENDIAN
 
 #else
 
-/* Needs _DEFAULT_SOURCE with glibc */
-#include <endian.h>
+#	error platform not supported
 
 #endif
+
+#endif

windows/libwindows_stubs.clib

@@ -0,0 +1 @@
+native/nocrypto_entropy_unix.o

windows/native/nocrypto_entropy_unix.c

@@ -0,0 +1,14 @@
+#include <caml/mlvalues.h>
+#include <windows.h>
+#include <bcrypt.h>
+
+CAMLprim value
+get_random_bytes(PUCHAR *pbBuffer)
+{
+    BCRYPT_ALG_HANDLE phAlgorithm;
+    BCryptOpenAlgorithmProvider(&phAlgorithm, BCRYPT_RSA_ALGORITHM, NULL, 0);
+    BCryptGenRandom(phAlgorithm, &pbBuffer, 32, 0);
+    BCryptCloseAlgorithmProvider(phAlgorithm, 0);
+
+    return Val_int(32);
+}

windows/nocrypto_entropy_unix.ml

@@ -0,0 +1,29 @@
+open Nocrypto
+open Uncommon
+
+let a_little = 32
+let a_lot =    1024
+
+
+let sys_rng = "BCryptGenRandom"
+
+external get_random_bytes: bytes -> int = "get_random_bytes"
+
+let read_cs n =
+    let buf = Bytes.create n in
+    let k = get_random_bytes buf in
+    let cs = Cstruct.create k in
+    Cstruct.blit_from_bytes buf 0 cs 0 k;
+    cs
+
+let reseed ?(bytes = a_little) ?(device = sys_rng) g =
+    let rec feed n =
+      if n > 0 then
+        let cs = read_cs(n) in
+        Rng.reseed ~g cs;
+        feed (n - Cstruct.len cs) in
+    feed bytes
+
+let initialize () =
+    let g = !Rng.generator in
+    if not (Rng.seeded (Some g)) then reseed ~bytes:a_lot g

windows/nocrypto_entropy_unix.mli

@@ -0,0 +1,45 @@
+(** {b RNG} seeding on {b Unix}.
+
+    This module provides one-shot RNG seeding from the Unix kernel RNG,
+    typically {[/dev/urandom]}.
+
+    Calling {{!initialize}initialize} is enough to bring the RNG into a working
+    state.
+
+    [initialize] is idempotent as long as the default generator is unchanged.
+    It is harmless to call it several times.
+
+    If you are using {b lwt}, conside using {!Nocrypto_entropy_lwt} as this
+    module allows for continuous reseeding.
+
+    Unless you want to recover from an unlikely case of missing system RNG, the
+    recommended way to prime the RNG is to invoke [initialize] at the module
+    level:
+
+{[let () = Nocrypto_entropy_unix.initialize () ]}
+
+*)
+
+(** {1 Default generator initialization} *)
+
+val initialize : unit -> unit
+(** Seeds the current defalt generator from the system RNG device if it is
+    currently unseeded.
+
+    This is the closest thing to {!Random.self_init} and is a good way to prime
+    the RNG. *)
+
+(** {1 Manual seeding} *)
+
+val sys_rng : string
+(** Detected system RNG device. *)
+
+val read_cs : int -> Cstruct.t
+
+val reseed : ?bytes:int -> ?device:string -> Nocrypto.Rng.g -> unit
+(** [reseed ~bytes ~g] mixes in [bytes] bytes from the system RNG into the
+    generator [g].
+
+    [bytes] default to a small value reasonable for periodic reseeding.
+
+    [device] defaults to {{!sys_rng}sys_rng}. *)

windows/nocrypto_unix.mllib

@@ -0,0 +1 @@
+Nocrypto_entropy_unix