Add finalizer for OS-PRNG to close /dev/urandom.

ironclad.asd

@@ -14,7 +14,7 @@
   :description "A cryptographic toolkit written in pure Common Lisp"
   :license "BSD 3-Clause"
   :default-component-class ironclad-source-file
-  :depends-on (#+sbcl "sb-rotate-byte" #+sbcl "sb-posix" "bordeaux-threads")
+  :depends-on (#+sbcl "sb-rotate-byte" #+sbcl "sb-posix" "bordeaux-threads" "trivial-garbage")
   :in-order-to ((test-op (test-op "ironclad/tests")))
   :components ((:static-file "LICENSE")
                (:static-file "NEWS")

src/prng/os-prng.lisp

@@ -9,32 +9,58 @@
 (defmethod prng-random-data (num-bytes (prng os-prng))
   #+unix
   (let ((seq (make-array num-bytes :element-type '(unsigned-byte 8))))
-    (unless (slot-boundp prng 'source)
-      (setf (slot-value prng 'source)
-            (open #P"/dev/urandom" :element-type '(unsigned-byte 8))))
-    (assert (>= (read-sequence seq (slot-value prng 'source)) num-bytes))
+    (unless (>= (read-sequence seq (slot-value prng 'source)) num-bytes)
+      (error 'ironclad-error :format-control "Failed to get random data."))
     seq)
-  #+(and win32 sb-dynamic-core)(sb-win32:crypt-gen-random num-bytes)
-  #+(and os-windows ccl) (multiple-value-bind (buff buffp)
-                             (ccl:make-heap-ivector num-bytes '(unsigned-byte 8))
-                           (when (= (ccl:external-call "SystemFunction036" :address buffp :unsigned-long num-bytes :boolean) 0)
-                             (error 'ironclad-error :format-control "RtlGenRandom failed"))
-                           (let ((copy (copy-seq buff)))
-                             (ccl:dispose-heap-ivector buff)
-                             (ccl:dispose-heap-ivector buffp)
-                             copy))
-  #+(and os-windows allegro) (let ((buff (make-array num-bytes :element-type '(unsigned-byte 8))))
-                               (when (= (rtl-gen-random buff num-bytes) 0)
-                                 (error 'ironclad-error :format-control "RtlGenRandom failed"))
-                               buff)
-  #+(and mswindows lispworks)(let ((buff (sys:in-static-area (make-array num-bytes :element-type '(unsigned-byte 8)))))
-                                (unless (fli:with-dynamic-lisp-array-pointer (buff buff) (rtl-gen-random buff num-bytes)) (error 'ironclad-error :format-control "RtlGenRandom failed"))
-                                (copy-seq buff))
-  #-(or unix (and win32 sb-dynamic-core) (and os-windows ccl) (and os-windows allegro) (and mswindows lispworks))(error 'ironclad-error :format-control "OS-RANDOM-SEED is not supported on your platform."))
+
+  #+(and win32 sb-dynamic-core)
+  (sb-win32:crypt-gen-random num-bytes)
+
+  #+(and os-windows ccl)
+  (multiple-value-bind (buff buffp)
+      (ccl:make-heap-ivector num-bytes '(unsigned-byte 8))
+    (when (zerop (ccl:external-call "SystemFunction036"
+                                    :address buffp
+                                    :unsigned-long num-bytes
+                                    :boolean))
+      (error 'ironclad-error :format-control "RtlGenRandom failed"))
+    (let ((copy (copy-seq buff)))
+      (ccl:dispose-heap-ivector buff)
+      (ccl:dispose-heap-ivector buffp)
+      copy))
+
+  #+(and os-windows allegro)
+  (let ((buff (make-array num-bytes :element-type '(unsigned-byte 8))))
+    (when (zerop (rtl-gen-random buff num-bytes))
+      (error 'ironclad-error :format-control "RtlGenRandom failed"))
+    buff)
+
+  #+(and mswindows lispworks)
+  (let ((buff (sys:in-static-area (make-array num-bytes :element-type '(unsigned-byte 8)))))
+    (unless (fli:with-dynamic-lisp-array-pointer (buff buff)
+              (rtl-gen-random buff num-bytes))
+      (error 'ironclad-error :format-control "RtlGenRandom failed"))
+    (copy-seq buff))
+
+  #-(or unix
+        (and win32 sb-dynamic-core)
+        (and os-windows ccl)
+        (and os-windows allegro)
+        (and mswindows lispworks))
+  (error 'ironclad-error
+         :format-control "OS-RANDOM-SEED is not supported on your platform."))
 
 (defmethod make-prng ((name (eql :os)) &key seed)
   (declare (ignorable seed))
-  (make-instance 'os-prng))
+  (let ((prng (make-instance 'os-prng)))
+    #+unix
+    (let ((source (open #P"/dev/urandom"
+                        #+ccl :sharing #+ccl :external
+                        :element-type '(unsigned-byte 8))))
+      (setf (slot-value prng 'source) source)
+      (trivial-garbage:finalize prng (lambda () (close source))))
+    prng))
 
 (setf *prng* (make-prng :os))
-#+thread-support(pushnew '(*prng* . (make-prng :os)) bt:*default-special-bindings* :test #'equal)
+#+thread-support
+(pushnew '(*prng* . (make-prng :os)) bt:*default-special-bindings* :test #'equal)