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

Kind	Covered	All	%
expression	346	666	52.0
branch	9	20	45.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; sha3.lisp -- implementation of SHA-3 from NIST

2

(in-package :crypto)

3

4

;;; Keccak state and parameters

5

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

6

(defconstant +keccak-state-columns+ 5)

7

(defconstant +keccak-state-rows+ 5)

8

(defconstant +keccak-state-lanes+ 25)

9

(defconstant +keccak-lane-width+ 64)

10

(defconstant +keccak-lane-byte-width+ 8)

11

(defconstant +keccak-rounds+ 24))

12

13

(deftype keccak-lane ()

14

`(unsigned-byte ,+keccak-lane-width+))

15

16

(deftype keccak-state ()

17

`(simple-array keccak-lane (,+keccak-state-lanes+)))

18

19

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

20

(defconst +keccak-rotate-offsets+

21

(make-array (list +keccak-state-columns+ +keccak-state-rows+)

22

:element-type '(unsigned-byte 8)

23

:initial-contents '(( 0 36 3 41 18)

24

( 1 44 10 45 2)

25

(62 6 43 15 61)

26

(28 55 25 21 56)

27

(27 20 39 8 14))))

28

29

(defconst +keccak-round-constants+

30

(make-array 24

31

:element-type 'keccak-lane

32

:initial-contents '(#x0000000000000001

33

#x0000000000008082

34

#x800000000000808a

35

#x8000000080008000

36

#x000000000000808b

37

#x0000000080000001

38

#x8000000080008081

39

#x8000000000008009

40

#x000000000000008a

41

#x0000000000000088

42

#x0000000080008009

43

#x000000008000000a

44

#x000000008000808b

45

#x800000000000008b

46

#x8000000000008089

47

#x8000000000008003

48

#x8000000000008002

49

#x8000000000000080

50

#x000000000000800a

51

#x800000008000000a

52

#x8000000080008081

53

#x8000000000008080

54

#x0000000080000001

55

#x8000000080008008))))

56

57

(defmacro get-keccak-rotate-offset (x y &environment env)

58

(aref +keccak-rotate-offsets+

59

(eval (trivial-macroexpand-all x env))

60

(eval (trivial-macroexpand-all y env))))

61

62

(declaim (inline get-keccak-round-constant)

63

(ftype (function ((integer 0 23)) keccak-lane) get-keccak-round-constant))

64

(defun get-keccak-round-constant (i)

65

(declare (type (integer 0 23) i)

66

(optimize (speed 3) (space 0) (safety 0) (debug 0)))

67

(let ((constants (load-time-value +keccak-round-constants+ t)))

68

(declare (type (simple-array keccak-lane (24)) constants))

69

(aref constants i)))

70

71

(declaim (inline make-keccak-state)

72

(ftype (function () keccak-state) make-keccak-state))

73

(defun make-keccak-state ()

74

(declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))

75

(make-array #.+keccak-state-lanes+ :element-type 'keccak-lane :initial-element 0))

76

77

;;; Transforming linear input/output to state array

78

(defun keccak-state-merge-input (state bit-rate input start)

79

(declare (type keccak-state state)

80

(type (integer 0 1600) bit-rate)

81

(type (simple-array (unsigned-byte 8) (*)) input)

82

(type fixnum start)

83

(optimize (speed 3) (space 0) (safety 0) (debug 0)))

84

(let ((rate-bytes (truncate bit-rate 8)))

85

(declare (type (integer 0 200) rate-bytes))

86

(dotimes (y +keccak-state-rows+)

87

(dotimes (x +keccak-state-columns+)

88

(let* ((element (+ (the fixnum (* y +keccak-state-columns+)) x))

89

(offset (* element +keccak-lane-byte-width+))

90

(index (the fixnum (+ start offset))))

91

(when (>= offset rate-bytes)

92

(return-from keccak-state-merge-input))

93

(setf (aref state element)

94

(logxor

95

(aref state element)

96

.

97

#.(loop for byte-index from 0 below +keccak-lane-byte-width+

98

                          collect `(the keccak-lane (ash (aref input (+ index ,byte-index))

99

                                                         ,(* byte-index 8)))))))))))

100

101

(defun keccak-state-extract-output (state output-bytes)

102

(let ((digest (make-array (list output-bytes) :element-type '(unsigned-byte 8))))

103

(dotimes (x +keccak-state-columns+)

104

(dotimes (y +keccak-state-rows+)

105

(let* ((element (+ (* y +keccak-state-columns+) x))

106

(offset (* element +keccak-lane-byte-width+)))

107

(unless (>= offset output-bytes)

108

(loop with value = (aref state element)

109

                   for index from offset below (min (+ offset +keccak-lane-byte-width+) output-bytes)

110

do (setf (aref digest index) (ldb (byte 8 0) value)

111

value (ash value -8)))))))

112

digest))

113

114

;;; Keccak rounds

115

(defmacro with-keccak-state-accessors ((&rest states) &body body)

116

"Bind the contents of the state(s) array(s) to local variables, and save

117

the content on normal form exit."

118

(let ((bindings nil) (mappings nil) (save-forms nil))

119

(loop for state in states

120

for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+))

121

do

122

(dotimes (y +keccak-state-rows+)

123

(dotimes (x +keccak-state-columns+)

124

(let ((sym (make-symbol (format nil "~A-~D-~D" state x y))))

125

(setf (aref map x y) sym)

126

(push `(,sym (aref ,state ,(+ x (* y +keccak-state-columns+))))

127

bindings)

128

(push `(setf (aref ,state ,(+ x (* y +keccak-state-columns+))) ,sym)

129

save-forms))))

130

(push (cons state map) mappings))

131

`(let (,@bindings)

132

(declare (ignorable ,@(mapcar #'car bindings))

133

(type keccak-lane ,@(mapcar #'car bindings)))

134

(macrolet ((state-aref (state x y &environment env)

135

(let ((entry (assoc state ',mappings)))

136

(unless entry (error 'ironclad-error

137

:format-control "Strange: ~S!"

138

                                            :format-arguments (list state)))

139

(aref (cdr entry)

140

(eval (trivial-macroexpand-all x env))

141

(eval (trivial-macroexpand-all y env))))))

142

(multiple-value-prog1 (progn ,@body)

143

,@save-forms)))))

144

145

(defmacro with-temp-keccak-state ((&rest temps) &body body)

146

"Bind local variables for each temporary state."

147

(let ((bindings nil) (mappings nil))

148

(loop for temp in temps

149

for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+))

150

do

151

(dotimes (y +keccak-state-rows+)

152

(dotimes (x +keccak-state-columns+)

153

(let ((sym (make-symbol (format nil "~A-~D-~D" temp x y))))

154

(setf (aref map x y) sym)

155

(push `(,sym 0) bindings))))

156

(push (cons temp map) mappings))

157

`(let (,@bindings)

158

(declare (ignorable ,@(mapcar #'car bindings))

159

(type keccak-lane ,@(mapcar #'car bindings)))

160

(macrolet ((temp-state-aref (temp x y &environment env)

161

(let ((entry (assoc temp ',mappings)))

162

(unless entry (error 'ironclad-error

163

:format-control "Strange: ~S!"

164

                                            :format-arguments (list temp)))

165

(aref (cdr entry)

166

(eval (trivial-macroexpand-all x env))

167

(eval (trivial-macroexpand-all y env))))))

168

,@body))))

169

170

(defmacro with-temp-keccak-rows ((&rest rows) &body body)

171

"Bind local variables for each temporary row."

172

(let ((bindings nil) (mappings nil))

173

(loop for row in rows

174

for map = (make-array '(#.+keccak-state-columns+))

175

do

176

(dotimes (x +keccak-state-columns+)

177

(let ((sym (make-symbol (format nil "~A-~D" row x))))

178

(setf (aref map x) sym)

179

(push `(,sym 0) bindings)))

180

(push (cons row map) mappings))

181

`(let (,@bindings)

182

(declare (ignorable ,@(mapcar #'car bindings))

183

(type keccak-lane ,@(mapcar #'car bindings)))

184

(macrolet ((temp-row-aref (row x &environment env)

185

(let ((entry (assoc row ',mappings)))

186

(unless entry (error 'ironclad-error

187

:format-control "Strange: ~S!"

188

:format-arguments (list row)))

189

(aref (cdr entry)

190

(eval (trivial-macroexpand-all x env))))))

191

,@body))))

192

193

(declaim (ftype (function (keccak-state)) keccak-rounds))

194

(defun keccak-rounds (state)

195

(declare (type keccak-state state)

196

(optimize (speed 3) (space 0) (safety 0) (debug 0)))

197

(with-keccak-state-accessors (state)

198

(with-temp-keccak-state (b)

199

(with-temp-keccak-rows (c d)

200

(dotimes (i #.+keccak-rounds+)

201

(dotimes-unrolled (x +keccak-state-columns+)

202

(setf (temp-row-aref c x)

203

(logxor (state-aref state x 0)

204

(state-aref state x 1)

205

(state-aref state x 2)

206

(state-aref state x 3)

207

(state-aref state x 4))))

208

(dotimes-unrolled (x +keccak-state-columns+)

209

(setf (temp-row-aref d x)

210

                   (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) +keccak-state-columns+))

211

                           (rol64 (temp-row-aref c (mod (1+ x) +keccak-state-columns+)) 1))))

212

(dotimes-unrolled (x +keccak-state-columns+)

213

(dotimes-unrolled (y +keccak-state-rows+)

214

(setf (state-aref state x y)

215

(logxor (state-aref state x y) (temp-row-aref d x)))))

216

(dotimes-unrolled (x +keccak-state-columns+)

217

(dotimes-unrolled (y +keccak-state-rows+)

218

(setf (temp-state-aref b y (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+))

219

(rol64 (state-aref state x y) (get-keccak-rotate-offset x y)))))

220

(dotimes-unrolled (x +keccak-state-columns+)

221

(dotimes-unrolled (y +keccak-state-rows+)

222

(setf (state-aref state x y)

223

(logxor (temp-state-aref b x y)

224

                             (logandc1 (temp-state-aref b (mod (1+ x) +keccak-state-columns+) y)

225

                                       (temp-state-aref b (mod (+ x 2) +keccak-state-columns+) y))))))

226

(setf (state-aref state 0 0) (logxor (state-aref state 0 0)

227

                                                (get-keccak-round-constant i)))))))

228

(values))

229

230

;;; Message Padding for last block

231

(defun pad-message-to-width (message bit-width padding-type)

232

(let* ((message-byte-length (length message))

233

(width-bytes (truncate bit-width 8))

234

(padding-bytes (- width-bytes (mod message-byte-length width-bytes)))

235

(padded-message-byte-length (+ message-byte-length padding-bytes))

236

(padded-message (make-array padded-message-byte-length :element-type '(unsigned-byte 8))))

237

(replace padded-message message :end2 message-byte-length)

238

(setf (aref padded-message message-byte-length) (ecase padding-type

239

                                                       (:xof #x1f)

240

                                                       (:keccak #x01)

241

                                                       (:sha3 #x06)))

242

(loop for index from (1+ message-byte-length) below padded-message-byte-length

243

do (setf (aref padded-message index) #x00))

244

(setf (aref padded-message (1- padded-message-byte-length))

245

(logior #x80 (aref padded-message (1- padded-message-byte-length))))

246

padded-message))

247

248

;;; SHA-3

249

(defstruct (sha3

250

(:constructor %make-sha3-digest nil)

251

(:copier nil))

252

(state (make-keccak-state) :type keccak-state)

253

(bit-rate 576 :type (integer 0 1600))

254

(buffer (make-array 200 :element-type '(unsigned-byte 8))

255

:type (simple-array (unsigned-byte 8) (200)))

256

(buffer-index 0 :type (integer 0 199))

257

(output-length 64))

258

259

(defstruct (sha3/384

260

(:include sha3)

261

(:constructor %make-sha3/384-digest

262

(&aux (bit-rate 832)

263

(output-length 48)))

264

(:copier nil)))

265

266

(defstruct (sha3/256

267

(:include sha3)

268

(:constructor %make-sha3/256-digest

269

(&aux (bit-rate 1088)

270

(output-length 32)))

271

(:copier nil)))

272

273

(defstruct (sha3/224

274

(:include sha3)

275

(:constructor %make-sha3/224-digest

276

(&aux (bit-rate 1152)

277

(output-length 28)))

278

(:copier nil)))

279

280

(defstruct (keccak

281

(:include sha3)

282

(:constructor %make-keccak-digest

283

(&aux (bit-rate 576)

284

(output-length 64)))

285

(:copier nil)))

286

287

(defstruct (keccak/384

288

(:include sha3)

289

(:constructor %make-keccak/384-digest

290

(&aux (bit-rate 832)

291

(output-length 48)))

292

(:copier nil)))

293

294

(defstruct (keccak/256

295

(:include sha3)

296

(:constructor %make-keccak/256-digest

297

(&aux (bit-rate 1088)

298

(output-length 32)))

299

(:copier nil)))

300

301

(defstruct (keccak/224

302

(:include sha3)

303

(:constructor %make-keccak/224-digest

304

(&aux (bit-rate 1152)

305

(output-length 28)))

306

(:copier nil)))

307

308

(defstruct (shake256

309

(:include sha3)

310

(:constructor %make-shake256 (bit-rate output-length))

311

(:copier nil)))

312

313

(defstruct (shake128

314

(:include sha3)

315

(:constructor %make-shake128 (bit-rate output-length))

316

(:copier nil)))

317

318

(defun %make-shake256-digest (&key (output-length 32))

319

(%make-shake256 1088 output-length))

320

321

(defun %make-shake128-digest (&key (output-length 16))

322

(%make-shake128 1344 output-length))

323

324

(defmethod block-length ((state shake256))

325

136)

326

327

(defmethod block-length ((state shake128))

328

168)

329

330

(defmethod digest-length ((state shake256))

331

(sha3-output-length state))

332

333

(defmethod digest-length ((state shake128))

334

(sha3-output-length state))

335

336

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

337

(declare (ignore initargs))

338

(setf (sha3-state state) (make-keccak-state))

339

(setf (sha3-buffer-index state) 0)

340

state)

341

342

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

343

(check-type copy (or null sha3))

344

(let ((copy (if copy

345

copy

346

(etypecase state

347

(shake128 (%make-shake128-digest))

348

(shake256 (%make-shake256-digest))

349

(keccak/224 (%make-keccak/224-digest))

350

(keccak/256 (%make-keccak/256-digest))

351

(keccak/384 (%make-keccak/384-digest))

352

(keccak (%make-keccak-digest))

353

(sha3/224 (%make-sha3/224-digest))

354

(sha3/256 (%make-sha3/256-digest))

355

(sha3/384 (%make-sha3/384-digest))

356

(sha3 (%make-sha3-digest))))))

357

(declare (type sha3 copy))

358

(replace (sha3-state copy) (sha3-state state))

359

(setf (sha3-bit-rate copy) (sha3-bit-rate state))

360

(replace (sha3-buffer copy) (sha3-buffer state))

361

(setf (sha3-buffer-index copy) (sha3-buffer-index state))

362

(setf (sha3-output-length copy) (sha3-output-length state))

363

copy))

364

365

(defun sha3-update (state vector start end)

366

(declare (type sha3 state)

367

(type (simple-array (unsigned-byte 8) (*)) vector)

368

(type fixnum start end)

369

(optimize (speed 3) (safety 0) (space 0) (debug 0)))

370

(let* ((keccak-state (sha3-state state))

371

(buffer (sha3-buffer state))

372

(buffer-index (sha3-buffer-index state))

373

(bit-rate (sha3-bit-rate state))

374

(rate-bytes (truncate bit-rate 8)))

375

(declare (type keccak-state keccak-state)

376

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

377

(type (integer 0 199) buffer-index)

378

(type (integer 0 1600) bit-rate)

379

(type (integer 0 200) rate-bytes))

380

381

;; Handle potential remaining bytes

382

(unless (zerop buffer-index)

383

(let ((remainder (- rate-bytes buffer-index))

384

(length (- end start)))

385

(declare (type fixnum remainder length))

386

(replace buffer vector :start1 buffer-index :end1 rate-bytes :start2 start :end2 end)

387

388

;; Return if still unfilled buffer

389

(when (< length remainder)

390

(incf (sha3-buffer-index state) length)

391

(return-from sha3-update))

392

393

;; Else handle now complete buffer

394

(keccak-state-merge-input keccak-state bit-rate buffer 0)

395

(keccak-rounds keccak-state)

396

(setf (sha3-buffer-index state) 0)

397

(setf start (+ start remainder))))

398

399

;; Now handle full blocks, stuff any remainder into buffer

400

(loop for block-offset of-type fixnum from start below end by rate-bytes

401

do (cond

402

((<= (+ block-offset rate-bytes) end)

403

(keccak-state-merge-input keccak-state bit-rate vector block-offset)

404

(keccak-rounds keccak-state))

405

(t

406

                 (replace buffer vector :start1 0 :end1 rate-bytes :start2 block-offset :end2 end)

407

(setf (sha3-buffer-index state) (- end block-offset))))))

408

(values))

409

410

(defun sha3-finalize (state digest digest-start)

411

(declare (type sha3 state)

412

(type (simple-array (unsigned-byte 8) (*)) digest)

413

(type integer digest-start)

414

(optimize (speed 3) (safety 1) (space 0) (debug 0)))

415

(let ((padding-type (typecase state

416

(shake128 :xof)

417

(shake256 :xof)

418

(keccak/224 :keccak)

419

(keccak/256 :keccak)

420

(keccak/384 :keccak)

421

(keccak :keccak)

422

(t :sha3)))

423

(keccak-state (sha3-state state))

424

(buffer (sha3-buffer state))

425

(buffer-index (sha3-buffer-index state))

426

(bit-rate (sha3-bit-rate state))

427

(output-byte-length (digest-length state)))

428

(declare (type keccak-state keccak-state)

429

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

430

(type (integer 0 199) buffer-index)

431

(type (integer 0 1600) bit-rate)

432

(type integer output-byte-length))

433

434

;; Process remaining data after padding it

435

(keccak-state-merge-input keccak-state

436

bit-rate

437

(pad-message-to-width (subseq buffer 0 buffer-index)

438

bit-rate

439

padding-type)

440

0)

441

(keccak-rounds keccak-state)

442

(setf (sha3-buffer-index state) 0)

443

444

;; Get output

445

(let ((output-size 0)

446

(chunk-size (truncate bit-rate 8)))

447

(loop until (= output-size output-byte-length) do

448

(let* ((n (min (- output-byte-length output-size) chunk-size))

449

(output (keccak-state-extract-output keccak-state n)))

450

(replace digest output :start1 (+ digest-start output-size) :end2 n)

451

(incf output-size n)

452

(keccak-rounds keccak-state))))

453

digest))

454

455

(define-digest-updater sha3

456

(sha3-update state sequence start end))

457

458

(define-digest-finalizer ((sha3 64)

459

(sha3/384 48)

460

(sha3/256 32)

461

(sha3/224 28)

462

(keccak 64)

463

(keccak/384 48)

464

(keccak/256 32)

465

(keccak/224 28))

466

(sha3-finalize state digest digest-start))

467

468

(defdigest sha3 :digest-length 64 :block-length 72)

469

(defdigest sha3/384 :digest-length 48 :block-length 104)

470

(defdigest sha3/256 :digest-length 32 :block-length 136)

471

(defdigest sha3/224 :digest-length 28 :block-length 144)

472

473

(defdigest keccak :digest-length 64 :block-length 72)

474

(defdigest keccak/384 :digest-length 48 :block-length 104)

475

(defdigest keccak/256 :digest-length 32 :block-length 136)

476

(defdigest keccak/224 :digest-length 28 :block-length 144)

477

478

(defmethod produce-digest ((state shake256) &key digest (digest-start 0))

479

(let ((digest-size (digest-length state))

480

(state-copy (copy-digest state)))

481

(if digest

482

(if (> digest-size (- (length digest) digest-start))

483

(error 'insufficient-buffer-space

484

:buffer digest :start digest-start

485

:length digest-size)

486

(sha3-finalize state-copy digest digest-start))

487

(sha3-finalize state-copy

488

(make-array digest-size :element-type '(unsigned-byte 8))

489

0))))

490

491

(defmethod produce-digest ((state shake128) &key digest (digest-start 0))

492

(let ((digest-size (digest-length state))

493

(state-copy (copy-digest state)))

494

(if digest

495

(if (> digest-size (- (length digest) digest-start))

496

(error 'insufficient-buffer-space

497

:buffer digest :start digest-start

498

:length digest-size)

499

(sha3-finalize state-copy digest digest-start))

500

(sha3-finalize state-copy

501

(make-array digest-size :element-type '(unsigned-byte 8))

502

0))))

503

504

(setf (get 'shake256 '%digest-length) 32)

505

(setf (get 'shake256 '%make-digest) (symbol-function '%make-shake256-digest))

506

(setf (get 'shake128 '%digest-length) 16)

507

(setf (get 'shake128 '%make-digest) (symbol-function '%make-shake128-digest))