Coverage report: /home/ellis/comp/ext/ironclad/src/digests/sha256.lisp

Kind	Covered	All	%
expression	242	330	73.3
branch	2	4	50.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; sha256.lisp -- implementation of SHA-2/256 from NIST

2

(in-package :crypto)

3

(in-ironclad-readtable)

4

5

(define-digest-registers (sha224 :endian :big :digest-registers 7)

6

(a #xc1059ed8)

7

(b #x367cd507)

8

(c #x3070dd17)

9

(d #xf70e5939)

10

(e #xffc00b31)

11

(f #x68581511)

12

(g #x64f98fa7)

13

(h #xbefa4fa4))

14

15

(defconst +pristine-sha224-registers+ (initial-sha224-regs))

16

17

(define-digest-registers (sha256 :endian :big)

18

(a #x6a09e667)

19

(b #xbb67ae85)

20

(c #x3c6ef372)

21

(d #xa54ff53a)

22

(e #x510e527f)

23

(f #x9b05688c)

24

(g #x1f83d9ab)

25

(h #x5be0cd19))

26

27

(defconst +pristine-sha256-registers+ (initial-sha256-regs))

28

29

(defconst +sha256-round-constants+

30

#32@(#x428A2F98 #x71374491 #xB5C0FBCF #xE9B5DBA5 #x3956C25B #x59F111F1

31

#x923F82A4 #xAB1C5ED5 #xD807AA98 #x12835B01 #x243185BE #x550C7DC3

32

#x72BE5D74 #x80DEB1FE #x9BDC06A7 #xC19BF174 #xE49B69C1 #xEFBE4786

33

#x0FC19DC6 #x240CA1CC #x2DE92C6F #x4A7484AA #x5CB0A9DC #x76F988DA

34

#x983E5152 #xA831C66D #xB00327C8 #xBF597FC7 #xC6E00BF3 #xD5A79147

35

#x06CA6351 #x14292967 #x27B70A85 #x2E1B2138 #x4D2C6DFC #x53380D13

36

#x650A7354 #x766A0ABB #x81C2C92E #x92722C85 #xA2BFE8A1 #xA81A664B

37

#xC24B8B70 #xC76C51A3 #xD192E819 #xD6990624 #xF40E3585 #x106AA070

38

#x19A4C116 #x1E376C08 #x2748774C #x34B0BCB5 #x391C0CB3 #x4ED8AA4A

39

#x5B9CCA4F #x682E6FF3 #x748F82EE #x78A5636F #x84C87814 #x8CC70208

40

#x90BEFFFA #xA4506CEB #xBEF9A3F7 #xC67178F2))

41

42

(defun update-sha256-block (regs block)

43

(declare (type sha256-regs regs))

44

(declare (type (simple-array (unsigned-byte 32) (64)) block)

45

#.(burn-baby-burn))

46

(let ((a (sha256-regs-a regs)) (b (sha256-regs-b regs))

47

(c (sha256-regs-c regs)) (d (sha256-regs-d regs))

48

(e (sha256-regs-e regs)) (f (sha256-regs-f regs))

49

(g (sha256-regs-g regs)) (h (sha256-regs-h regs)))

50

(flet ((ch (x y z)

51

#+cmu

52

(kernel:32bit-logical-xor z

53

(kernel:32bit-logical-and x

54

                                                                  (kernel:32bit-logical-xor y z)))

55

#-cmu

56

(logxor z (logand x (logxor y z))))

57

(maj (x y z)

58

(ldb (byte 32 0) (logxor (logand x y) (logand x z)

59

(logand y z))))

60

(sigma0 (x)

61

(logxor (rol32 x 30) (rol32 x 19) (rol32 x 10)))

62

(sigma1 (x)

63

(logxor (rol32 x 26) (rol32 x 21) (rol32 x 7))))

64

#+ironclad-fast-mod32-arithmetic

65

(declare (inline ch maj sigma0 sigma1))

66

(macrolet ((sha256-round (i a b c d e f g h)

67

`(let ((x (mod32+ (sigma1 ,e)

68

(mod32+ (ch ,e ,f ,g)

69

(mod32+ ,h

70

                                                         (mod32+ (aref block ,i)

71

                                                                 (aref +sha256-round-constants+ ,i)))))))

72

(declare (type (unsigned-byte 32) x))

73

(setf ,d (mod32+ ,d x)

74

,h (mod32+ (sigma0 ,a)

75

(mod32+ (maj ,a ,b ,c) x))))))

76

;; Yay for "implementation-dependent" behavior (6.1.1.4).

77

#.(let ((xvars (make-circular-list 'a 'b 'c 'd 'e 'f 'g 'h)))

78

(loop for i from 0 below 64

79

for vars on xvars by #'(lambda (x) (nthcdr 7 x))

80

collect `(sha256-round ,i ,@(circular-list-subseq vars 0 8)) into forms

81

finally (return `(progn ,@forms))))

82

#.(loop for slot in '(a b c d e f g h)

83

collect (let ((regs-accessor (symbolicate '#:sha256-regs- slot)))

84

`(setf (,regs-accessor regs)

85

(mod32+ (,regs-accessor regs) ,slot))) into forms

86

finally (return `(progn ,@forms)))

87

regs))))

88

89

(defun sha256-expand-block (block)

90

(declare (type (simple-array (unsigned-byte 32) (64)) block)

91

#.(burn-baby-burn))

92

(flet ((sigma0 (x)

93

(declare (type (unsigned-byte 32) x))

94

(logxor (rol32 x 25) (rol32 x 14) (mod32ash x -3)))

95

(sigma1 (x)

96

(declare (type (unsigned-byte 32) x))

97

(logxor (rol32 x 15) (rol32 x 13) (mod32ash x -10))))

98

#+ironclad-fast-mod32-arithmetic

99

(declare (inline sigma0 sigma1))

100

(loop for i from 16 below 64 do

101

(setf (aref block i)

102

(mod32+ (sigma1 (aref block (- i 2)))

103

(mod32+ (aref block (- i 7))

104

(mod32+ (sigma0 (aref block (- i 15)))

105

(aref block (- i 16)))))))

106

(values)))

107

108

;;; mid-level

109

(defstruct (sha256

110

(:constructor %make-sha256-digest nil)

111

(:copier nil)

112

(:include mdx))

113

(regs (initial-sha256-regs) :type sha256-regs :read-only t)

114

(block (make-array 64 :element-type '(unsigned-byte 32))

115

:type (simple-array (unsigned-byte 32) (64)) :read-only t))

116

117

(defstruct (sha224

118

(:include sha256)

119

(:constructor %make-sha224-digest (&aux (regs (initial-sha224-regs))))

120

(:copier nil)))

121

122

(defmethod reinitialize-instance ((state sha256) &rest initargs)

123

(declare (ignore initargs))

124

(replace (sha256-regs state) +pristine-sha256-registers+)

125

(setf (sha256-amount state) 0

126

(sha256-buffer-index state) 0)

127

state)

128

129

(defmethod reinitialize-instance ((state sha224) &rest initargs)

130

(declare (ignore initargs))

131

(replace (sha224-regs state) +pristine-sha224-registers+)

132

(setf (sha224-amount state) 0

133

(sha224-buffer-index state) 0)

134

state)

135

136

(defmethod copy-digest ((state sha256) &optional copy)

137

(check-type copy (or null sha256))

138

(let ((copy (if copy

139

copy

140

(etypecase state

141

(sha224 (%make-sha224-digest))

142

(sha256 (%make-sha256-digest))))))

143

(declare (type sha256 copy))

144

(replace (sha256-regs copy) (sha256-regs state))

145

(replace (sha256-buffer copy) (sha256-buffer state))

146

(setf (sha256-amount copy) (sha256-amount state)

147

(sha256-buffer-index copy) (sha256-buffer-index state))

148

copy))

149

150

(define-digest-updater sha256

151

(flet ((compress (state sequence offset)

152

(let ((block (sha256-block state)))

153

(fill-block-ub8-be block sequence offset)

154

(sha256-expand-block block)

155

(update-sha256-block (sha256-regs state) block))))

156

(declare (dynamic-extent #'compress))

157

(declare (notinline mdx-updater))

158

(mdx-updater state #'compress sequence start end)))

159

160

(define-digest-finalizer ((sha256 32) (sha224 28))

161

(let ((regs (sha256-regs state))

162

(block (sha256-block state))

163

(buffer (sha256-buffer state))

164

(buffer-index (sha256-buffer-index state))

165

(total-length (* 8 (sha256-amount state))))

166

(declare (type sha256-regs regs)

167

(type (integer 0 63) buffer-index)

168

(type (simple-array (unsigned-byte 32) (64)) block)

169

(type (simple-array (unsigned-byte 8) (64)) buffer))

170

(setf (aref buffer buffer-index) #x80)

171

(when (> buffer-index 55)

172

(loop for index of-type (integer 0 64)

173

from (1+ buffer-index) below 64

174

do (setf (aref buffer index) #x00))

175

(fill-block-ub8-be block buffer 0)

176

(sha256-expand-block block)

177

(update-sha256-block regs block)

178

(loop for index of-type (integer 0 16)

179

from 0 below 16

180

do (setf (aref block index) #x00000000)))

181

(when (<= buffer-index 55)

182

(loop for index of-type (integer 0 64)

183

from (1+ buffer-index) below 64

184

do (setf (aref buffer index) #x00))

185

;; copy the data to BLOCK prematurely

186

(fill-block-ub8-be block buffer 0))

187

;; fill in the remaining block data

188

(store-data-length block total-length 14 t)

189

(sha256-expand-block block)

190

(update-sha256-block regs block)

191

(finalize-registers state regs)))

192

193

(defdigest sha256 :digest-length 32 :block-length 64)

194

(defdigest sha224 :digest-length 28 :block-length 64)