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

Kind	Covered	All	%
expression	7	286	2.4
branch	0	8	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; whirlpool.lisp

2

;;;; This file implements the Whirlpool message-digest algoritm, as

3

;;;; defined in The WHIRLPOOL Hashing Function, by Paulo S.L.M. Barreto1

4

;;;; and Vincent Rijmen, revised on Revised on May 24, 2003 (1).

5

6

;;;; It was written by Peter Gijsels.

7

8

9

10

;;;; This software is "as is", and has no warranty of any kind. The

11

;;;; authors assume no responsibility for the consequences of any use of

12

;;;; this software.

13

(in-package :crypto)

14

15

(eval-when (:compile-toplevel :load-toplevel :execute)

16

(deftype whirlpool-regs () '(simple-array (unsigned-byte 32) (64)))

17

(defun initial-whirlpool-regs ()

18

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

19

(defconstant +whirlpool-regs-hash-offset+ 0)

20

(defconstant +whirlpool-regs-k-offset+ 16)

21

(defconstant +whirlpool-regs-state-offset+ 32)

22

(defconstant +whirlpool-regs-l-offset+ 48)) ; EVAL-WHEN

23

24

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

25

26

(defun whirlpool-regs-digest (regs buffer &optional (start 0))

27

(declare (type whirlpool-regs regs)

28

(type (integer 0 #.(- array-dimension-limit 64)) start))

29

(flet ((stuff-registers (buffer start)

30

(dotimes (i 16 buffer)

31

(setf (ub32ref/be buffer (+ start (* 4 i))) (aref regs i)))))

32

(declare (inline stuff-registers))

33

(cond

34

(buffer (stuff-registers buffer start))

35

(t (stuff-registers (make-array 64 :element-type '(unsigned-byte 8)) 0)))))

36

37

(eval-when (:compile-toplevel :load-toplevel :execute)

38

(defconstant +whirlpool-rounds+ 10 "The number of rounds. The default is 10."))

39

40

(eval-when (:compile-toplevel)

41

;;; Code to generate lookup tables +C-EVEN+ and +C-ODD+.

42

(defconst +e+ #(#x1 #xB #x9 #xC #xD #x6 #xF #x3 #xE #x8 #x7 #x4 #xA #x2 #x5 #x0))

43

(defconst +r+ #(#x7 #xC #xB #xD #xE #x4 #x9 #xF #x6 #x3 #x8 #xA #x2 #x5 #x1 #x0))

44

45

(defun e (i) (aref +e+ i))

46

47

(defun r (i) (aref +r+ i))

48

49

(defun e-1 (i) (position i +e+))

50

51

(defun byte-xor (i1 i2) (logxor i1 i2))

52

53

(defun s-internal (u v)

54

"The S-box internals. Corresponds to equations on page 10 of (1)."

55

(let ((r (r (byte-xor (e u) (e-1 v)))))

56

(values (e (byte-xor (e u) r))

57

(e-1 (byte-xor (e-1 v) r)))))

58

59

(defun s (i)

60

"The S-box function."

61

(let ((u (ldb (byte 4 4) i))

62

(v (ldb (byte 4 0) i)))

63

(multiple-value-bind (u_ v_) (s-internal u v)

64

(let ((result 0))

65

(setf (ldb (byte 4 4) result) u_

66

(ldb (byte 4 0) result) v_)

67

result))))

68

69

(defconstant +p8+ #.(reduce #'+ (mapcar #'(lambda (x) (expt 2 x)) '(8 4 3 2 0)))

70

"The primitive polynomial of degree 8 for GF(2^8).")

71

72

;; Arithmetic in the Galois Field GF(2^8).

73

(defun gf-add (x y)

74

(logxor x y))

75

76

(defun gf-shift (x n)

77

(ash x n))

78

79

(defun gf-reduce (x)

80

(let ((result x))

81

(loop until (< (integer-length result) (integer-length +p8+))

82

         do (setf result (gf-add result (gf-shift +p8+ (- (integer-length result) (integer-length +p8+))))))

83

result))

84

85

(defun gf-mult (x y)

86

(loop with result = 0

87

for i downfrom (integer-length y) to 0

88

do (progn

89

(setf result (gf-reduce (gf-shift result 1)))

90

(unless (zerop (ldb (byte 1 i) y))

91

(setf result (gf-add result x))))

92

finally (return result)))

93

94

(defun cir (vector)

95

"The circulant matrix whose first row is VECTOR."

96

(loop with n = (length vector)

97

with result = (make-array (list n n))

98

for i below n

99

do (loop for j below n

100

do (setf (aref result i j) (aref vector (mod (- j i) n))))

101

finally (return result)))

102

103

(defparameter *c* (cir #(1 1 4 1 8 5 2 9)))

104

105

(defun calculate-table-word (i j offset)

106

(loop with sx = (s j)

107

with result = 0

108

for k below 4

109

do (setf (ldb (byte 8 (- 32 (* (1+ k) 8))) result)

110

(gf-mult sx (aref *c* i (+ k offset))))

111

finally (return result)))

112

113

(defun calculate-c-even ()

114

(loop with result = (make-array '(8 256) :element-type '(unsigned-byte 32)

115

:initial-element 0)

116

for i below 8

117

do (dotimes (j 256)

118

(setf (aref result i j) (calculate-table-word i j 0)))

119

finally (return result)))

120

121

(defun calculate-c-odd ()

122

(loop with result = (make-array '(8 256) :element-type '(unsigned-byte 32)

123

:initial-element 0)

124

for i below 8

125

do (dotimes (j 256)

126

(setf (aref result i j) (calculate-table-word i j 4)))

127

finally (return result)))) ; EVAL-WHEN

128

129

(declaim (type (simple-array (unsigned-byte 32) (22)) +rc+))

130

(defconst +rc+

131

#.(loop with result = (make-array 22 :element-type '(unsigned-byte 32)

132

:initial-element 0)

133

with one-row-of-bytes = (make-array 8 :element-type '(unsigned-byte 8))

134

for r from 1 to +whirlpool-rounds+

135

do (progn

136

(loop for j below 8 do

137

(setf (aref one-row-of-bytes j) (s (+ (* 8 (- r 1)) j))))

138

(setf (aref result (* 2 r)) (ub32ref/be one-row-of-bytes 0))

139

(setf (aref result (+ (* 2 r) 1)) (ub32ref/be one-row-of-bytes 4)))

140

finally (return result)))

141

142

(declaim (type (simple-array (unsigned-byte 32) (8 256)) +c-even+ +c-odd+))

143

(defconst +c-even+ #.(calculate-c-even))

144

(defconst +c-odd+ #.(calculate-c-odd))

145

146

(eval-when (:compile-toplevel :load-toplevel :execute)

147

;;; Macro helper functions.

148

(defun extract-byte (k row column)

149

(if (>= column 4)

150

`(ldb (byte 8 ,(- 24 (* 8 (- column 4)))) (,k ,(1+ (* 2 row))))

151

`(ldb (byte 8 ,(- 24 (* 8 column))) (,k ,(* 2 row)))))

152

153

(defun split (lst)

154

(let* ((n (length lst))

155

(mid (floor n 2)))

156

(values

157

(subseq lst 0 mid)

158

(subseq lst mid))))

159

160

(defun generate-xor (terms)

161

(if (endp (cdr terms))

162

(car terms)

163

(multiple-value-bind (terms1 terms2) (split terms)

164

`(logxor ,(generate-xor terms1) ,(generate-xor terms2)))))

165

166

(defun one-slice (to from i)

167

(let ((indices (loop for n below 8 collect (gensym))))

168

`(let (,@(loop for index in indices

169

for j below 8

170

collect `(,index ,(extract-byte from (mod (- i j) 8) j))))

171

(setf (,to ,(* 2 i))

172

,(generate-xor `,(loop for index in indices

173

for j below 8

174

collect `(aref +c-even+ ,j ,index))))

175

(setf (,to ,(1+ (* 2 i)))

176

,(generate-xor `,(loop for index in indices

177

for j below 8

178

                                 collect `(aref +c-odd+ ,j ,index)))))))) ; EVAL-WHEN

179

180

(defmacro lookup-in-c (to from)

181

`(progn

182

,@(loop for i below 8 collect (one-slice to from i))))

183

184

(defun update-whirlpool-block (regs block)

185

"this is the core part of the whirlpool algorithm. it takes a complete 16

186

word block of input, and updates the working state in the regs."

187

(declare (type whirlpool-regs regs)

188

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

189

(macrolet ((hash (i)

190

`(aref regs (+ ,i +whirlpool-regs-hash-offset+)))

191

(k (i)

192

`(aref regs (+ ,i +whirlpool-regs-k-offset+)))

193

(state (i)

194

`(aref regs (+ ,i +whirlpool-regs-state-offset+)))

195

(l (i)

196

`(aref regs (+ ,i +whirlpool-regs-l-offset+))))

197

;; Compute and apply K^0 to the cipher state

198

(loop for i below 16

199

do (setf (state i) (logxor (aref block i) (setf (k i) (hash i)))))

200

;; Iterate over all rounds

201

(loop for r of-type (integer 1 11) from 1 to +whirlpool-rounds+

202

do (progn

203

;; Compute K^r from K^{r-1}

204

(lookup-in-c l k)

205

(setf (l 0) (logxor (l 0) (aref +rc+ (* 2 r))))

206

(setf (l 1) (logxor (l 1) (aref +rc+ (+ (* 2 r) 1))))

207

(loop for i below 16

208

do (setf (k i) (l i)))

209

;; Apply the r-th round transformation

210

(lookup-in-c l state)

211

(loop for i below 16

212

do (setf (l i) (logxor (l i) (k i))))

213

(loop for i below 16

214

do (setf (state i) (l i)))))

215

;; Apply the Miyaguchi-Preneel compression function

216

(loop for i below 16

217

do (setf (hash i)

218

(logxor (hash i)

219

(logxor (state i)

220

(aref block i)))))

221

regs))

222

223

;;; Mid-Level Drivers

224

(defstruct (whirlpool

225

(:constructor %make-whirlpool-digest nil)

226

(:constructor %make-whirlpool-state

227

(regs amount block buffer buffer-index))

228

(:copier nil)

229

(:include mdx))

230

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

231

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

232

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

233

234

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

235

(declare (ignore initargs))

236

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

237

(setf (whirlpool-amount state) 0

238

(whirlpool-buffer-index state) 0)

239

state)

240

241

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

242

(check-type copy (or whirlpool null))

243

(cond

244

(copy

245

(replace (whirlpool-regs copy) (whirlpool-regs state))

246

(replace (whirlpool-buffer copy) (whirlpool-buffer state))

247

(setf (whirlpool-amount copy) (whirlpool-amount state)

248

(whirlpool-buffer-index copy) (whirlpool-buffer-index state))

249

copy)

250

(t

251

(%make-whirlpool-state (copy-seq (whirlpool-regs state))

252

(whirlpool-amount state)

253

(copy-seq (whirlpool-block state))

254

(copy-seq (whirlpool-buffer state))

255

(whirlpool-buffer-index state)))))

256

257

(define-digest-updater whirlpool

258

"Update the given whirlpool state from sequence, which is either a

259

simple-string or a simple-array with element-type (unsigned-byte 8),

260

bounded by start and end, which must be numeric bounding-indices."

261

(flet ((compress (state sequence offset)

262

(let ((block (whirlpool-block state)))

263

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

264

(update-whirlpool-block (whirlpool-regs state) block))))

265

(declare (dynamic-extent #'compress))

266

(declare (notinline mdx-updater))

267

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

268

269

(define-digest-finalizer (whirlpool 64)

270

"If the given whirlpool-state has not already been finalized, finalize it,

271

by processing any remaining input in its buffer, with suitable padding

272

and appended bit-length, as specified by the Whirlpool standard.

273

274

The resulting whirlpool message-digest is returned as an array of 64

275

(unsigned-byte 8) values. Calling UPDATE-WHIRLPOOL-STATE after a call to

276

FINALIZE-WHIRLPOOL-STATE results in unspecified behaviour."

277

(let ((regs (whirlpool-regs state))

278

(block (whirlpool-block state))

279

(buffer (whirlpool-buffer state))

280

(buffer-index (whirlpool-buffer-index state))

281

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

282

(declare (type whirlpool-regs regs)

283

(type (integer 0 63) buffer-index)

284

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

285

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

286

;; Add mandatory bit 1 padding

287

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

288

;; Fill with 0 bit padding

289

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

290

from (1+ buffer-index) below 64

291

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

292

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

293

;; Flush block first if length wouldn't fit

294

(when (>= buffer-index 32)

295

(update-whirlpool-block regs block)

296

;; Create new fully 0 padded block

297

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

298

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

299

;; Add 256 bit message bit length

300

(loop for i of-type (integer 0 8) from 0 below 8

301

do (setf (aref block (+ 8 i))

302

(ldb (byte 32 (- 256 (* 32 (1+ i)))) total-length)))

303

;; Flush last block

304

(update-whirlpool-block regs block)

305

;; Done, remember digest for later calls

306

(finalize-registers state regs)))

307

308

(defdigest whirlpool :digest-length 64 :block-length 64)