Move key derivation functions to their own directory

4 files changed, 257 insertions, 0 deletions

diff --git a/src/kdf/kdf-common.lisp b/src/kdf/kdf-common.lisp
new file mode 100644
index 0000000..3b7f796
--- /dev/null
+++ b/src/kdf/kdf-common.lisp
@@ -0,0 +1,37 @@
+;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
+(in-package :crypto)
+
+(defgeneric derive-key (kdf passphrase salt iteration-count key-length))
+
+(defclass pbkdf1 ()
+  ((digest :reader kdf-digest)))
+
+(defclass pbkdf2 ()
+  ((digest-name :initarg :digest :reader kdf-digest)))
+
+(defclass scrypt-kdf ()
+ ((N :initarg :N :reader scrypt-kdf-N)
+  (r :initarg :r :reader scrypt-kdf-r)
+  (p :initarg :p :reader scrypt-kdf-p)))
+
+(defun make-kdf (kind &key digest (N 4096) (r 8) (p 2))
+  ;; PBKDF1, at least, will do stricter checking; this is good enough for now.
+  "digest is used for pbkdf1 and pbkdf2.
+   N, p, and r are cost factors for scrypt."
+  (case kind
+    ((pbkdf1 :pbkdf1)
+     (unless (digestp digest)
+       (error 'unsupported-digest :name digest))
+     (make-instance 'pbkdf1 :digest digest))
+    ((pbkdf2 :pbkdf2)
+     (unless (digestp digest)
+       (error 'unsupported-digest :name digest))
+     (make-instance 'pbkdf2 :digest digest))
+    ((scrypt-kdf :scrypt-kdf)
+     (when (or (<= N 1)
+               (not (zerop (logand N (1- N))))
+               (>= (* r p) (expt 2 30)))
+       (error 'unsupported-scrypt-cost-factors :N N :r r :p p))
+     (make-instance 'scrypt-kdf :N N :r r :p p))
+    (t
+     (error 'unsupported-kdf :kdf kind))))
diff --git a/src/kdf/password-hash.lisp b/src/kdf/password-hash.lisp
new file mode 100644
index 0000000..bd0b25f
--- /dev/null
+++ b/src/kdf/password-hash.lisp
@@ -0,0 +1,73 @@
+;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
+(in-package :crypto)
+
+(defun make-random-salt (&optional (size 16))
+  "Generate a byte vector of SIZE (default 16) random bytes, suitable
+for use as a password salt."
+  (random-data size))
+
+(defun pbkdf2-hash-password (password &key (salt (make-random-salt))
+                                           (digest 'sha256)
+                                           (iterations 1000))
+  "Given a PASSWORD as a byte vector, a SALT as a byte
+vector (MAKE-RANDOM-SALT is called to generate a random salt if none
+is provided), a digest function (SHA256 by default), and a number of
+iterations (1000), returns the PBKDF2-derived hash of the
+password (byte vector) as the first value, and the SALT (byte vector)
+as the second value."
+  (values (pbkdf2-derive-key digest password salt iterations (digest-length digest))
+          salt))
+
+(defun pbkdf2-hash-password-to-combined-string (password &key
+                                                (salt (make-random-salt))
+                                                (digest 'sha256)
+                                                (iterations 1000))
+  "Given a PASSWORD byte vector, a SALT as a byte vector (MAKE-RANDOM-SALT
+is called to generate a random salt if none is provided), a digest
+function (SHA256 by default), and a number of iterations (1000),
+returns the salt and PBKDF2-derived hash of the password encoded in a
+single ASCII string, suitable for use with PBKDF2-CHECK-PASSWORD."
+  (with-standard-io-syntax
+    (format nil "PBKDF2$~a:~a$~a$~a" digest iterations
+            (byte-array-to-hex-string salt)
+            (byte-array-to-hex-string
+             (pbkdf2-hash-password password :iterations iterations
+                                            :salt salt :digest digest)))))
+
+(defun constant-time-equal (data1 data2)
+  "Returns T if the elements in DATA1 and DATA2 are identical, NIL otherwise.
+All the elements of DATA1 and DATA2 are compared to prevent timing attacks."
+  (declare (type (simple-array (unsigned-byte 8) (*)) data1 data2)
+           (optimize (speed 3)))
+  (let ((res (if (= (length data1) (length data2)) 0 1)))
+    (declare (type (unsigned-byte 8) res))
+    (loop for d1 across data1
+          for d2 across data2
+          do (setf res (logior res (logxor d1 d2))))
+    (zerop res)))
+
+(defun pbkdf2-check-password (password combined-salt-and-digest)
+  "Given a PASSWORD byte vector and a combined salt and digest string
+produced by PBKDF2-HASH-PASSWORD-TO-COMBINED-STRING, checks whether
+the password is valid."
+  ;; can we have a dependency on regular expressions, please?
+  (let* ((positions (loop with start = 0 repeat 3 collect
+                         (setf start (position #\$ combined-salt-and-digest
+                                               :start (1+ start)))))
+         (digest-separator-position
+          (position #\: combined-salt-and-digest :start (first positions))))
+    (constant-time-equal
+     (pbkdf2-hash-password
+      password
+      :digest (find-symbol (subseq combined-salt-and-digest
+                                   (1+ (first positions))
+                                   digest-separator-position)
+                           '#:ironclad)
+      :iterations (parse-integer combined-salt-and-digest
+                                 :start (1+ digest-separator-position)
+                                 :end (second positions))
+      :salt (hex-string-to-byte-array combined-salt-and-digest
+                                      :start (1+ (second positions))
+                                      :end (third positions)))
+     (hex-string-to-byte-array combined-salt-and-digest
+                               :start (1+ (third positions))))))
diff --git a/src/kdf/pkcs5.lisp b/src/kdf/pkcs5.lisp
new file mode 100644
index 0000000..a1e48e5
--- /dev/null
+++ b/src/kdf/pkcs5.lisp
@@ -0,0 +1,85 @@
+;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
+(in-package :crypto)
+
+
+;;; PBKDF1 from RFC 2898, section 5.1
+
+(defmethod shared-initialize :after ((kdf pbkdf1) slot-names &rest initargs
+                                     &key digest &allow-other-keys)
+  (declare (ignore slot-names initargs))
+  (let ((digest-name (massage-symbol digest)))
+    (cond
+      ;; Permit DIGEST to be NULL to indicate reinitializing the whole
+      ;; instance.
+      ((cl:null digest)
+       (reinitialize-instance (kdf-digest kdf)))
+      ((not (digestp digest-name))
+       (error 'unsupported-digest :name digest-name))
+      ;; Don't cons unnecessarily.  (Although this depends how expensive
+      ;; TYPEP is with a non-constant type...)
+      ((and (slot-boundp kdf 'digest)
+            (typep (digest kdf) digest-name))
+       (reinitialize-instance (kdf-digest kdf)))
+      ((member digest-name '(md2 md5 sha1))
+       (setf (slot-value kdf 'digest)
+             (funcall (the function (get digest-name '%make-digest)))))
+      (t
+       (error 'ironclad-error
+              :format-control "Digest ~A not supported for PBKDF1"
+              :format-arguments (list digest))))
+    kdf))
+
+(defmethod derive-key ((kdf pbkdf1) passphrase salt iteration-count key-length)
+  (check-type iteration-count (integer 1 *))
+  (check-type key-length (integer 1 *))
+  (loop with digest = (kdf-digest kdf)
+     with digest-length = (digest-length digest)
+     with key = (make-array 20 :element-type '(unsigned-byte 8))
+     initially
+       (update-digest digest passphrase)
+       (update-digest digest salt)
+       (produce-digest digest :digest key)
+     for i from 1 below iteration-count
+     do
+       (reinitialize-instance digest)
+       (update-digest digest key :end digest-length)
+       (produce-digest digest :digest key)
+     finally
+       (return (subseq key 0 (min key-length (length key))))))
+
+
+;;; PBKDF2, from RFC 2898, section 5.2
+
+(defun pbkdf2-derive-key (digest passphrase salt iteration-count key-length)
+  (check-type iteration-count (integer 1 *))
+  (check-type key-length (integer 1 *))
+  (loop with count = 1
+     with hmac = (make-hmac passphrase digest)
+     with hmac-length = (digest-length digest)
+     with key = (make-array key-length :element-type '(unsigned-byte 8)
+                            :initial-element 0)
+     with key-position = 0
+     with count-buffer = (make-array 4 :element-type '(unsigned-byte 8))
+     with hmac-out = (make-array hmac-length :element-type '(unsigned-byte 8))
+     while (plusp key-length)
+     do (let ((size (min hmac-length key-length)))
+          (reinitialize-instance hmac :key passphrase)
+          (update-hmac hmac salt)
+          (setf (nibbles:ub32ref/be count-buffer 0) count)
+          (update-hmac hmac count-buffer)
+          (hmac-digest hmac :buffer hmac-out)
+          (xor-block size hmac-out key key-position key key-position)
+          (loop for i from 1 below iteration-count
+             do
+               (reinitialize-instance hmac :key passphrase)
+               (update-hmac hmac hmac-out)
+               (hmac-digest hmac :buffer hmac-out)
+               (xor-block size hmac-out key key-position key key-position)
+             finally
+               (decf key-length size)
+               (incf key-position size)
+               (incf count)))
+     finally (return key)))
+
+(defmethod derive-key ((kdf pbkdf2) passphrase salt iteration-count key-length)
+  (pbkdf2-derive-key (kdf-digest kdf) passphrase salt iteration-count key-length))
diff --git a/src/kdf/scrypt.lisp b/src/kdf/scrypt.lisp
new file mode 100644
index 0000000..eb3ec71
--- /dev/null
+++ b/src/kdf/scrypt.lisp
@@ -0,0 +1,62 @@
+;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
+(in-package :crypto)
+
+
+;;; scrypt from Colin Percival's
+;;; "Stronger Key Derivation via Sequential Memory-Hard Functions"
+;;; presented at BSDCan'09, May 2009.
+;;; http://www.tarsnap.com/scrypt.html
+
+(defun scrypt-vector-salsa (b)
+  (declare (type (simple-octet-vector 64) b))
+  (let ((x (make-array 16 :element-type '(unsigned-byte 32))))
+    (declare (type (simple-array (unsigned-byte 32) (16)) x))
+    (declare (dynamic-extent x))
+    (fill-block-ub8-le x b 0)
+    (salsa20/8-core b x)))
+
+(defun block-mix (b xy xy-start r)
+  (declare (type (simple-array (unsigned-byte 8) (*)) b xy))
+  ;; The derivation of the bound here is that (* I 64) in the first loop below
+  ;; must be a legitimate array index.  That loop runs to (* 2 R), hence the
+  ;; truncation by 128.  The subtraction of 64 comes from loops further down.
+  (declare (type (integer 0 (#.(truncate (- array-dimension-limit 64) 128))) r))
+  (let ((xs (make-array 64 :element-type '(unsigned-byte 8))))
+    (declare (type (simple-array (unsigned-byte 8) (64)) xs))
+    (declare (dynamic-extent xs))
+    (replace xs b :start2 (* 64 (1- (* 2 r))) :end1 64)
+    (dotimes (i (* 2 r))
+      (xor-block 64 xs b (* i 64) xs 0)
+      (scrypt-vector-salsa xs)
+      (replace xy xs :start1 (+ xy-start (* i 64)) :end2 64))
+    (dotimes (i r)
+      (replace b xy :start1 (* i 64) :end1 (+ 64 (* i 64)) :start2 (+ xy-start (* 64 2 i))))
+    (dotimes (i r)
+      (replace b xy :start1 (* 64 (+ i r)) :end1 (+ (* 64 (+ i r)) 64) :start2 (+ xy-start (* 64 (1+ (* i 2))))))))
+
+(defun smix (b b-start r N v xy)
+  (declare (type (simple-array (unsigned-byte 8) (*)) b v xy))
+  (declare (type (integer 0 (#.(truncate array-dimension-limit 128))) r))
+  (let ((x xy)
+        (xy-start (* 128 r))
+        (smix-length (* 128 r)))
+    (replace x b :end1 smix-length :start2 b-start)
+    (dotimes (i N)
+      (replace v x :start1 (* i smix-length) :end2 smix-length)
+      (block-mix x xy xy-start r))
+    (dotimes (i N)
+      (let ((j (ldb (byte 32 0) (logand (nibbles:ub64ref/le x (* (1- (* 2 r)) 64)) (1- N)))))
+        (xor-block smix-length x v (* j smix-length) x 0)
+        (block-mix x xy xy-start r)))
+    (replace b x :start1 b-start :end1 (+ b-start smix-length))))
+
+(defmethod derive-key ((kdf scrypt-kdf) passphrase salt iteration-count key-length)
+  (declare (ignore iteration-count))
+  (let* ((pb-kdf (make-kdf 'PBKDF2 :digest 'SHA256))
+         (xy (make-array (* 256 (scrypt-kdf-r kdf)) :element-type '(unsigned-byte 8)))
+         (v (make-array (* 128 (scrypt-kdf-r kdf) (scrypt-kdf-N kdf)) :element-type '(unsigned-byte 8)))
+         (b (derive-key pb-kdf passphrase salt 1 (* (scrypt-kdf-p kdf) 128 (scrypt-kdf-r kdf)))))
+    (dotimes (i (scrypt-kdf-p kdf))
+      (smix b (* i 128 (scrypt-kdf-r kdf)) (scrypt-kdf-r kdf) (scrypt-kdf-N kdf) v xy))
+    (reinitialize-instance pb-kdf :digest 'SHA256)
+    (derive-key pb-kdf passphrase b 1 key-length)))