Coverage report: /home/ellis/comp/ext/ironclad/src/macs/hmac.lisp

KindCoveredAll%
expression103129 79.8
branch12 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; hmac.lisp -- RFC 2104 keyed hashing for message authentication
2
 (in-package :crypto)
3
 
4
 (defclass hmac (mac)
5
   ((inner-digest :reader inner-digest :initarg :inner-digest)
6
    (outer-digest :reader outer-digest :initarg :outer-digest)))
7
 
8
 (defmethod print-object ((mac hmac) stream)
9
   (print-unreadable-object (mac stream :type nil :identity t)
10
     (format stream "HMAC(~A)" (type-of (inner-digest mac)))))
11
 
12
 (defun make-hmac (key digest-name)
13
   (make-instance 'hmac :key key
14
                  :inner-digest (make-digest digest-name)
15
                  :outer-digest (make-digest digest-name)))
16
 
17
 (defmethod reinitialize-instance ((mac hmac) &rest initargs
18
                                   &key key &allow-other-keys)
19
   (declare (ignore key initargs))
20
   (reinitialize-instance (inner-digest mac))
21
   (reinitialize-instance (outer-digest mac))
22
   (call-next-method))
23
 
24
 (defmethod shared-initialize :after ((mac hmac) slot-names &rest initargs
25
                               &key key &allow-other-keys)
26
   (declare (ignore slot-names initargs))
27
   (declare (type (simple-array (unsigned-byte 8) (*)) key))
28
   (let* ((inner (inner-digest mac))
29
          (outer (outer-digest mac))
30
          (block-length (block-length inner))
31
          (inner-padding (make-array block-length
32
                                     :element-type '(unsigned-byte 8)
33
                                     :initial-element #x36))
34
          (outer-padding (make-array block-length
35
                                     :element-type '(unsigned-byte 8)
36
                                     :initial-element #x5c))
37
          (padded-key (make-array block-length
38
                                  :element-type '(unsigned-byte 8)
39
                                  :initial-element 0)))
40
     (declare (type simple-octet-vector
41
                    inner-padding outer-padding padded-key)
42
              (fixnum block-length))
43
     ;; XXX: SBCL bogusly ignores this because we use :INITIAL-ELEMENT.
44
     ;; see also https://bugs.launchpad.net/sbcl/+bug/902351
45
     (declare (dynamic-extent inner-padding outer-padding padded-key))
46
     (when (> (length key) block-length)
47
       (setf key (digest-sequence (type-of inner) key)))
48
     (replace padded-key key)
49
     (xor-block block-length padded-key 0 inner-padding 0 inner-padding 0)
50
     (update-digest inner inner-padding)
51
     (xor-block block-length padded-key 0 outer-padding 0 outer-padding 0)
52
     (update-digest outer outer-padding)
53
     mac))
54
 
55
 (defun update-hmac (hmac sequence &key (start 0) (end (length sequence)))
56
   (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
57
   (update-digest (inner-digest hmac) sequence :start start :end end)
58
   hmac)
59
 
60
 (defun hmac-digest (hmac &key buffer (buffer-start 0))
61
   (let* ((x (copy-digest (inner-digest hmac)))
62
          (inner-hash (produce-digest x :digest buffer :digest-start buffer-start)))
63
     (copy-digest (outer-digest hmac) x)
64
     (update-digest x inner-hash :digest buffer :digest-start buffer-start)
65
     (produce-digest x :digest buffer :digest-start buffer-start)))
66
 
67
 (defmac hmac
68
         make-hmac
69
         update-hmac
70
         hmac-digest)