From: Stas Boukarev Date: Fri, 1 Feb 2013 11:57:41 +0000 (+0800) Subject: Use CryptGenRandom as a random seed on Windows. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5f0bd05a15aaf93f46baf9b8aa3e9b0bfbca26ab;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 +#include #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 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -30,6 +30,7 @@ #define WIN32_LEAN_AND_MEAN #include #include + #include #undef boolean #else #include @@ -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");