Coverage report: /home/ellis/comp/ext/ironclad/src/digests/tree-hash.lisp

KindCoveredAll%
expression0224 0.0
branch024 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; tree-hash.lisp
2
 (in-package :crypto)
3
 ;;; See the spec at
4
 ;;; http://zgp.org/pipermail/p2p-hackers/2002-June/000621.html
5
 (defparameter *leaf-byte* (make-array 1 :element-type '(unsigned-byte 8)
6
                                       :initial-element 0))
7
 (defparameter *internal-byte* (make-array 1 :element-type '(unsigned-byte 8)
8
                                           :initial-element 1))
9
 
10
 (defun make-tree-hash-leaf-digest (digest-spec)
11
   (let ((digest (make-digest digest-spec)))
12
     (update-digest digest *leaf-byte*)
13
     digest))
14
 
15
 (defstruct (tree-hash
16
              (:constructor %make-tree-hash nil)
17
              (:constructor %make-tree-hash-state (block-length state block-index branch))
18
              (:copier nil))
19
   (block-length 1024 :type (integer 1 #.most-positive-fixnum))
20
   (state (make-tree-hash-leaf-digest :tiger))
21
   (block-index 0 :type (integer 0 #.most-positive-fixnum))
22
   (branch () :type list))
23
 
24
 (defun %make-tree-hash-digest (&key (digest :tiger) (block-length 1024))
25
   (%make-tree-hash-state block-length (make-tree-hash-leaf-digest digest) 0 '()))
26
 
27
 (defun make-tiger-tree-hash ()
28
   (%make-tree-hash-digest))
29
 
30
 (defmethod block-length ((x tree-hash))
31
   (tree-hash-block-length x))
32
 
33
 (defmethod digest-length ((x tree-hash))
34
   (digest-length (tree-hash-state x)))
35
 
36
 (defmethod reinitialize-instance ((state tree-hash) &rest initargs)
37
   (declare (ignore initargs))
38
   (reinitialize-instance (tree-hash-state state))
39
   (update-digest (tree-hash-state state) *leaf-byte*)
40
   (setf (tree-hash-block-index state) 0)
41
   (setf (tree-hash-branch state) '())
42
   state)
43
 
44
 (defmethod copy-digest ((state tree-hash) &optional copy)
45
   (check-type copy (or null tree-hash))
46
   (cond
47
     (copy
48
      (copy-digest (tree-hash-state state) (tree-hash-state copy))
49
      (setf (tree-hash-block-length copy) (tree-hash-block-length state))
50
      (setf (tree-hash-block-index copy) (tree-hash-block-index state))
51
      (setf (tree-hash-branch copy) (tree-hash-branch state))
52
      copy)
53
     (t
54
      (%make-tree-hash-state
55
       (tree-hash-block-length state)
56
       (copy-digest (tree-hash-state state))
57
       (tree-hash-block-index state)
58
       (tree-hash-branch state)))))
59
 
60
 (define-digest-updater tree-hash
61
   "Update the given tree-hash state from sequence,
62
 which is a simple-array with element-type (unsigned-byte 8),
63
 bounded by start and end, which must be numeric bounding-indices."
64
   (assert (<= start end))
65
   (when (< start end)
66
     (loop :with block-length = (tree-hash-block-length state)
67
       :with digest = (tree-hash-state state)
68
       :for length fixnum = (- end start)
69
       :for block-index fixnum = (tree-hash-block-index state) :then 0
70
       :for block-remaining-length fixnum = (- block-length block-index)
71
       :for current-length fixnum = (min block-remaining-length length)
72
       :for new-index fixnum = (+ block-index current-length)
73
       :for new-start fixnum = (+ start current-length) :do
74
       (update-digest digest sequence :start start :end new-start)
75
       (when (= new-index block-length)
76
         (update-tree-hash-branch state)
77
         (reinitialize-instance digest)
78
         (update-digest digest *leaf-byte*)
79
         (setf new-index 0))
80
       (setf start new-start)
81
       (when (= start end)
82
         (setf (tree-hash-block-index state) new-index)
83
         (return)))))
84
 
85
 (defun update-tree-hash-branch (state)
86
   (let ((digest (tree-hash-state state)))
87
     (setf (tree-hash-branch state)
88
           (merge-tree-hash-branch digest (tree-hash-branch state) (produce-digest digest)))))
89
 
90
 (defun merge-tree-hash-branch (digest branch hash)
91
   (let ((other-hash (car branch)))
92
     (if (null other-hash)
93
         (cons hash (cdr branch)) ;; happens to work when branch is nil!
94
         (cons nil (merge-tree-hash-branch
95
                    digest
96
                    (cdr branch)
97
                    (combine-hash-tree-digests digest other-hash hash))))))
98
 
99
 (defun combine-hash-tree-digests (digest hash1 hash2)
100
   (reinitialize-instance digest)
101
   (update-digest digest *internal-byte*)
102
   (update-digest digest hash1)
103
   (update-digest digest hash2)
104
   (produce-digest digest))
105
 
106
 (defmethod produce-digest ((state tree-hash) &key digest (digest-start 0))
107
   (let ((state (copy-digest state)))
108
     (when (or (not (zerop (tree-hash-block-index state)))
109
               (null (tree-hash-branch state)))
110
       (update-tree-hash-branch state))
111
     (let* ((internal-state (tree-hash-state state))
112
            (result
113
              (reduce (lambda (hash2 hash1)
114
                        (cond
115
                          ((null hash2) hash1)
116
                          ((null hash1) hash2)
117
                          (t (combine-hash-tree-digests internal-state hash1 hash2))))
118
                      (tree-hash-branch state))))
119
       (if digest
120
           (if (<= (length result) (- (length digest) digest-start))
121
               (replace digest result :start1 digest-start)
122
               (error 'insufficient-buffer-space
123
                      :buffer digest :start digest-start
124
                      :length (length result)))
125
           result))))
126
 
127
 (setf (get 'tree-hash '%digest-length) 24)
128
 (setf (get 'tree-hash '%make-digest) (symbol-function '%make-tree-hash-digest))