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

Kind	Covered	All	%
expression	67	416	16.1
branch	1	64	1.6

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; cipher.lisp -- generic functions for symmetric encryption

2

(in-package :crypto)

3

4

(defclass cipher ()

5

((mode :initarg :mode :accessor mode)

6

(mode-name :reader mode-name)

7

(initialized-p :initform nil :accessor initialized-p)))

8

9

;;; Block ciphers are denoted by the use of the {8,16,32,64,128}-byte-block-mixin.

10

(defclass stream-cipher (cipher)

11

())

12

13

 (defmethod encrypt ((cipher cipher) plaintext ciphertext &key (plaintext-start 0) plaintext-end (ciphertext-start 0) handle-final-block &allow-other-keys)

14

(check-type plaintext vector)

15

(let ((plaintext-end (or plaintext-end (length plaintext))))

16

(funcall (slot-value (mode cipher) 'encrypt-function)

17

plaintext ciphertext

18

plaintext-start plaintext-end ciphertext-start

19

handle-final-block)))

20

21

 (defmethod decrypt ((cipher cipher) ciphertext plaintext &key (ciphertext-start 0) ciphertext-end (plaintext-start 0) handle-final-block &allow-other-keys)

22

(check-type ciphertext vector)

23

(let ((ciphertext-end (or ciphertext-end (length ciphertext))))

24

(funcall (slot-value (mode cipher) 'decrypt-function)

25

ciphertext plaintext

26

ciphertext-start ciphertext-end

27

plaintext-start handle-final-block)))

28

29

(defun encrypt-in-place (cipher text &key (start 0) end)

30

(encrypt cipher text text

31

:plaintext-start start :plaintext-end end

32

:ciphertext-start start))

33

34

(defun decrypt-in-place (cipher text &key (start 0) end)

35

(decrypt cipher text text

36

:ciphertext-start start :ciphertext-end end

37

:plaintext-start start))

38

39

;;; utilities for wordwise fetches and stores

40

41

;;; we attempt to make this as efficient as possible. the first check we

42

;;; do is to see whether or not the range

43

;;; [INITIAL-OFFSET, INITIAL-OFFSET + BLOCK-SIZE) is within the bounds of

44

;;; the array. if not, then we do the fetches as normal. if so, then we

45

;;; can either (DECLARE (SAFETY 0)) to avoid the bounds-checking on the

46

;;; fetches, or we can do full-word fetches if INITIAL-OFFSET is

47

;;; word-addressable and the implementation supports it.

48

#+nil

49

(defmacro with-words (((&rest word-vars) array initial-offset

50

&key (size 4) (big-endian t))

51

&body body)

52

(let ((ref-sym (ubref-fun-name (* size 8) big-endian))

53

(n-bytes (* (length word-vars) size)))

54

(flet ((generate-fetches (n-fetches)

55

(loop for offset from 0 by size below (* n-fetches size)

56

collect `(,ref-sym ,array (+ ,initial-offset ,offset)))))

57

`(multiple-value-bind ,word-vars (let ((length (length ,array)))

58

(cond

59

                                            ((<= ,initial-offset (- length ,n-bytes))

60

                                             ,(if (and (member :sbcl *features*)

61

                                                       (= size 4)

62

                                                       (or (and big-endian (member :big-endian *features*))

63

                                                           (and (not big-endian) (member :little-endian *features*))))

64

                                                  `(if (logtest ,initial-offset (1- ,size))

65

                                                       ;; do FETCH-UB* way

66

                                                       (locally (declare (optimize (safety 0)))

67

                                                         (values ,@(generate-fetches (length word-vars))))

68

                                                       (let ((word-offset (truncate ,initial-offset 4)))

69

                                                         (values

70

                                                          ,@(loop for offset from 0 below (length word-vars)

71

                                                               collect `(sb-kernel:%vector-raw-bits ,array (+ word-offset ,offset))))))

72

                                                   `(locally (declare (optimize (safety 0)))

73

                                                      (values ,@(generate-fetches (length word-vars))))))

74

(t

75

                                             (values ,@(generate-fetches (length word-vars))))))

76

(declare (type (unsigned-byte ,(* size 8)) ,@word-vars))

77

(macrolet ((store-words (buffer buffer-offset &rest word-vars)

78

(loop for word-var in word-vars

79

for offset from 0 by ,size

80

                          collect `(setf (,',ref-sym ,buffer (+ ,buffer-offset ,offset)) ,word-var)

81

into stores

82

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

83

,@body)))))

84

85

(defmacro with-words (((&rest word-vars) array initial-offset

86

&key (size 4) (big-endian t))

87

&body body)

88

(let ((ref-sym (ubref-fun-name (* size 8) big-endian)))

89

(loop for word-var in word-vars

90

for offset from 0 by size

91

collect `(,word-var (,ref-sym ,array (+ ,initial-offset ,offset)))

92

into let-bindings

93

finally (return `(macrolet ((store-words (buffer buffer-offset &rest word-vars)

94

(loop for word-var in word-vars

95

                                              for offset from 0 by ,size

96

                                              collect `(setf (,',ref-sym ,buffer (+ ,buffer-offset ,offset)) ,word-var)

97

into stores

98

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

99

(let ,let-bindings

100

                                (declare (type (unsigned-byte ,(* size 8)) ,@word-vars))

101

,@body))))))

102

103

;;; mixins for dispatching

104

(defclass 8-byte-block-mixin ()

105

())

106

107

(defclass 16-byte-block-mixin ()

108

())

109

110

(defclass 32-byte-block-mixin ()

111

())

112

113

(defclass 64-byte-block-mixin ()

114

())

115

116

(defclass 128-byte-block-mixin ()

117

())

118

119

;;; defining ciphers

120

121

;;; the idea behind this is that one only has to implement encryption

122

;;; and decryption of a block for a particular cipher (and perhaps

123

;;; some key generation) and then "define" the cipher with some

124

;;; parameters. necessary interface functions will be auto-generated

125

;;; with this macro.

126

127

;;; possible things to go in INITARGS

128

;;;

129

;;; * (:encrypt-function #'cipher-encrypt-block)

130

;;; * (:decrypt-function #'cipher-decrypt-block)

131

;;; * (:key-length (:fixed &rest lengths))

132

;;; * (:key-length (:variable low high increment))

133

;;; * (:constructor #'create-cipher-context)

134

(defmacro defcipher (name &rest initargs)

135

(%defcipher name initargs))

136

137

;;; KLUDGE: we add the blocksize to these two forms so that we can declare

138

;;; the type of the *-START parameters correctly. That is, good Lisp

139

;;; implementations will see that references into the plaintext and

140

;;; ciphertext can never overflow into bignum land; shorter code should

141

;;; then be generated. This is a kludge, however, because we're putting

142

;;; the blocksize in three different places: once in the encryptor, once

143

;;; in the decryptor, and once in the DEFCIPHER form. It would be nice

144

;;; if there was one single place to put everything.

145

(defmacro define-block-encryptor (algorithm blocksize &body body)

146

`(defun ,(symbolicate algorithm '#:-encrypt-block)

147

(context plaintext plaintext-start ciphertext ciphertext-start)

148

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

149

(declare (type simple-octet-vector plaintext ciphertext)

150

(type (integer 0 ,(- array-dimension-limit blocksize))

151

plaintext-start ciphertext-start))

152

,@body))

153

154

(defmacro define-block-decryptor (algorithm blocksize &body body)

155

`(defun ,(symbolicate algorithm '#:-decrypt-block)

156

(context ciphertext ciphertext-start plaintext plaintext-start)

157

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

158

(declare (type simple-octet-vector ciphertext plaintext)

159

(type (integer 0 ,(- array-dimension-limit blocksize))

160

ciphertext-start plaintext-start))

161

,@body))

162

163

(defmacro define-stream-cryptor (algorithm &body body)

164

`(defun ,(symbolicate algorithm '#:-crypt)

165

(context plaintext plaintext-start ciphertext ciphertext-start length)

166

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

167

(declare (type simple-octet-vector plaintext ciphertext))

168

(declare (type index plaintext-start ciphertext-start length))

169

,@body))

170

171

;; Catch various errors.

172

(defmethod verify-key (cipher key)

173

;; check the key first

174

(when (null key)

175

(error 'key-not-supplied :cipher cipher))

176

(unless (typep key '(vector (unsigned-byte 8)))

177

(error 'type-error :datum key :expected-type '(vector (unsigned-byte 8))))

178

;; hmmm, the key looks OK. what about the cipher?

179

(unless (member cipher (list-all-ciphers))

180

(error 'unsupported-cipher :name cipher)))

181

182

(defmethod schedule-key :before ((cipher cipher) key)

183

(verify-key cipher key))

184

185

;;; introspection

186

(defclass cipher-info ()

187

((class-name :reader %class-name :initarg :class-name)

188

(name :reader cipher :initarg :cipher)

189

(block-length :reader %block-length :initarg :block-length)

190

(key-lengths :reader %key-lengths :initarg :key-lengths)))

191

192

(defmethod print-object ((object cipher-info) stream)

193

(print-unreadable-object (object stream :type t)

194

(format stream "~A" (cipher object))))

195

196

(defun %find-cipher (name)

197

(and (symbolp name)

198

(let ((name (massage-symbol name)))

199

(and name (get name '%cipher-info)))))

200

201

(defun (setf %find-cipher) (cipher-info name)

202

(setf (get (massage-symbol name) '%cipher-info) cipher-info))

203

204

(defmethod key-lengths (cipher)

205

(let ((cipher-info (%find-cipher cipher)))

206

(and cipher-info (%key-lengths cipher-info))))

207

208

(defmethod key-lengths ((cipher cipher))

209

(key-lengths (class-name (class-of cipher))))

210

211

(defmethod block-length ((cipher symbol))

212

(let ((cipher-info (%find-cipher (massage-symbol cipher))))

213

(and cipher-info (%block-length cipher-info))))

214

215

(defmethod block-length ((cipher cipher))

216

(block-length (class-name (class-of cipher))))

217

218

(defmethod block-length ((cipher 8-byte-block-mixin))

219

8)

220

221

(defmethod block-length ((cipher 16-byte-block-mixin))

222

16)

223

224

(defmethod block-length ((cipher 32-byte-block-mixin))

225

32)

226

227

(defmethod block-length ((cipher 64-byte-block-mixin))

228

64)

229

230

(defmethod block-length ((cipher 128-byte-block-mixin))

231

128)

232

233

(defun list-all-ciphers ()

234

(loop for symbol being each external-symbol of (find-package :ironclad)

235

if (%find-cipher symbol)

236

collect (intern (symbol-name symbol) :keyword) into ciphers

237

finally (return (sort ciphers #'string<))))

238

239

(defun cipher-supported-p (name)

240

"Return T if the cipher NAME is supported as an argument to MAKE-CIPHER."

241

(not (null (%find-cipher name))))

242

243

(defun acceptable-key-lengths* (key-length-spec)

244

(ecase (car key-length-spec)

245

(:fixed (loop for length in (cdr key-length-spec)

246

collect `(= length ,length) into forms

247

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

248

(:variable (destructuring-bind (low high increment) (cdr key-length-spec)

249

(if (= increment 1)

250

`(<= ,low length ,high)

251

;; Punt. It'd be a weird cipher implemented otherwise.

252

                      (error 'ironclad-error :format-control "Need to implement the (/= INCREMENT 1) case"))))))

253

254

(defun acceptable-key-lengths (key-length-spec)

255

(ecase (car key-length-spec)

256

(:fixed (cdr key-length-spec))

257

(:variable (destructuring-bind (low high increment) (cdr key-length-spec)

258

(loop for i from low to high by increment

259

collect i)))))

260

261

(defun generate-key-verifier-methods (name key-length-spec)

262

(let ((acceptable-key-lengths (acceptable-key-lengths key-length-spec)))

263

`(defmethod verify-key ((cipher ,name) (key vector))

264

(check-type key (array (unsigned-byte 8) (*)))

265

(let ((length (length key)))

266

(cond

267

(,(acceptable-key-lengths* key-length-spec) (copy-seq key))

268

(t (error 'invalid-key-length

269

:cipher ',name

270

:accepted-lengths ',acceptable-key-lengths)))))))

271

272

(defun generate-common-cipher-methods (name block-length key-length-spec)

273

`(progn

274

;; make sure we pass in valid keys

275

,(generate-key-verifier-methods name key-length-spec)

276

(setf (%find-cipher ',name)

277

(make-instance 'cipher-info

278

:class-name ',name

279

:cipher ',name

280

:block-length ,block-length

281

:key-lengths ',(acceptable-key-lengths key-length-spec)))))

282

283

(defun generate-block-cipher-forms (name key-length-spec

284

encrypt-function decrypt-function)

285

(declare (ignorable key-length-spec))

286

`(progn

287

(defmethod encrypt-function ((cipher ,name))

288

#',encrypt-function)

289

(defmethod decrypt-function ((cipher ,name))

290

#',decrypt-function)))

291

292

(defun generate-stream-cipher-forms (name key-length-spec crypt-function)

293

(declare (ignorable key-length-spec))

294

`(progn

295

(defmethod encrypt-function ((cipher ,name))

296

#',crypt-function)

297

(defmethod decrypt-function ((cipher ,name))

298

#',crypt-function)))

299

300

(defun %defcipher (name initargs)

301

(let ((encrypt-function nil)

302

(decrypt-function nil)

303

(crypt-function nil)

304

(block-length nil)

305

(mode :block)

306

(key-length-spec nil)

307

(constructor nil))

308

(declare (ignorable constructor))

309

(loop for (arg value) in initargs

310

do (case arg

311

(:encrypt-function

312

(if (not encrypt-function)

313

(setf encrypt-function value)

314

                     (error 'ironclad-error :format-control "Specified :ENCRYPT-FUNCTION multiple times.")))

315

(:decrypt-function

316

(if (not decrypt-function)

317

(setf decrypt-function value)

318

                     (error 'ironclad-error :format-control "Specified :DECRYPT-FUNCTION multiple times.")))

319

(:crypt-function

320

(if (not crypt-function)

321

(setf crypt-function value)

322

                     (error 'ironclad-error :format-control "Specified :CRYPT-FUNCTION multiple times.")))

323

(:mode

324

(setf mode value))

325

(:block-length

326

(cond

327

(block-length

328

                    (error 'ironclad-error :format-control "Specified :BLOCK-LENGTH multiple times."))

329

((or (not (integerp value))

330

(not (plusp value)))

331

                    (error 'ironclad-error :format-control ":BLOCK-LENGTH must be a positive, integral number."))

332

(t

333

(setf block-length value))))

334

(:key-length

335

(cond

336

(key-length-spec

337

                    (error 'ironclad-error :format-control "Specified :KEY-LENGTH multiple times."))

338

((not (consp value))

339

                    (error 'ironclad-error :format-control ":KEY-LENGTH value must be a list."))

340

((and (not (eq :fixed (car value)))

341

(not (eq :variable (car value))))

342

                    (error 'ironclad-error :format-control "First element of :KEY-LENGTH spec must be either :FIXED or :VARIABLE."))

343

((eq :fixed (car value))

344

(if (and (cdr value)

345

(every #'integerp (cdr value))

346

(every #'plusp (cdr value)))

347

(setf key-length-spec value)

348

;;; FIXME: better error message

349

                        (error 'ironclad-error :format-control "bad :FIXED specification for :KEY-LENGTH.")))

350

((eq :variable (car value))

351

(if (and (null (nthcdr 4 value))

352

(every #'integerp (cdr value))

353

(every #'plusp (cdr value))

354

(< (cadr value) (caddr value)))

355

(setf key-length-spec value)

356

                        (error 'ironclad-error :format-control "bad :VARIABLE specification for :KEY-LENGTH."))))))

357

finally (cond

358

                     ((and (eq mode :block) key-length-spec encrypt-function decrypt-function)

359

(return

360

`(progn

361

                           ,(generate-common-cipher-methods name block-length key-length-spec)

362

,(generate-block-cipher-forms name key-length-spec

363

                                                         encrypt-function decrypt-function))))

364

((and (eq mode :stream) crypt-function key-length-spec)

365

(return

366

`(progn

367

,(generate-common-cipher-methods name 1 key-length-spec)

368

                           ,(generate-stream-cipher-forms name key-length-spec crypt-function))))

369

(t

370

                      (error 'ironclad-error :format-control "Didn't specify all required fields for DEFCIPHER"))))))