Coverage report: /home/ellis/comp/ext/ironclad/src/ciphers/des.lisp

Kind	Covered	All	%
expression	0	387	0.0
branch	0	18	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; des.lisp -- implementation of DES

2

3

;;; converted from the C code appearing in _Applied Cryptography_ by

4

;;; Bruce Schneier to Common Lisp. Unfortunately, a lot of C-isms

5

;;; remain, so this is not the prettiest Common Lisp code ever.

6

(in-package :crypto)

7

(in-ironclad-readtable)

8

9

;;; the sboxes of DES

10

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

11

des-sbox0 des-sbox1 des-sbox2 des-sbox3

12

des-sbox4 des-sbox5 des-sbox6 des-sbox7))

13

(defconst des-sbox0

14

#32@(

15

#x01010400 #x00000000 #x00010000 #x01010404

16

#x01010004 #x00010404 #x00000004 #x00010000

17

#x00000400 #x01010400 #x01010404 #x00000400

18

#x01000404 #x01010004 #x01000000 #x00000004

19

#x00000404 #x01000400 #x01000400 #x00010400

20

#x00010400 #x01010000 #x01010000 #x01000404

21

#x00010004 #x01000004 #x01000004 #x00010004

22

#x00000000 #x00000404 #x00010404 #x01000000

23

#x00010000 #x01010404 #x00000004 #x01010000

24

#x01010400 #x01000000 #x01000000 #x00000400

25

#x01010004 #x00010000 #x00010400 #x01000004

26

#x00000400 #x00000004 #x01000404 #x00010404

27

#x01010404 #x00010004 #x01010000 #x01000404

28

#x01000004 #x00000404 #x00010404 #x01010400

29

#x00000404 #x01000400 #x01000400 #x00000000

30

#x00010004 #x00010400 #x00000000 #x01010004

31

))

32

33

(defconst des-sbox1

34

#32@(

35

#x80108020 #x80008000 #x00008000 #x00108020

36

#x00100000 #x00000020 #x80100020 #x80008020

37

#x80000020 #x80108020 #x80108000 #x80000000

38

#x80008000 #x00100000 #x00000020 #x80100020

39

#x00108000 #x00100020 #x80008020 #x00000000

40

#x80000000 #x00008000 #x00108020 #x80100000

41

#x00100020 #x80000020 #x00000000 #x00108000

42

#x00008020 #x80108000 #x80100000 #x00008020

43

#x00000000 #x00108020 #x80100020 #x00100000

44

#x80008020 #x80100000 #x80108000 #x00008000

45

#x80100000 #x80008000 #x00000020 #x80108020

46

#x00108020 #x00000020 #x00008000 #x80000000

47

#x00008020 #x80108000 #x00100000 #x80000020

48

#x00100020 #x80008020 #x80000020 #x00100020

49

#x00108000 #x00000000 #x80008000 #x00008020

50

#x80000000 #x80100020 #x80108020 #x00108000

51

))

52

53

(defconst des-sbox2

54

#32@(

55

#x00000208 #x08020200 #x00000000 #x08020008

56

#x08000200 #x00000000 #x00020208 #x08000200

57

#x00020008 #x08000008 #x08000008 #x00020000

58

#x08020208 #x00020008 #x08020000 #x00000208

59

#x08000000 #x00000008 #x08020200 #x00000200

60

#x00020200 #x08020000 #x08020008 #x00020208

61

#x08000208 #x00020200 #x00020000 #x08000208

62

#x00000008 #x08020208 #x00000200 #x08000000

63

#x08020200 #x08000000 #x00020008 #x00000208

64

#x00020000 #x08020200 #x08000200 #x00000000

65

#x00000200 #x00020008 #x08020208 #x08000200

66

#x08000008 #x00000200 #x00000000 #x08020008

67

#x08000208 #x00020000 #x08000000 #x08020208

68

#x00000008 #x00020208 #x00020200 #x08000008

69

#x08020000 #x08000208 #x00000208 #x08020000

70

#x00020208 #x00000008 #x08020008 #x00020200

71

))

72

73

(defconst des-sbox3

74

#32@(

75

#x00802001 #x00002081 #x00002081 #x00000080

76

#x00802080 #x00800081 #x00800001 #x00002001

77

#x00000000 #x00802000 #x00802000 #x00802081

78

#x00000081 #x00000000 #x00800080 #x00800001

79

#x00000001 #x00002000 #x00800000 #x00802001

80

#x00000080 #x00800000 #x00002001 #x00002080

81

#x00800081 #x00000001 #x00002080 #x00800080

82

#x00002000 #x00802080 #x00802081 #x00000081

83

#x00800080 #x00800001 #x00802000 #x00802081

84

#x00000081 #x00000000 #x00000000 #x00802000

85

#x00002080 #x00800080 #x00800081 #x00000001

86

#x00802001 #x00002081 #x00002081 #x00000080

87

#x00802081 #x00000081 #x00000001 #x00002000

88

#x00800001 #x00002001 #x00802080 #x00800081

89

#x00002001 #x00002080 #x00800000 #x00802001

90

#x00000080 #x00800000 #x00002000 #x00802080

91

))

92

93

(defconst des-sbox4

94

#32@(

95

#x00000100 #x02080100 #x02080000 #x42000100

96

#x00080000 #x00000100 #x40000000 #x02080000

97

#x40080100 #x00080000 #x02000100 #x40080100

98

#x42000100 #x42080000 #x00080100 #x40000000

99

#x02000000 #x40080000 #x40080000 #x00000000

100

#x40000100 #x42080100 #x42080100 #x02000100

101

#x42080000 #x40000100 #x00000000 #x42000000

102

#x02080100 #x02000000 #x42000000 #x00080100

103

#x00080000 #x42000100 #x00000100 #x02000000

104

#x40000000 #x02080000 #x42000100 #x40080100

105

#x02000100 #x40000000 #x42080000 #x02080100

106

#x40080100 #x00000100 #x02000000 #x42080000

107

#x42080100 #x00080100 #x42000000 #x42080100

108

#x02080000 #x00000000 #x40080000 #x42000000

109

#x00080100 #x02000100 #x40000100 #x00080000

110

#x00000000 #x40080000 #x02080100 #x40000100

111

))

112

113

(defconst des-sbox5

114

#32@(

115

#x20000010 #x20400000 #x00004000 #x20404010

116

#x20400000 #x00000010 #x20404010 #x00400000

117

#x20004000 #x00404010 #x00400000 #x20000010

118

#x00400010 #x20004000 #x20000000 #x00004010

119

#x00000000 #x00400010 #x20004010 #x00004000

120

#x00404000 #x20004010 #x00000010 #x20400010

121

#x20400010 #x00000000 #x00404010 #x20404000

122

#x00004010 #x00404000 #x20404000 #x20000000

123

#x20004000 #x00000010 #x20400010 #x00404000

124

#x20404010 #x00400000 #x00004010 #x20000010

125

#x00400000 #x20004000 #x20000000 #x00004010

126

#x20000010 #x20404010 #x00404000 #x20400000

127

#x00404010 #x20404000 #x00000000 #x20400010

128

#x00000010 #x00004000 #x20400000 #x00404010

129

#x00004000 #x00400010 #x20004010 #x00000000

130

#x20404000 #x20000000 #x00400010 #x20004010

131

))

132

133

(defconst des-sbox6

134

#32@(

135

#x00200000 #x04200002 #x04000802 #x00000000

136

#x00000800 #x04000802 #x00200802 #x04200800

137

#x04200802 #x00200000 #x00000000 #x04000002

138

#x00000002 #x04000000 #x04200002 #x00000802

139

#x04000800 #x00200802 #x00200002 #x04000800

140

#x04000002 #x04200000 #x04200800 #x00200002

141

#x04200000 #x00000800 #x00000802 #x04200802

142

#x00200800 #x00000002 #x04000000 #x00200800

143

#x04000000 #x00200800 #x00200000 #x04000802

144

#x04000802 #x04200002 #x04200002 #x00000002

145

#x00200002 #x04000000 #x04000800 #x00200000

146

#x04200800 #x00000802 #x00200802 #x04200800

147

#x00000802 #x04000002 #x04200802 #x04200000

148

#x00200800 #x00000000 #x00000002 #x04200802

149

#x00000000 #x00200802 #x04200000 #x00000800

150

#x04000002 #x04000800 #x00000800 #x00200002

151

))

152

153

(defconst des-sbox7

154

#32@(

155

#x10001040 #x00001000 #x00040000 #x10041040

156

#x10000000 #x10001040 #x00000040 #x10000000

157

#x00040040 #x10040000 #x10041040 #x00041000

158

#x10041000 #x00041040 #x00001000 #x00000040

159

#x10040000 #x10000040 #x10001000 #x00001040

160

#x00041000 #x00040040 #x10040040 #x10041000

161

#x00001040 #x00000000 #x00000000 #x10040040

162

#x10000040 #x10001000 #x00041040 #x00040000

163

#x00041040 #x00040000 #x10041000 #x00001000

164

#x00000040 #x10040040 #x00001000 #x00041040

165

#x10001000 #x00000040 #x10000040 #x10040000

166

#x10040040 #x10000000 #x00040000 #x10001040

167

#x00000000 #x10041040 #x00040040 #x10000040

168

#x10040000 #x10001000 #x10001040 #x00000000

169

#x10041040 #x00041000 #x00041000 #x00001040

170

#x00001040 #x00040040 #x10000000 #x10041000))

171

172

;;; permutations and rotations for the key schedule

173

(defconst permutation1

174

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

175

:initial-contents (list 56 48 40 32 24 16 8 0

176

57 49 41 33 25 17 9 1

177

58 50 42 34 26 18 10 2

178

59 51 43 35 62 54 46 38 30

179

22 14 6 61 53 45 37 29

180

21 13 5 60 52 44 36 28

181

20 12 4 27 19 11 3)))

182

183

(defconst total-rotations

184

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

185

:initial-contents (list 1 2 4 6 8 10 12 14

186

15 17 19 21 23 25 27 28)))

187

188

(defconst permutation2

189

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

190

:initial-contents (list 13 16 10 23 0 4

191

2 27 14 5 20 9

192

22 18 11 3 25 7

193

15 6 26 19 12 1

194

40 51 30 36 46 54

195

29 39 50 44 32 47

196

43 48 38 55 33 52

197

45 41 49 35 28 31)))

198

199

;;; actual encryption and decryption guts

200

(deftype des-round-keys () '(simple-array (unsigned-byte 32) (32)))

201

202

(macrolet ((frob (left right shift-amount constant)

203

`(setf work (logand (logxor (mod32ash ,left

204

                                                          ,shift-amount) ,right)

205

,constant)

206

,right (logxor ,right work)

207

,left (logxor (mod32ash work ,(- shift-amount)) ,left)))

208

(6-bits (val offset) `(ldb (byte 6 ,offset) ,val))

209

(sbox-subst (val sbox0 sbox1 sbox2 sbox3)

210

`(logior (aref ,sbox0 (6-bits ,val 0))

211

(aref ,sbox1 (6-bits ,val 8))

212

(aref ,sbox2 (6-bits ,val 16))

213

(aref ,sbox3 (6-bits ,val 24))))

214

(des-round (left right keys index)

215

`(let* ((work (logxor (rol32 ,right 28) (aref ,keys ,index)))

216

(fval (sbox-subst work des-sbox6 des-sbox4

217

des-sbox2 des-sbox0)))

218

(declare (type (unsigned-byte 32) work fval))

219

(setf work (logxor ,right (aref ,keys (1+ ,index)))

220

fval (logior fval (sbox-subst work des-sbox7 des-sbox5

221

des-sbox3 des-sbox1))

222

,left (logxor ,left fval))))

223

(des-initial-permutation (left right)

224

`(progn

225

(frob ,left ,right -4 #x0f0f0f0f)

226

(frob ,left ,right -16 #x0000ffff)

227

(frob ,right ,left -2 #x33333333)

228

(frob ,right ,left -8 #x00ff00ff)

229

230

(setf ,right (rol32 ,right 1)

231

work (logand (logxor ,left ,right) #xaaaaaaaa)

232

,left (logxor ,left work)

233

,right (logxor ,right work)

234

,left (rol32 ,left 1))))

235

(des-final-permutation (left right)

236

`(progn

237

(setf ,right (rol32 ,right 31)

238

work (logand (logxor ,left ,right) #xaaaaaaaa)

239

,left (logxor ,left work)

240

,right (logxor ,right work)

241

,left (rol32 ,left 31))

242

(frob ,left ,right -8 #x00ff00ff)

243

(frob ,left ,right -2 #x33333333)

244

(frob ,right ,left -16 #x0000ffff)

245

(frob ,right ,left -4 #x0f0f0f0f)))

246

(des-munge-core (left right keys)

247

`(do ((round 0 (1+ round))

248

(key-index 0 (+ key-index 4)))

249

((>= round 8))

250

(des-round ,left ,right ,keys key-index)

251

(des-round ,right ,left ,keys (+ key-index 2)))))

252

253

(defun des-munge-block (input input-start output output-start keys)

254

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

255

(declare (type (integer 0 #.(- array-dimension-limit 8))

256

input-start output-start))

257

(declare (type des-round-keys keys))

258

(with-words ((left right) input input-start)

259

(let ((work 0))

260

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

261

(des-initial-permutation left right)

262

;; now the real work begins

263

(des-munge-core left right keys)

264

(des-final-permutation left right)

265

(store-words output output-start right left))))

266

267

(defun 3des-munge-block (input input-start output output-start k1 k2 k3)

268

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

269

(declare (type (integer 0 #.(- array-dimension-limit 8))

270

input-start output-start))

271

(declare (type des-round-keys k1 k2 k3))

272

(with-words ((left right) input input-start)

273

(let ((work 0))

274

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

275

(des-initial-permutation left right)

276

;; now the real work begins

277

(des-munge-core left right k1)

278

(des-munge-core right left k2)

279

(des-munge-core left right k3)

280

(des-final-permutation left right)

281

(store-words output output-start right left))))) ; MACROLET

282

283

;;; ECB mode encryption and decryption

284

(defclass des (cipher 8-byte-block-mixin)

285

((encryption-keys :accessor encryption-keys :type des-round-keys)

286

(decryption-keys :accessor decryption-keys :type des-round-keys)))

287

288

(define-block-encryptor des 8

289

(des-munge-block plaintext plaintext-start ciphertext ciphertext-start

290

(encryption-keys context)))

291

292

(define-block-decryptor des 8

293

(des-munge-block ciphertext ciphertext-start plaintext plaintext-start

294

(decryption-keys context)))

295

296

(defclass 3des (cipher 8-byte-block-mixin)

297

((encryption-keys-1 :accessor encryption-keys-1 :type des-round-keys)

298

(decryption-keys-1 :accessor decryption-keys-1 :type des-round-keys)

299

(encryption-keys-2 :accessor encryption-keys-2 :type des-round-keys)

300

(decryption-keys-2 :accessor decryption-keys-2 :type des-round-keys)

301

(encryption-keys-3 :accessor encryption-keys-3 :type des-round-keys)

302

(decryption-keys-3 :accessor decryption-keys-3 :type des-round-keys)))

303

304

(define-block-encryptor 3des 8

305

(3des-munge-block plaintext plaintext-start ciphertext ciphertext-start

306

(encryption-keys-1 context)

307

(decryption-keys-2 context)

308

(encryption-keys-3 context)))

309

310

(define-block-decryptor 3des 8

311

(3des-munge-block ciphertext ciphertext-start plaintext plaintext-start

312

(decryption-keys-3 context)

313

(encryption-keys-2 context)

314

(decryption-keys-1 context)))

315

316

;;; key scheduling

317

;; `dough' being a cute pun from Schiener's code.

318

(defun des-cook-key-schedule (dough)

319

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

320

(declare (type des-round-keys dough schedule))

321

(do ((dough-index 0 (+ dough-index 2))

322

(schedule-index 0 (+ schedule-index 2)))

323

((>= dough-index 32) schedule)

324

(declare (optimize (debug 3)))

325

(let ((schedule-index+1 (1+ schedule-index))

326

(dough-index+1 (1+ dough-index)))

327

(setf (aref schedule schedule-index)

328

(let ((dough0 (aref dough dough-index))

329

(dough1 (aref dough dough-index+1)))

330

(logior (mod32ash (mask-field (byte 6 18) dough0) 6)

331

(mod32ash (mask-field (byte 6 6) dough0) 10)

332

(mod32ash (mask-field (byte 6 18) dough1) -10)

333

(mod32ash (mask-field (byte 6 6) dough1) -6)))

334

(aref schedule schedule-index+1)

335

(let ((dough0 (aref dough dough-index))

336

(dough1 (aref dough dough-index+1)))

337

(logior (mod32ash (mask-field (byte 6 12) dough0) 12)

338

(mod32ash (mask-field (byte 6 0) dough0) 16)

339

(mod32ash (mask-field (byte 6 12) dough1) -4)

340

(mask-field (byte 6 0) dough1))))))))

341

342

(defun compute-des-encryption-keys (key)

343

(declare (type (simple-array (unsigned-byte 8) (8)) key))

344

(let ((pc1m (make-array 56 :element-type '(unsigned-byte 8) :initial-element 0))

345

(pcr (make-array 56 :element-type '(unsigned-byte 8) :initial-element 0))

346

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

347

(dotimes (j 56)

348

(let* ((l (aref permutation1 j))

349

(m (logand l #x7)))

350

(setf (aref pc1m j)

351

(logand (aref key (ldb (byte 4 3) l))

352

(ash 1 (- 7 m))))))

353

(dotimes (i 16)

354

(let* ((m (ash i 1))

355

(n (1+ m)))

356

(dotimes (j 28)

357

(let ((l (+ j (aref total-rotations i))))

358

(if (< l 28)

359

(setf (aref pcr j) (aref pc1m l))

360

(setf (aref pcr j) (aref pc1m (- l 28))))))

361

(do ((j 28 (1+ j)))

362

((= j 56))

363

(let ((l (+ j (aref total-rotations i))))

364

(if (< l 56)

365

(setf (aref pcr j) (aref pc1m l))

366

(setf (aref pcr j) (aref pc1m (- l 28))))))

367

(dotimes (j 24)

368

(unless (zerop (aref pcr (aref permutation2 j)))

369

(setf (aref kn m) (logior (aref kn m) (ash 1 (- 24 (1+ j))))))

370

(unless (zerop (aref pcr (aref permutation2 (+ j 24))))

371

(setf (aref kn n) (logior (aref kn n) (ash 1 (- 24 (1+ j)))))))))

372

(des-cook-key-schedule kn)))

373

374

(defun compute-round-keys-for-des-key (key)

375

(let ((encryption-keys (compute-des-encryption-keys key))

376

(decryption-keys (make-array 32 :element-type '(unsigned-byte 32))))

377

(declare (type des-round-keys encryption-keys decryption-keys))

378

(do ((i 0 (+ i 2)))

379

((= i 32)

380

(values encryption-keys decryption-keys))

381

(setf (aref decryption-keys (1+ i)) (aref encryption-keys (- 31 i))

382

(aref decryption-keys i) (aref encryption-keys (- 31 (1+ i)))))))

383

384

(defmethod schedule-key ((cipher des) key)

385

(multiple-value-bind (encryption-keys decryption-keys)

386

(compute-round-keys-for-des-key key)

387

(setf (encryption-keys cipher) encryption-keys

388

(decryption-keys cipher) decryption-keys)

389

cipher))

390

391

(defmethod schedule-key ((cipher 3des) key)

392

(multiple-value-bind (ek1 dk1)

393

(compute-round-keys-for-des-key (subseq key 0 8))

394

(multiple-value-bind (ek2 dk2)

395

(compute-round-keys-for-des-key (subseq key 8 16))

396

(multiple-value-bind (ek3 dk3)

397

(let ((length (length key)))

398

(cond

399

((= length 16) (compute-round-keys-for-des-key (subseq key 0 8)))

400

((= length 24) (compute-round-keys-for-des-key (subseq key 16 24)))))

401

(setf (encryption-keys-1 cipher) ek1

402

(decryption-keys-1 cipher) dk1

403

(encryption-keys-2 cipher) ek2

404

(decryption-keys-2 cipher) dk2

405

(encryption-keys-3 cipher) ek3

406

(decryption-keys-3 cipher) dk3)

407

cipher))))

408

409

(defcipher des

410

(:encrypt-function des-encrypt-block)

411

(:decrypt-function des-decrypt-block)

412

(:block-length 8)

413

(:key-length (:fixed 8)))

414

415

(defcipher 3des

416

(:encrypt-function 3des-encrypt-block)

417

(:decrypt-function 3des-decrypt-block)

418

(:block-length 8)

419

(:key-length (:fixed 16 24)))