Use CryptGenRandom as a random seed on Windows.

Patch by Anton Kovalenko.
Fixes lp#1102748

diff --git a/NEWS b/NEWS
index 7a57a7c..ec02634 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes relative to sbcl-1.1.4:
   * enhancement: by setting SB-EXT:*ON-PACKAGE-VARIANCE* appropriately variant
     DEFPACKAGE forms can now signal a full error with restarts provided for
     resolving the situation. See manual for details. (lp#891351)
+  * enhancement: make-random-state now uses CryptGenRandom as a seed on Windows.
+    (Thanks to Anton Kovalenko.) (lp#1102748)
   * bug fix: secondary CLOS dispatch functions have better debug names.
     (lp#503081)
   * bug fix: deleting a package removes it from implementation-package

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 971ab42..bfab9b1 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2903,6 +2903,7 @@ SBCL itself"
                "CLOSE-HANDLE"
                "CREATE-FILE"
                "CREATE-FILE-MAPPING"
+               "CRYPT-GEN-RANDOM"
                "DWORD"
                "FD-CLEAR-INPUT"
                "FD-LISTEN"

diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp
index 073ec4e..aa36398 100644 (file)
--- a/src/code/target-random.lisp
+++ b/src/code/target-random.lisp
@@ -100,6 +100,35 @@ See SB-EXT:SEED-RANDOM-STATE for a SBCL extension to this functionality."
   (check-type state (or boolean random-state))
   (seed-random-state state))
 
+(defun fallback-random-seed ()
+  ;; When /dev/urandom is not available, we make do with time and pid
+  ;; Thread ID and/or address of a CONS cell would be even better, but...
+  (/show0 "No /dev/urandom, using randomness from time and pid")
+  (+ (get-internal-real-time)
+     (ash (sb!unix:unix-getpid) 32)))
+
+#!-win32
+(defun os-random-seed ()
+  (or
+   ;; On unices, we try to read from /dev/urandom and pass the results
+   ;; to our (simple-array (unsigned-byte 32) (*)) processor below.
+   ;; More than 256 bits would provide a false sense of security.
+   ;; If you need more bits than that, you probably also need
+   ;; a better algorithm too.
+   (ignore-errors
+    (with-open-file (r "/dev/urandom" :element-type '(unsigned-byte 32)
+                                      :direction :input :if-does-not-exist :error)
+      (let ((a (make-array '(8) :element-type '(unsigned-byte 32))))
+        (assert (= 8 (read-sequence a r)))
+        a)))
+   (fallback-random-seed)))
+
+#!+win32
+(defun os-random-seed ()
+  (/show0 "Getting randomness from CryptGenRandom")
+  (or (sb!win32:crypt-gen-random 32)
+      (fallback-random-seed)))
+
 (defun seed-random-state (&optional state)
   #!+sb-doc
   "Make a random state object. The optional STATE argument specifies a seed
@@ -139,26 +168,7 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
     ;; Standard case, less easy: try to randomly initialize a state.
     ((eql t)
      (/show0 "getting randomness from the operating system")
-     (seed-random-state
-      (or
-       ;; On unices, we try to read from /dev/urandom and pass the results
-       ;; to our (simple-array (unsigned-byte 32) (*)) processor below.
-       ;; More than 256 bits would provide a false sense of security.
-       ;; If you need more bits than that, you probably also need
-       ;; a better algorithm too.
-       #!-win32
-       (ignore-errors
-         (with-open-file (r "/dev/urandom" :element-type '(unsigned-byte 32)
-                            :direction :input :if-does-not-exist :error)
-           (let ((a (make-array '(8) :element-type '(unsigned-byte 32))))
-             (assert (= 8 (read-sequence a r)))
-             a)))
-       ;; When /dev/urandom is not available, we make do with time and pid
-       ;; Thread ID and/or address of a CONS cell would be even better, but...
-       (progn
-         (/show0 "No /dev/urandom, using randomness from time and pid")
-         (+ (get-internal-real-time)
-            (ash (sb!unix:unix-getpid) 32))))))
+     (seed-random-state (os-random-seed)))
     ;; For convenience to users, we accept (simple-array (unsigned-byte 8) (*))
     ;; We just convert it to (simple-array (unsigned-byte 32) (*)) in a
     ;; completely straightforward way.

diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index 3bdbf58..9c5cc97 100644 (file)
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -1184,3 +1184,38 @@ absense."
           (unwind-protect (funcall thunk fd)
             (real-crt-close fd)))
         (values nil errno))))
+
+;;; random seeding
+
+(define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool
+  (handle handle)
+  (length dword)
+  (buffer (* t)))
+
+(define-alien-routine (#!-sb-unicode "CryptAcquireContextA"
+                       #!+sb-unicode "CryptAcquireContextW"
+                       %crypt-acquire-context) lispbool
+  (handle handle :out)
+  (container system-string)
+  (provider system-string)
+  (provider-type dword)
+  (flags dword))
+
+(define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool
+  (handle handle)
+  (flags dword))
+
+(defun crypt-gen-random (length)
+  (multiple-value-bind (ok context)
+      (%crypt-acquire-context nil nil prov-rsa-full
+                              (logior crypt-verifycontext crypt-silent))
+    (unless ok
+      (return-from crypt-gen-random (values nil (get-last-error))))
+    (unwind-protect
+         (let ((data (make-array length :element-type '(unsigned-byte 8))))
+           (with-pinned-objects (data)
+             (if (%crypt-gen-random context length (vector-sap data))
+                 data
+                 (values nil (get-last-error)))))
+      (unless (%crypt-release-context context 0)
+        (win32-error '%crypt-release-context)))))

diff --git a/src/runtime/Config.x86-64-win32 b/src/runtime/Config.x86-64-win32
index 9fe5ce2..c4a2dba 100644 (file)
--- a/src/runtime/Config.x86-64-win32
+++ b/src/runtime/Config.x86-64-win32
@@ -30,7 +30,7 @@ OS_OBJS = # sbcl-win.res.o
 LINKFLAGS = -Wl,-export-all-symbols -Wl,mswin64.def -Wl,mswin.def
 
 
-OS_LIBS = -l ws2_32
+OS_LIBS = -l ws2_32 -ladvapi32
 ifdef LISP_FEATURE_SB_CORE_COMPRESSION
   OS_LIBS += -lz
 endif

diff --git a/src/runtime/Config.x86-win32 b/src/runtime/Config.x86-win32
index e858eaa..a6d2714 100644 (file)
--- a/src/runtime/Config.x86-win32
+++ b/src/runtime/Config.x86-win32
@@ -29,7 +29,7 @@ OS_SRC = win32-os.c x86-win32-os.c os-common.c pthreads_win32.c
 # interface, though.:-| As far as I (WHN 2002-05-19) know, no one is
 # working on one and it would be a nice thing to have.)
 LINKFLAGS = -Wl,-export-all-symbols -Wl,mswin.def
-OS_LIBS = -l ws2_32
+OS_LIBS = -l ws2_32 -ladvapi32
 ifdef LISP_FEATURE_SB_CORE_COMPRESSION
   OS_LIBS += -lz
 endif

diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c
index 49358a1..1d5d590 100644 (file)
--- a/src/runtime/win32-os.c
+++ b/src/runtime/win32-os.c
@@ -70,6 +70,7 @@ os_vm_size_t os_vm_page_size;
 #include "gc.h"
 #include "gencgc-internal.h"
 #include <winsock2.h>
+#include <wincrypt.h>
 
 #if 0
 int linux_sparc_siginfo_bug = 0;
@@ -2080,6 +2081,9 @@ void scratch(void)
 
     /* a function from shell32.dll */
     SHGetFolderPathA(0, 0, 0, 0, 0);
+
+    /* from advapi32.dll */
+    CryptGenRandom(0, 0, 0);
 }
 
 char *

diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c
index e1e0166..9a3e74d 100644 (file)
--- a/tools-for-build/grovel-headers.c
+++ b/tools-for-build/grovel-headers.c
@@ -30,6 +30,7 @@
   #define WIN32_LEAN_AND_MEAN
   #include <windows.h>
   #include <shlobj.h>
+  #include <wincrypt.h>
   #undef boolean
 #else
   #include <poll.h>
@@ -244,6 +245,10 @@ main(int argc, char *argv[])
     defconstant("STD_OUTPUT_HANDLE", STD_OUTPUT_HANDLE);
     defconstant("STD_ERROR_HANDLE", STD_ERROR_HANDLE);
 
+    printf(";;; WinCrypt\n");
+    defconstant("crypt-verifycontext", CRYPT_VERIFYCONTEXT);
+    defconstant("crypt-silent", CRYPT_SILENT);
+    defconstant("prov-rsa-full", PROV_RSA_FULL);
 
     /* FIXME: SB-UNIX and SB-WIN32 really need to be untangled. */
     printf("(in-package \"SB!UNIX\")\n\n");