Coverage report: /home/ellis/comp/ext/ironclad/src/prng/fortuna.lisp

KindCoveredAll%
expression38151 25.2
branch312 25.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; fortuna.lisp -- Fortuna PRNG
2
 (in-package :crypto)
3
 
4
 (defparameter +min-pool-size+
5
   128
6
   "Minimum pool size before a reseed is allowed.  This should be the
7
   number of bytes of pool data that are likely to contain 128 bits of
8
   entropy.  Defaults to a pessimistic estimate of 1 bit of entropy per
9
   byte.")
10
 
11
 (defparameter +fortuna-seed-length+ 64)
12
 
13
 (defclass fortuna-pool ()
14
   ((digest :initform (make-digest :sha256))
15
    (length :initform 0))
16
   (:documentation "A Fortuna entropy pool.  DIGEST contains its current
17
   state; LENGTH the length in bytes of the entropy it contains."))
18
 
19
 (defclass fortuna-prng ()
20
   ((pools :initform (loop for i from 1 to 32
21
                        collect (make-instance 'fortuna-pool)))
22
    (reseed-count :initform 0)
23
    (last-reseed :initform 0)
24
    (generator))
25
   (:documentation "A Fortuna random number generator.  Contains 32
26
   entropy pools which are used to reseed GENERATOR."))
27
 
28
 (defmethod prng-random-data (num-bytes (prng fortuna-prng))
29
   (when (plusp num-bytes)
30
     (with-slots (pools generator reseed-count last-reseed) prng
31
       (when (and (>= (slot-value (first pools) 'length) +min-pool-size+)
32
                  (> (- (get-internal-run-time) last-reseed) 100))
33
         (incf reseed-count)
34
         (loop for i from 0 below (length pools)
35
            with seed = (make-array (* (digest-length :sha256)
36
                                       (integer-length
37
                                        (logand reseed-count
38
                                                (- reseed-count))))
39
                                    :element-type '(unsigned-byte 8))
40
            while (zerop (mod reseed-count (expt 2 i)))
41
            collect (with-slots (digest length) (nth i pools)
42
                      (let ((digest-length (digest-length digest)))
43
                        (produce-digest digest
44
                                        :digest seed
45
                                        :digest-start (* i digest-length))
46
                        (reinitialize-instance digest)
47
                        (digest-sequence digest seed
48
                                         :digest seed
49
                                         :start (* i digest-length)
50
                                         :end (* (1+ i) digest-length)
51
                                         :digest-start (* i digest-length))
52
                        (setf length 0)
53
                        (reinitialize-instance digest)))
54
            finally (prng-reseed seed generator)))
55
       (assert (plusp reseed-count))
56
       (prng-random-data num-bytes generator))))
57
 
58
 (defun add-random-event (source pool-id event &optional (prng *prng*))
59
   (declare (type fortuna-prng prng))
60
   (assert (and (<= 1 (length event) 32)
61
                (<= 0 source 255)
62
                (<= 0 pool-id 31)))
63
   (let ((pool (nth pool-id (slot-value prng 'pools))))
64
     (update-digest (slot-value pool 'digest)
65
                             (concatenate '(vector (unsigned-byte 8))
66
                                          (integer-to-octets source)
67
                                          (integer-to-octets
68
                                           (length event))
69
                                          event))
70
     (incf (slot-value pool 'length) (length event))))
71
 
72
 (defmethod prng-seed-length ((prng fortuna-prng))
73
   +fortuna-seed-length+)
74
 
75
 (defmethod prng-reseed (seed (prng fortuna-prng))
76
   (declare (type simple-octet-vector seed))
77
   (assert (= (length seed) +fortuna-seed-length+))
78
   (prng-reseed seed (slot-value prng 'generator))
79
   (incf (slot-value prng 'reseed-count)))
80
 
81
 (defun make-fortuna (cipher)
82
   (let ((prng (make-instance 'fortuna-prng)))
83
     (setf (slot-value prng 'generator)
84
           (make-instance 'fortuna-generator :cipher cipher))
85
     prng))
86
 
87
 (defmethod make-prng ((name (eql :fortuna)) &key seed (cipher :aes))
88
   (declare (ignorable seed))
89
   (make-fortuna cipher))
90
 
91
 ;; FIXME: this is more than a little ugly; maybe there should be a
92
 ;; prng-registry or something?
93
 (defmethod make-prng ((name (eql 'fortuna)) &key seed (cipher :aes))
94
   (declare (ignorable seed))
95
   (make-fortuna cipher))