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

Kind	Covered	All	%
expression	105	496	21.2
branch	9	52	17.3

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; digest.lisp -- common functions for hashing

2

(in-package :crypto)

3

4

;;; defining digest (hash) functions

5

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

6

(defconstant +buffer-size+ (* 128 1024))

7

(defconstant +seq-copy-buffer-size+ 512))

8

9

(deftype buffer-index () `(integer 0 (,+buffer-size+)))

10

11

(defun update-digest-from-stream (digest stream &key buffer (start 0) end)

12

(cond

13

((subtypep (stream-element-type stream) '(unsigned-byte 8))

14

(flet ((frob (read-buffer start end)

15

(loop for last-updated = (read-sequence read-buffer stream

16

                                                       :start start :end end)

17

do (update-digest digest read-buffer

18

:start start :end last-updated)

19

until (< last-updated end)

20

finally (return digest))))

21

(if buffer

22

(frob buffer start (or end (length buffer)))

23

(let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8))))

24

(declare (dynamic-extent buffer))

25

(frob buffer 0 +buffer-size+)))))

26

(t

27

(error 'ironclad-error

28

:format-control "Unsupported stream element-type ~S for stream ~S."

29

:format-arguments (list (stream-element-type stream) stream)))))

30

31

(declaim (inline update-digest-from-vector))

32

33

(defun update-digest-from-vector (digest vector start end)

34

;; SBCL and CMUCL have with-array-data, so copying can be avoided even

35

;; for non-simple vectors.

36

(declare (type (vector (unsigned-byte 8)) vector)

37

(type index start end))

38

(sb-kernel:with-array-data ((data vector) (real-start start) (real-end end))

39

(declare (ignore real-end))

40

(update-digest digest data :start real-start :end (+ real-start (- end start)))))

41

42

;;; Storing a length at the end of the hashed data is very common and

43

;;; can be a small bottleneck when generating lots of hashes over small

44

;;; quantities of data. We assume that the appropriate locations have

45

;;; already been zeroed if necessary. LENGTH is also assumed to be an

46

;;; (effectively) 64-bit quantity.

47

(declaim (inline store-data-length))

48

(defun store-data-length (block length offset &optional big-endian-p)

49

(let ((lo (if big-endian-p (1+ offset) offset))

50

(hi (if big-endian-p offset (1+ offset))))

51

#+32-bit

52

(cond

53

((sb-int:fixnump length)

54

(setf (aref block lo) length))

55

;; Otherwise, we have a bignum.

56

(t

57

(locally (declare (optimize (safety 0))

58

(type bignum length))

59

(cond

60

((= (sb-bignum:%bignum-length length) 1)

61

(setf (aref block lo) (sb-bignum:%bignum-ref length 0)))

62

(t

63

(setf (aref block lo) (sb-bignum:%bignum-ref length 0)

64

(aref block hi) (sb-bignum:%bignum-ref length 1)))))))

65

#-(and sbcl 32-bit)

66

(setf (aref block lo) (ldb (byte 32 0) length)

67

(aref block hi) (ldb (byte 32 32) length))))

68

69

;;; macros for "mid-level" functions

70

 (defmacro define-digest-registers ((digest-name &key (endian :big) (size 4) (digest-registers nil)) &rest registers)

71

(let* ((struct-name (symbolicate digest-name '#:-regs))

72

(constructor (symbolicate '#:initial- struct-name))

73

(copier (symbolicate '#:copy- struct-name))

74

(digest-fun (symbolicate digest-name '#:-regs-digest))

75

(register-bit-size (* size 8))

76

(digest-size (* size (or digest-registers

77

(length registers))))

78

(ref-fun (ubref-fun-name register-bit-size (eq endian :big))))

79

`(progn

80

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

81

(defstruct (,struct-name

82

(:type (vector (unsigned-byte ,register-bit-size)))

83

(:constructor ,constructor ())

84

(:copier ,copier))

85

,@registers)

86

;; Some versions of LispWorks incorrectly define STRUCT-NAME as

87

;; a type with DEFSTRUCT, so avoid gratuitous warnings.

88

#-(and lispworks lispworks5.0)

89

(deftype ,struct-name ()

90

'(simple-array (unsigned-byte ,register-bit-size) (,(length registers)))))

91

(defun ,digest-fun (regs buffer start)

92

(declare (type ,struct-name regs)

93

(type simple-octet-vector buffer)

94

(type (integer 0 ,(- array-dimension-limit digest-size)) start)

95

,(burn-baby-burn))

96

,(let ((inlined-unpacking

97

`(setf ,@(loop for (reg value) in registers

98

for index from 0 below digest-size by size

99

nconc `((,ref-fun buffer (+ start ,index))

100

                                          (,(symbolicate digest-name '#:-regs- reg)

101

regs))))))

102

(cond

103

#+little-endian

104

((eq endian :little)

105

`(if (and (= start 0) (<= ,register-bit-size sb-vm:n-word-bits))

106

(sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size)

107

,inlined-unpacking))

108

#+big-endian

109

((eq endian :big)

110

`(if (and (= start 0) (<= ,register-bit-size sb-vm:n-word-bits))

111

(sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size)

112

,inlined-unpacking))

113

(t inlined-unpacking)))

114

buffer))))

115

116

(defmacro define-digest-updater (digest-name &body body)

117

(destructuring-bind (maybe-doc-string &rest rest) body

118

     `(defmethod update-digest ((state ,digest-name) (sequence vector) &key (start 0) (end (length sequence)))

119

,@(when (stringp maybe-doc-string)

120

`(,maybe-doc-string))

121

,(hold-me-back)

122

(check-type sequence simple-octet-vector)

123

(check-type start index)

124

(check-type end index)

125

,@(if (stringp maybe-doc-string)

126

rest

127

body))))

128

129

;;; SPECS is either (DIGEST-NAME DIGEST-BYTES) or a list of the same.

130

;;; The latter spelling is for digests that are related, but have

131

;;; different output sizes (e.g. SHA2-512 and SHA2-384). In that case,

132

;;; the first list is expected to be for the "major" variant of the

133

;;; pair; its digest type is expected to be the supertype of the

134

;;; variants.

135

(defmacro define-digest-finalizer (specs &body body)

136

(let* ((single-digest-p (not (consp (car specs))))

137

(specs (if single-digest-p (list specs) specs))

138

(inner-fun-name (symbolicate '#:finalize- (caar specs) '#:-state)))

139

(destructuring-bind (maybe-doc-string &rest rest) body

140

(let ((primary-digest (caar specs)))

141

`(defmethod produce-digest ((state ,primary-digest)

142

&key digest (digest-start 0))

143

,@(when (stringp maybe-doc-string)

144

`(,maybe-doc-string))

145

(flet ((,inner-fun-name (state digest digest-start)

146

;; CCL requires special treatment to not introduce

147

;; array indexing errors.

148

,(cond

149

((member :ccl *features*)

150

'(declare (optimize (speed 0))))

151

(t (hold-me-back)))

152

(macrolet ((finalize-registers (state regs)

153

(declare (ignorable state))

154

(let ((clauses

155

                                          (loop for (digest-name digest-length) in ',specs

156

collect `(,digest-name

157

                                                          (,(symbolicate digest-name '#:-regs-digest)

158

                                                           ,regs digest digest-start)))))

159

(if ,single-digest-p

160

(second (first clauses))

161

(list* 'etypecase state

162

(reverse clauses))))))

163

,@(if (stringp maybe-doc-string)

164

rest

165

body))))

166

(let ((digest-size ,(if single-digest-p

167

(second (first specs))

168

`(etypecase state

169

,@(reverse specs))))

170

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

171

(etypecase digest

172

(simple-octet-vector

173

;; verify that the buffer is large enough

174

(if (<= digest-size (- (length digest) digest-start))

175

(,inner-fun-name state-copy digest digest-start)

176

(error 'insufficient-buffer-space

177

:buffer digest :start digest-start

178

:length digest-size)))

179

(null

180

(,inner-fun-name state-copy

181

(make-array digest-size

182

                                                :element-type '(unsigned-byte 8))

183

0))))))))))

184

185

;;; common superclass (superstructure?) for MD5-style digest functions

186

(defstruct (mdx

187

(:constructor nil)

188

(:copier nil))

189

;; This is technically an (UNSIGNED-BYTE 61). But the type-checking

190

;; penalties that imposes on a good 32-bit implementation are

191

;; significant. We've opted to omit the type declaration here. If

192

;; you really need to digest exabytes of data, I'm sure we can work

193

;; something out.

194

(amount 0)

195

;; Most "64-bit" digest functions (e.g. SHA512) will need to override

196

;; this initial value in an &AUX.

197

(buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t

198

                                                            :type simple-octet-vector)

199

;; This fixed type should be big enough for "64-bit" digest functions.

200

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

201

202

(declaim (inline mdx-updater))

203

(defun mdx-updater (state compressor seq start end)

204

(declare (type mdx state))

205

(declare (type function compressor))

206

(declare (type index start end))

207

(let* ((buffer (mdx-buffer state))

208

(buffer-index (mdx-buffer-index state))

209

(buffer-length (length buffer))

210

(length (- end start)))

211

(declare (type fixnum length))

212

(unless (zerop buffer-index)

213

(let ((amount (min (- buffer-length buffer-index)

214

length)))

215

(copy-to-buffer seq start amount buffer buffer-index)

216

(setq start (+ start amount))

217

(let ((new-index (logand (+ buffer-index amount)

218

(1- buffer-length))))

219

(when (zerop new-index)

220

(funcall compressor state buffer 0))

221

(when (>= start end)

222

(setf (mdx-buffer-index state) new-index)

223

(incf (mdx-amount state) length)

224

(return-from mdx-updater state)))))

225

(loop until (< (- end start) buffer-length)

226

do (funcall compressor state seq start)

227

(setq start (the fixnum (+ start buffer-length)))

228

finally (return

229

(let ((amount (- end start)))

230

(unless (zerop amount)

231

(copy-to-buffer seq start amount buffer 0))

232

(setf (mdx-buffer-index state) amount)

233

(incf (mdx-amount state) length)

234

state)))))

235

(declaim (notinline mdx-updater))

236

237

;;; high-level generic function drivers

238

239

;;; These three functions are intended to be one-shot ways to digest

240

;;; an object of some kind. You could write these in terms of the more

241

;;; familiar digest interface below, but these are likely to be slightly

242

;;; more efficient, as well as more obvious about what you're trying to

243

;;; do.

244

(declaim (notinline make-digest))

245

246

(defmethod digest-file ((digest-name cons) pathname &rest kwargs)

247

(apply #'digest-file (apply #'make-digest digest-name) pathname kwargs))

248

(defmethod digest-file ((digest-name symbol) pathname &rest kwargs)

249

(apply #'digest-file (make-digest digest-name) pathname kwargs))

250

251

(defmethod digest-file (state pathname &key buffer (start 0) end

252

digest (digest-start 0))

253

(with-open-file (stream pathname :element-type '(unsigned-byte 8)

254

:direction :input

255

:if-does-not-exist :error)

256

(update-digest-from-stream state stream

257

:buffer buffer :start start :end end)

258

(produce-digest state :digest digest :digest-start digest-start)))

259

260

(defmethod digest-stream ((digest-name cons) stream &rest kwargs)

261

(apply #'digest-stream (apply #'make-digest digest-name) stream kwargs))

262

(defmethod digest-stream ((digest-name symbol) stream &rest kwargs)

263

(apply #'digest-stream (make-digest digest-name) stream kwargs))

264

265

(defmethod digest-stream (state stream &key buffer (start 0) end

266

digest (digest-start 0))

267

(update-digest-from-stream state stream

268

:buffer buffer :start start :end end)

269

(produce-digest state :digest digest :digest-start digest-start))

270

271

(defmethod digest-sequence ((digest-name symbol) sequence &rest kwargs)

272

(apply #'digest-sequence (make-digest digest-name) sequence kwargs))

273

274

(defmethod digest-sequence (state sequence &key (start 0) end

275

                                                 digest (digest-start 0))

276

(declare (type index start))

277

(check-type sequence (vector (unsigned-byte 8)))

278

(let ((end (or end (length sequence))))

279

(update-digest-from-vector state sequence start end))

280

(produce-digest state :digest digest :digest-start digest-start))

281

282

;;; These four functions represent the common interface for digests in

283

;;; other crypto toolkits (OpenSSL, Botan, Python, etc.). You obtain

284

;;; some state object for a particular digest, you update it with some

285

;;; data, and then you get the actual digest. Flexibility is the name

286

;;; of the game with these functions.

287

(defun make-digest (digest-name &rest keys &key &allow-other-keys)

288

"Return a digest object which uses the algorithm DIGEST-NAME."

289

(typecase digest-name

290

(symbol

291

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

292

(if (digestp name)

293

(apply (the function (get name '%make-digest)) keys)

294

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

295

(t

296

(error 'type-error :datum digest-name :expected-type 'symbol))))

297

298

;;; the digest-defining macro

299

(defun digestp (sym)

300

(get sym '%digest-length))

301

302

(defun list-all-digests ()

303

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

304

if (digestp symbol)

305

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

306

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

307

308

(defun digest-supported-p (name)

309

"Return T if the digest NAME is a valid digest name."

310

(and (symbolp name)

311

(not (null (digestp (massage-symbol name))))))

312

313

(defmethod digest-length ((digest-name symbol))

314

(or (digestp (massage-symbol digest-name))

315

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

316

317

(defmethod digest-length (digest-name)

318

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

319

320

(defmethod update-digest (digester (stream stream) &key buffer (start 0) end

321

                                                    &allow-other-keys)

322

(update-digest-from-stream digester stream

323

:buffer buffer :start start :end end))

324

325

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

326

(defun optimized-maker-name (name)

327

(let ((*package* (find-package :ironclad)))

328

(symbolicate '#:%make- name '#:-digest))))

329

330

(defmacro defdigest (name &key digest-length block-length)

331

(let ((optimized-maker-name (optimized-maker-name name)))

332

`(progn

333

(setf (get ',name '%digest-length) ,digest-length)

334

(setf (get ',name '%make-digest) (symbol-function ',optimized-maker-name))

335

(defmethod digest-length ((digest ,name))

336

,digest-length)

337

(defmethod block-length ((digest ,name))

338

,block-length))))

339

340

;;; If we pass a constant argument to MAKE-DIGEST, convert the

341

;;; MAKE-DIGEST call to a direct call to the state creation function.

342

(define-compiler-macro make-digest (&whole form &environment env

343

                                                 name &rest keys &key &allow-other-keys)

344

(declare (ignore env))

345

(cond

346

((or (keywordp name)

347

(and (quotationp name) (symbolp name)))

348

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

349

(if (digestp name)

350

`(,(optimized-maker-name name) ,@keys)

351

form)))

352

(t form)))

353

354

;;; And do the same for various one-shot digest functions.

355

(defun maybe-expand-one-shot-call (form funname name 2nd-arg keys)

356

(cond

357

((or (keywordp name)

358

(and (quotationp name) (symbolp name)))

359

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

360

(if (digestp name)

361

`(,funname (,(optimized-maker-name name)) ,2nd-arg ,@keys)

362

form)))

363

(t form)))

364

365

(define-compiler-macro digest-sequence (&whole form &environment env

366

                                                     name sequence &rest keys)

367

(declare (ignore env))

368

(maybe-expand-one-shot-call form 'digest-sequence name sequence keys))

369

370

(define-compiler-macro digest-stream (&whole form &environment env

371

                                                   name stream &rest keys)

372

(declare (ignore env))

373

(maybe-expand-one-shot-call form 'digest-stream name stream keys))

374

375

(define-compiler-macro digest-file (&whole form &environment env

376

                                                 name file &rest keys)

377

(declare (ignore env))

378

(maybe-expand-one-shot-call form 'digest-file name file keys))