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

Kind	Covered	All	%
expression	0	368	0.0
branch	0	14	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; jh.lisp -- implementation of the JH hash function

2

(in-package :crypto)

3

4

;;; Parameters

5

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

6

(defconstant +jh-rounds+ 42)

7

(defconstant +jh-block-size+ 64)

8

9

;;; Initial hash values

10

(defconst +jh224-h0+

11

(make-array 16

12

:element-type '(unsigned-byte 64)

13

:initial-contents '(#xac989af962ddfe2d #xe734d619d6ac7cae

14

#x161230bc051083a4 #x941466c9c63860b8

15

#x6f7080259f89d966 #xdc1a9b1d1ba39ece

16

#x106e367b5f32e811 #xc106fa027f8594f9

17

#xb340c8d85c1b4f1b #x9980736e7fa1f697

18

#xd3a3eaada593dfdc #x689a53c9dee831a4

19

#xe4a186ec8aa9b422 #xf06ce59c95ac74d5

20

#xbf2babb5ea0d9615 #x6eea64ddf0dc1196)))

21

22

(defconst +jh256-h0+

23

(make-array 16

24

:element-type '(unsigned-byte 64)

25

:initial-contents '(#xebd3202c41a398eb #xc145b29c7bbecd92

26

#xfac7d4609151931c #x038a507ed6820026

27

#x45b92677269e23a4 #x77941ad4481afbe0

28

#x7a176b0226abb5cd #xa82fff0f4224f056

29

#x754d2e7f8996a371 #x62e27df70849141d

30

#x948f2476f7957627 #x6c29804757b6d587

31

#x6c0d8eac2d275e5c #x0f7a0557c6508451

32

#xea12247067d3e47b #x69d71cd313abe389)))

33

34

(defconst +jh384-h0+

35

(make-array 16

36

:element-type '(unsigned-byte 64)

37

:initial-contents '(#x8a3913d8c63b1e48 #x9b87de4a895e3b6d

38

#x2ead80d468eafa63 #x67820f4821cb2c33

39

#x28b982904dc8ae98 #x4942114130ea55d4

40

#xec474892b255f536 #xe13cf4ba930a25c7

41

#x4c45db278a7f9b56 #x0eaf976349bdfc9e

42

#xcd80aa267dc29f58 #xda2eeb9d8c8bc080

43

#x3a37d5f8e881798a #x717ad1ddad6739f4

44

#x94d375a4bdd3b4a9 #x7f734298ba3f6c97)))

45

46

(defconst +jh512-h0+

47

(make-array 16

48

:element-type '(unsigned-byte 64)

49

:initial-contents '(#x17aa003e964bd16f #x43d5157a052e6a63

50

#x0bef970c8d5e228a #x61c3b3f2591234e9

51

#x1e806f53c1a01d89 #x806d2bea6b05a92a

52

#xa6ba7520dbcc8e58 #xf73bf8ba763a0fa9

53

#x694ae34105e66901 #x5ae66f2e8e8ab546

54

#x243c84c1d0a74710 #x99c15a2db1716e3b

55

#x56f8b19decf657cf #x56b116577c8806a7

56

#xfb1785e6dffcc2e3 #x4bdd8ccc78465a54)))

57

58

;;; Round constants

59

(defconst +jh-round-constants+

60

(make-array 168

61

:element-type '(unsigned-byte 64)

62

:initial-contents '(#x67f815dfa2ded572 #x571523b70a15847b

63

#xf6875a4d90d6ab81 #x402bd1c3c54f9f4e

64

#x9cfa455ce03a98ea #x9a99b26699d2c503

65

#x8a53bbf2b4960266 #x31a2db881a1456b5

66

#xdb0e199a5c5aa303 #x1044c1870ab23f40

67

#x1d959e848019051c #xdccde75eadeb336f

68

#x416bbf029213ba10 #xd027bbf7156578dc

69

#x5078aa3739812c0a #xd3910041d2bf1a3f

70

#x907eccf60d5a2d42 #xce97c0929c9f62dd

71

#xac442bc70ba75c18 #x23fcc663d665dfd1

72

#x1ab8e09e036c6e97 #xa8ec6c447e450521

73

#xfa618e5dbb03f1ee #x97818394b29796fd

74

#x2f3003db37858e4a #x956a9ffb2d8d672a

75

#x6c69b8f88173fe8a #x14427fc04672c78a

76

#xc45ec7bd8f15f4c5 #x80bb118fa76f4475

77

#xbc88e4aeb775de52 #xf4a3a6981e00b882

78

#x1563a3a9338ff48e #x89f9b7d524565faa

79

#xfde05a7c20edf1b6 #x362c42065ae9ca36

80

#x3d98fe4e433529ce #xa74b9a7374f93a53

81

#x86814e6f591ff5d0 #x9f5ad8af81ad9d0e

82

#x6a6234ee670605a7 #x2717b96ebe280b8b

83

#x3f1080c626077447 #x7b487ec66f7ea0e0

84

#xc0a4f84aa50a550d #x9ef18e979fe7e391

85

#xd48d605081727686 #x62b0e5f3415a9e7e

86

#x7a205440ec1f9ffc #x84c9f4ce001ae4e3

87

#xd895fa9df594d74f #xa554c324117e2e55

88

#x286efebd2872df5b #xb2c4a50fe27ff578

89

#x2ed349eeef7c8905 #x7f5928eb85937e44

90

#x4a3124b337695f70 #x65e4d61df128865e

91

#xe720b95104771bc7 #x8a87d423e843fe74

92

#xf2947692a3e8297d #xc1d9309b097acbdd

93

#xe01bdc5bfb301b1d #xbf829cf24f4924da

94

#xffbf70b431bae7a4 #x48bcf8de0544320d

95

#x39d3bb5332fcae3b #xa08b29e0c1c39f45

96

#x0f09aef7fd05c9e5 #x34f1904212347094

97

#x95ed44e301b771a2 #x4a982f4f368e3be9

98

#x15f66ca0631d4088 #xffaf52874b44c147

99

#x30c60ae2f14abb7e #xe68c6eccc5b67046

100

#x00ca4fbd56a4d5a4 #xae183ec84b849dda

101

#xadd1643045ce5773 #x67255c1468cea6e8

102

#x16e10ecbf28cdaa3 #x9a99949a5806e933

103

#x7b846fc220b2601f #x1885d1a07facced1

104

#xd319dd8da15b5932 #x46b4a5aac01c9a50

105

#xba6b04e467633d9f #x7eee560bab19caf6

106

#x742128a9ea79b11f #xee51363b35f7bde9

107

#x76d350755aac571d #x01707da3fec2463a

108

#x42d8a498afc135f7 #x79676b9e20eced78

109

#xa8db3aea15638341 #x832c83324d3bc3fa

110

#xf347271c1f3b40a7 #x9a762db734f04059

111

#xfd4f21d26c4e3ee7 #xef5957dc398dfdb8

112

#xdaeb492b490c9b8d #x0d70f36849d7a25b

113

#x84558d7ad0ae3b7d #x658ef8e4f0e9a5f5

114

#x533b1036f4a2b8a0 #x5aec3e759e07a80c

115

#x4f88e85692946891 #x4cbcbaf8555cb05b

116

#x7b9487f3993bbbe3 #x5d1c6b72d6f4da75

117

#x6db334dc28acae64 #x71db28b850a5346c

118

#x2a518d10f2e261f8 #xfc75dd593364dbe3

119

#xa23fce43f1bcac1c #xb043e8023cd1bb67

120

#x75a12988ca5b0a33 #x5c5316b44d19347f

121

#x1e4d790ec3943b92 #x3fafeeb6d7757479

122

#x21391abef7d4a8ea #x5127234c097ef45c

123

#xd23c32ba5324a326 #xadd5a66d4a17a344

124

#x08c9f2afa63e1db5 #x563c6b91983d5983

125

#x4d608672a17cf84c #xf6c76e08cc3ee246

126

#x5e76bcb1b333982f #x2ae6c4efa566d62b

127

#x36d4c1bee8b6f406 #x6321efbc1582ee74

128

#x69c953f40d4ec1fd #x26585806c45a7da7

129

#x16fae0061614c17e #x3f9d63283daf907e

130

#x0cd29b00e3f2c9d2 #x300cd4b730ceaa5f

131

#x9832e0f216512a74 #x9af8cee3d830eb0d

132

#x9279f1b57b9ec54b #xd36886046ee651ff

133

#x316796e6574d239b #x05750a17f3a6e6cc

134

#xce6c3213d98176b1 #x62a205f88452173c

135

#x47154778b3cb2bf4 #x486a9323825446ff

136

#x65655e4e0758df38 #x8e5086fc897cfcf2

137

#x86ca0bd0442e7031 #x4e477830a20940f0

138

#x8338f7d139eea065 #xbd3a2ce437e95ef7

139

#x6ff8130126b29721 #xe7de9fefd1ed44a3

140

#xd992257615dfa08b #xbe42dc12f6f7853c

141

#x7eb027ab7ceca7d8 #xdea83eaada7d8d53

142

#xd86902bd93ce25aa #xf908731afd43f65a

143

#xa5194a17daef5fc0 #x6a21fd4c33664d97

144

#x701541db3198b435 #x9b54cdedbb0f1eea

145

#x72409751a163d09a #xe26f4791bf9d75f6))))

146

147

;;; Transformations

148

(defmacro jh-swap-1 (x)

149

"Swapping bit 2i with bit 2i+1 of 64-bit X."

150

`(setf ,x (logior (ash (logand ,x #x5555555555555555) 1)

151

(ash (logand ,x #xaaaaaaaaaaaaaaaa) -1))))

152

153

(defmacro jh-swap-2 (x)

154

"Swapping bits 4i||4i+1 with bits 4i+2||4i+3 of 64-bit X."

155

`(setf ,x (logior (ash (logand ,x #x3333333333333333) 2)

156

(ash (logand ,x #xcccccccccccccccc) -2))))

157

158

(defmacro jh-swap-4 (x)

159

"Swapping bits 8i||8i+1||8i+2||8i+3 with bits

160

8i+4||8i+5||8i+6||8i+7 of 64-bit X."

161

`(setf ,x (logior (ash (logand ,x #x0f0f0f0f0f0f0f0f) 4)

162

(ash (logand ,x #xf0f0f0f0f0f0f0f0) -4))))

163

164

(defmacro jh-swap-8 (x)

165

"Swapping bits 16i||16i+1||......||16i+7 with bits

166

16i+8||16i+9||......||16i+15 of 64-bit X."

167

`(setf ,x (logior (ash (logand ,x #x00ff00ff00ff00ff) 8)

168

(ash (logand ,x #xff00ff00ff00ff00) -8))))

169

170

(defmacro jh-swap-16 (x)

171

"Swapping bits 32i||32i+1||......||32i+15 with bits

172

32i+16||32i+17||......||32i+31 of 64-bit X."

173

`(setf ,x (logior (ash (logand ,x #x0000ffff0000ffff) 16)

174

(ash (logand ,x #xffff0000ffff0000) -16))))

175

176

(defmacro jh-swap-32 (x)

177

"Swapping bits 64i||64i+1||......||64i+31 with bits

178

64i+32||64i+33||......||64i+63 of 64-bit X."

179

`(setf ,x (logior (ash (logand ,x #x00000000ffffffff) 32)

180

(ash (logand ,x #xffffffff00000000) -32))))

181

182

(defmacro jh-l (m0 m1 m2 m3 m4 m5 m6 m7)

183

"The MDS transform."

184

`(setf ,m4 (logxor ,m4 ,m1)

185

,m5 (logxor ,m5 ,m2)

186

,m6 (logxor ,m6 (logxor ,m0 ,m3))

187

,m7 (logxor ,m7 ,m0)

188

,m0 (logxor ,m0 ,m5)

189

,m1 (logxor ,m1 ,m6)

190

,m2 (logxor ,m2 (logxor ,m4 ,m7))

191

,m3 (logxor ,m3 ,m4)))

192

193

(defmacro jh-ss (m0 m1 m2 m3 m4 m5 m6 m7 cc0 cc1 t0 t1)

194

"The S-boxes."

195

`(setf ,m3 (mod64lognot ,m3)

196

,m7 (mod64lognot ,m7)

197

,m0 (logxor ,m0 (logand (mod64lognot ,m2) ,cc0))

198

,m4 (logxor ,m4 (logand (mod64lognot ,m6) ,cc1))

199

,t0 (logxor ,cc0 (logand ,m0 ,m1))

200

,t1 (logxor ,cc1 (logand ,m4 ,m5))

201

,m0 (logxor ,m0 (logand ,m2 ,m3))

202

,m4 (logxor ,m4 (logand ,m6 ,m7))

203

,m3 (logxor ,m3 (logand (mod64lognot ,m1) ,m2))

204

,m7 (logxor ,m7 (logand (mod64lognot ,m5) ,m6))

205

,m1 (logxor ,m1 (logand ,m0 ,m2))

206

,m5 (logxor ,m5 (logand ,m4 ,m6))

207

,m2 (logxor ,m2 (logand ,m0 (mod64lognot ,m3)))

208

,m6 (logxor ,m6 (logand ,m4 (mod64lognot ,m7)))

209

,m0 (logxor ,m0 (logior ,m1 ,m3))

210

,m4 (logxor ,m4 (logior ,m5 ,m7))

211

,m3 (logxor ,m3 (logand ,m1 ,m2))

212

,m7 (logxor ,m7 (logand ,m5 ,m6))

213

,m1 (logxor ,m1 (logand ,t0 ,m0))

214

,m5 (logxor ,m5 (logand ,t1 ,m4))

215

,m2 (logxor ,m2 ,t0)

216

,m6 (logxor ,m6 ,t1)))

217

218

;;; Rounds

219

(declaim (ftype (function ((simple-array (unsigned-byte 64) (16)))) jh-e8))

220

(defun jh-e8 (s)

221

"The bijective function."

222

(declare (type (simple-array (unsigned-byte 64) (16)) s)

223

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

224

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

225

(v0 (aref s 0))

226

(v1 (aref s 1))

227

(v2 (aref s 2))

228

(v3 (aref s 3))

229

(v4 (aref s 4))

230

(v5 (aref s 5))

231

(v6 (aref s 6))

232

(v7 (aref s 7))

233

(v8 (aref s 8))

234

(v9 (aref s 9))

235

(v10 (aref s 10))

236

(v11 (aref s 11))

237

(v12 (aref s 12))

238

(v13 (aref s 13))

239

(v14 (aref s 14))

240

(v15 (aref s 15))

241

(t0 0)

242

(t1 0))

243

(declare (type (simple-array (unsigned-byte 64) (168)) constants)

244

              (type (unsigned-byte 64) v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 t0 t1))

245

(do ((round 0 (+ round 7)))

246

((= round +jh-rounds+))

247

(declare (type (integer 0 42) round))

248

(macrolet ((constant (i j)

249

`(aref constants (+ (* 4 ,i) ,j)))

250

(sub-round (i)

251

(let ((swap (ecase i

252

((0) 'jh-swap-1)

253

((1) 'jh-swap-2)

254

((2) 'jh-swap-4)

255

((3) 'jh-swap-8)

256

((4) 'jh-swap-16)

257

((5) 'jh-swap-32)

258

((6) nil))))

259

`(progn

260

(jh-ss v0 v4 v8 v12 v2 v6 v10 v14

261

(constant (+ round ,i) 0)

262

(constant (+ round ,i) 2)

263

t0 t1)

264

(jh-l v0 v4 v8 v12 v2 v6 v10 v14)

265

,(when swap `(,swap v2))

266

,(when swap `(,swap v6))

267

,(when swap `(,swap v10))

268

,(when swap `(,swap v14))

269

(jh-ss v1 v5 v9 v13 v3 v7 v11 v15

270

(constant (+ round ,i) 1)

271

(constant (+ round ,i) 3)

272

t0 t1)

273

(jh-l v1 v5 v9 v13 v3 v7 v11 v15)

274

,(when swap `(,swap v3))

275

,(when swap `(,swap v7))

276

,(when swap `(,swap v11))

277

,(when swap `(,swap v15))))))

278

279

;; Round 7*roundnumber+0: S-box, MDS and swapping layers

280

(sub-round 0)

281

282

;; Round 7*roundnumber+1: S-box, MDS and swapping layers

283

(sub-round 1)

284

285

;; Round 7*roundnumber+2: S-box, MDS and swapping layers

286

(sub-round 2)

287

288

;; Round 7*roundnumber+3: S-box, MDS and swapping layers

289

(sub-round 3)

290

291

;; Round 7*roundnumber+4: S-box, MDS and swapping layers

292

(sub-round 4)

293

294

;; Round 7*roundnumber+5: S-box, MDS and swapping layers

295

(sub-round 5)

296

297

;; Round 7*roundnumber+6: S-box and MDS layers

298

(sub-round 6)

299

300

;; Round 7*roundnumber+6: swapping layer

301

(rotatef v2 v3)

302

(rotatef v6 v7)

303

(rotatef v10 v11)

304

(rotatef v14 v15)))

305

306

;; Save the new state

307

(setf (aref s 0) v0

308

(aref s 1) v1

309

(aref s 2) v2

310

(aref s 3) v3

311

(aref s 4) v4

312

(aref s 5) v5

313

(aref s 6) v6

314

(aref s 7) v7

315

(aref s 8) v8

316

(aref s 9) v9

317

(aref s 10) v10

318

(aref s 11) v11

319

(aref s 12) v12

320

(aref s 13) v13

321

(aref s 14) v14

322

(aref s 15) v15)

323

324

(values)))

325

326

(defun jh-f8 (state)

327

"The compression function."

328

(declare (notinline jh-buffer jh-state))

329

(let ((s (jh-state state))

330

(buffer (jh-buffer state))

331

(b (make-array 8 :element-type '(unsigned-byte 64))))

332

(declare (type (simple-array (unsigned-byte 64) (16)) s)

333

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

334

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

335

(dynamic-extent b))

336

337

;; Get input data as 64-bit little-endian integers

338

(dotimes (i 8)

339

(setf (aref b i) (ub64ref/le buffer (* 8 i))))

340

341

;; Xor the 512-bit message with the fist half of the 1024-bit hash state

342

(dotimes (i 8)

343

(setf (aref s i) (logxor (aref s i) (aref b i))))

344

345

;; Apply the bijective function E8

346

(jh-e8 s)

347

348

;; Xor the 512-bit message with the second half of the 1024-bit hash state

349

(dotimes (i 8)

350

(setf (aref s (+ i 8)) (logxor (aref s (+ i 8)) (aref b i))))

351

352

(values)))

353

354

;;; Digest structures and functions

355

(defstruct (jh

356

(:constructor %make-jh-digest nil)

357

(:copier nil))

358

(state (copy-seq +jh512-h0+) :type (simple-array (unsigned-byte 64) (16)))

359

(data-length 0 :type (unsigned-byte 64))

360

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

361

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

362

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

363

364

(defstruct (jh/384

365

(:include jh)

366

(:constructor %make-jh/384-digest

367

(&aux (state (copy-seq +jh384-h0+))))

368

(:copier nil)))

369

370

(defstruct (jh/256

371

(:include jh)

372

(:constructor %make-jh/256-digest

373

(&aux (state (copy-seq +jh256-h0+))))

374

(:copier nil)))

375

376

(defstruct (jh/224

377

(:include jh)

378

(:constructor %make-jh/224-digest

379

(&aux (state (copy-seq +jh224-h0+))))

380

(:copier nil)))

381

382

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

383

(declare (ignore initargs))

384

(setf (jh-state state) (etypecase state

385

(jh/224 (copy-seq +jh224-h0+))

386

(jh/256 (copy-seq +jh256-h0+))

387

(jh/384 (copy-seq +jh384-h0+))

388

(jh (copy-seq +jh512-h0+)))

389

(jh-data-length state) 0

390

(jh-buffer-index state) 0)

391

state)

392

393

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

394

(check-type copy (or null jh))

395

(let ((copy (if copy

396

copy

397

(etypecase state

398

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

399

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

400

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

401

(jh (%make-jh-digest))))))

402

(declare (type jh copy))

403

(replace (jh-state copy) (jh-state state))

404

(replace (jh-buffer copy) (jh-buffer state))

405

(setf (jh-data-length copy) (jh-data-length state)

406

(jh-buffer-index copy) (jh-buffer-index state))

407

copy))

408

409

(defun jh-update (state input start end)

410

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

411

(type (unsigned-byte 64) start end))

412

(let ((data-length (jh-data-length state))

413

(buffer (jh-buffer state))

414

(buffer-index (jh-buffer-index state))

415

(length (- end start))

416

(n 0))

417

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

418

(type (unsigned-byte 64) data-length length)

419

(type (integer 0 64) buffer-index n))

420

421

;; Try to fill the buffer with the new data

422

(setf n (min length (- +jh-block-size+ buffer-index)))

423

(replace buffer input :start1 buffer-index :start2 start :end2 (+ start n))

424

(incf data-length n)

425

(incf buffer-index n)

426

(incf start n)

427

(decf length n)

428

429

;; Process data in buffer

430

(when (= buffer-index +jh-block-size+)

431

(jh-f8 state)

432

(setf buffer-index 0))

433

434

;; Process data in message

435

(loop until (< length +jh-block-size+) do

436

(replace buffer input :start2 start)

437

(jh-f8 state)

438

(incf data-length +jh-block-size+)

439

(incf start +jh-block-size+)

440

(decf length +jh-block-size+))

441

442

;; Put remaining message data in buffer

443

(when (plusp length)

444

(replace buffer input :end1 length :start2 start)

445

(incf data-length length)

446

(incf buffer-index length))

447

448

;; Save the new state

449

(setf (jh-data-length state) data-length

450

(jh-buffer-index state) buffer-index)

451

452

(values)))

453

454

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

455

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

456

(jh-state (jh-state state))

457

(data-length (jh-data-length state))

458

(buffer (jh-buffer state))

459

(buffer-index (jh-buffer-index state)))

460

(declare (type (simple-array (unsigned-byte 64) (16)) jh-state)

461

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

462

(type (unsigned-byte 64) data-length)

463

(type (integer 0 64) buffer-index))

464

465

;; Set the rest of the bytes in the buffer to 0

466

(fill buffer 0 :start buffer-index)

467

468

;; Pad and process the partial block

469

(if (zerop buffer-index)

470

(progn

471

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

472

(setf (ub64ref/be buffer 56) (* data-length 8))

473

(jh-f8 state))

474

(progn

475

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

476

(jh-f8 state)

477

(fill buffer 0)

478

(setf (ub64ref/be buffer 56) (* data-length 8))

479

(jh-f8 state)))

480

481

;; Truncate the final hash value to generate the message digest

482

(let ((output (make-array +jh-block-size+ :element-type '(unsigned-byte 8))))

483

(dotimes (i 8)

484

(setf (ub64ref/le output (* i 8)) (aref jh-state (+ i 8))))

485

(replace digest output :start1 digest-start :start2 (- +jh-block-size+ digest-length))

486

digest)))

487

488

(define-digest-updater jh

489

(jh-update state sequence start end))

490

491

(define-digest-finalizer ((jh 64)

492

(jh/384 48)

493

(jh/256 32)

494

(jh/224 28))

495

(jh-finalize state digest digest-start))

496

497

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

498

(defdigest jh/384 :digest-length 48 :block-length 64)

499

(defdigest jh/256 :digest-length 32 :block-length 64)

500

(defdigest jh/224 :digest-length 28 :block-length 64)