Coverage report: /home/ellis/comp/ext/ironclad/src/octet-stream.lisp

Kind	Covered	All	%
expression	0	624	0.0
branch	0	50	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; octet-stream.lisp -- like string-streams, but with (VECTOR (UNSIGNED-BYTE 8))

2

(in-package :crypto)

3

4

;;; portability definitions

5

;; TRIVIAL-GRAY-STREAMS has it, we might as well, too...

6

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

7

(defvar *binary-input-stream-class*

8

(quote sb-gray:fundamental-binary-input-stream))

9

10

(defvar *binary-output-stream-class*

11

(quote

12

sb-gray:fundamental-binary-output-stream))

13

14

;;; FIXME: how to do CMUCL support for this?

15

(defvar *stream-element-type-function*

16

(quote

17

sb-gray::stream-element-type))

18

19

(defvar *stream-read-byte-function*

20

(quote

21

sb-gray:stream-read-byte))

22

23

(defvar *stream-write-byte-function*

24

(quote

25

sb-gray:stream-write-byte))

26

27

(defvar *stream-read-sequence-function*

28

(quote

29

sb-gray:stream-read-sequence))

30

31

(defvar *stream-write-sequence-function*

32

(quote

33

sb-gray:stream-write-sequence))

34

35

(defvar *stream-finish-output-function*

36

(quote

37

sb-gray:stream-finish-output))

38

39

(defvar *stream-force-output-function*

40

(quote

41

sb-gray:stream-force-output))

42

43

(defvar *stream-clear-output-function*

44

(quote

45

sb-gray:stream-clear-output)))

46

47

;;; implementation via Gray streams

48

49

;;; These could be specialized for particular implementations by hooking

50

;;; in directly to the "native" stream methods for the implementation.

51

(defclass octet-stream ()

52

((buffer :accessor buffer :initarg :buffer :type simple-octet-vector)))

53

54

(defmethod #.*stream-element-type-function* ((stream octet-stream))

55

'(unsigned-byte 8))

56

57

(defmacro define-stream-read-sequence (specializer type &body body)

58

`(defmethod sb-gray:stream-read-sequence ((stream ,specializer) seq &optional (start 0) end)

59

(typecase seq

60

(,type

61

(let ((end (or end (length seq))))

62

,@body))

63

(t

64

(call-next-method)))))

65

66

(defmacro define-stream-write-sequence (specializer type &body body)

67

`(defmethod sb-gray:stream-write-sequence ((stream ,specializer) seq &optional (start 0) end)

68

(typecase seq

69

(,type

70

(let ((end (or end (length seq))))

71

,@body))

72

(t

73

(call-next-method)))))

74

75

;;; input streams

76

(defclass octet-input-stream (octet-stream #.*binary-input-stream-class*)

77

((index :accessor index :initarg :index :type index)

78

(end :accessor end :initarg :end :type index)))

79

80

(defmethod #.*stream-read-byte-function* ((stream octet-input-stream))

81

(let ((buffer (buffer stream))

82

(index (index stream)))

83

(declare (type simple-octet-vector buffer))

84

(cond

85

((>= index (end stream)) :eof)

86

(t

87

(setf (index stream) (1+ index))

88

(aref buffer index)))))

89

90

(define-stream-read-sequence octet-input-stream simple-octet-vector

91

(let ((buffer (buffer stream))

92

(index (index stream))

93

(buffer-end (end stream)))

94

(declare (type simple-octet-vector buffer))

95

(let* ((remaining (- buffer-end index))

96

(length (- end start))

97

(amount (min remaining length)))

98

(replace seq buffer :start1 start :end1 end

99

:start2 index :end2 buffer-end)

100

(setf (index stream) (+ index amount))

101

(+ start amount))))

102

103

(defun make-octet-input-stream (buffer &optional (start 0) end)

104

"As MAKE-STRING-INPUT-STREAM, only with octets instead of characters."

105

(declare (type simple-octet-vector buffer)

106

(type index start)

107

(type (or index null) end))

108

(let ((end (or end (length buffer))))

109

(make-instance 'octet-input-stream

110

:buffer buffer :index start :end end)))

111

112

(defmacro with-octet-input-stream ((var buffer &optional (start 0) end) &body body)

113

`(with-open-stream (,var (make-octet-input-stream ,buffer ,start ,end))

114

,@body))

115

116

;;; output streams

117

(defclass octet-output-stream (octet-stream #.*binary-output-stream-class*)

118

((index :accessor index :initform 0 :type index)))

119

120

(defmethod #.*stream-write-byte-function* ((stream octet-output-stream) integer)

121

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

122

(let* ((buffer (buffer stream))

123

(length (length buffer))

124

(index (index stream)))

125

(declare (type simple-octet-vector buffer))

126

(when (>= index (length buffer))

127

(let ((new-buffer (make-array (* 2 length)

128

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

129

(declare (type simple-octet-vector new-buffer))

130

(replace new-buffer buffer)

131

(setf buffer new-buffer

132

(buffer stream) new-buffer)))

133

(setf (aref buffer index) integer

134

(index stream) (1+ index))

135

integer))

136

137

(define-stream-write-sequence octet-output-stream simple-octet-vector

138

(let* ((buffer (buffer stream))

139

(length (length buffer))

140

(index (index stream))

141

(amount (- end start)))

142

(declare (type simple-octet-vector buffer))

143

(when (>= (+ index amount) length)

144

(let ((new-buffer (make-array (* 2 (max amount length))

145

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

146

(declare (type simple-octet-vector new-buffer))

147

(replace new-buffer buffer)

148

(setf buffer new-buffer

149

(buffer stream) new-buffer)))

150

(replace buffer seq :start1 index :start2 start :end2 end)

151

(incf (index stream) amount)

152

seq))

153

154

(defmethod #.*stream-clear-output-function* ((stream octet-output-stream))

155

(setf (index stream) 0)

156

nil)

157

158

(defun get-output-stream-octets (stream)

159

"As GET-OUTPUT-STREAM-STRING, only with an octet output-stream instead

160

of a string output-stream."

161

(let ((buffer (buffer stream))

162

(index (index stream)))

163

(setf (index stream) 0)

164

(subseq buffer 0 index)))

165

166

(defun make-octet-output-stream ()

167

"As MAKE-STRING-OUTPUT-STREAM, only with octets instead of characters."

168

(make-instance 'octet-output-stream

169

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

170

171

(defmacro with-octet-output-stream ((var) &body body)

172

`(with-open-stream (,var (make-octet-output-stream))

173

,@body

174

(get-output-stream-octets ,var)))

175

176

;;; digesting streams

177

(defclass digesting-stream (#.*binary-output-stream-class*)

178

((digest :initarg :digest :reader stream-digest)

179

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

180

:reader stream-buffer)

181

(position :initform 0

182

:reader stream-buffer-position)))

183

184

(defmethod #.*stream-element-type-function* ((stream digesting-stream))

185

'(unsigned-byte 8))

186

187

(defun make-digesting-stream (digest &rest args)

188

(make-instance 'digesting-stream :digest (apply #'make-digest digest args)))

189

190

(defmethod #.*stream-write-byte-function* ((stream digesting-stream) byte)

191

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

192

(with-slots (digest buffer position) stream

193

(setf (aref buffer position) byte)

194

(when (= (incf position) 64)

195

(update-digest digest buffer :start 0 :end 64)

196

(setf position 0))

197

byte))

198

199

(define-stream-write-sequence digesting-stream simple-octet-vector

200

(unless (zerop (stream-buffer-position stream))

201

(update-digest (stream-digest stream)

202

(stream-buffer stream)

203

:end (stream-buffer-position stream))

204

(setf (slot-value stream 'position) 0))

205

(update-digest (stream-digest stream) seq :start start :end end)

206

seq)

207

208

(defmethod #.*stream-clear-output-function* ((stream digesting-stream))

209

(with-slots (digest position) stream

210

(setf position 0)

211

(reinitialize-instance digest)

212

nil))

213

214

(defmethod produce-digest ((stream digesting-stream)

215

&key digest (digest-start 0))

216

(with-slots ((%digest digest) buffer position) stream

217

(unless (zerop position)

218

(update-digest %digest buffer :start 0 :end position)

219

(setf position 0))

220

(produce-digest %digest :digest digest :digest-start digest-start)))

221

222

(defun execute-with-digesting-stream (digest fn)

223

(with-open-stream (stream (make-digesting-stream digest))

224

(funcall fn stream)

225

(produce-digest stream)))

226

227

(defmacro with-digesting-stream ((var digest &rest args) &body body)

228

`(with-open-stream (,var (make-digesting-stream ,digest ,@args))

229

,@body

230

(produce-digest ,var)))

231

232

;;; encrypting and decrypting streams

233

(defclass crypting-stream ()

234

((cipher :initarg :cipher :reader stream-cipher)

235

(buffer :initarg :buffer :reader stream-buffer)

236

(n-bytes-valid :initform 0 :reader stream-n-bytes-valid)

237

(position :initform 0 :reader stream-buffer-position)

238

(wrapped-stream :initarg :stream :reader stream-wrapped-stream)))

239

240

(defmethod #.*stream-element-type-function* ((stream crypting-stream))

241

'(unsigned-byte 8))

242

243

(defclass encrypting-input-stream (crypting-stream #.*binary-input-stream-class*) ())

244

(defclass encrypting-output-stream (crypting-stream #.*binary-output-stream-class*) ())

245

(defclass decrypting-input-stream (crypting-stream #.*binary-input-stream-class*) ())

246

(defclass decrypting-output-stream (crypting-stream #.*binary-output-stream-class*) ())

247

248

(deftype stream-direction () '(member :input :output))

249

250

(defun make-encrypting-stream (stream cipher mode key &key initialization-vector (direction :output))

251

(declare (type stream-direction direction))

252

(unless (member mode '(ctr :ctr cfb :cfb cfb8 :cfb8 ofb :ofb stream :stream))

253

(error 'ironclad-error

254

            :format-control "Encrypting streams support only CTR, CFB, CFB8, OFB and STREAM modes"))

255

(let* ((context (make-cipher cipher :mode mode :key key

256

:initialization-vector initialization-vector))

257

(block-length (max (block-length cipher) 4096))

258

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

259

(if (eq direction :input)

260

(make-instance 'encrypting-input-stream :stream stream

261

:cipher context :buffer buffer)

262

(make-instance 'encrypting-output-stream :stream stream

263

:cipher context :buffer buffer))))

264

265

(defun make-decrypting-stream (stream cipher mode key &key initialization-vector (direction :input))

266

(declare (type stream-direction direction))

267

(unless (member mode '(ctr :ctr cfb :cfb cfb8 :cfb8 ofb :ofb stream :stream))

268

(error 'ironclad-error

269

            :format-control "Decrypting streams support only CTR, CFB, CFB8, OFB and STREAM modes"))

270

(let* ((context (make-cipher cipher :mode mode :key key

271

:initialization-vector initialization-vector))

272

(block-length (max (block-length cipher) 4096))

273

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

274

(if (eq direction :input)

275

(make-instance 'decrypting-input-stream :stream stream

276

:cipher context :buffer buffer)

277

(make-instance 'decrypting-output-stream :stream stream

278

:cipher context :buffer buffer))))

279

280

(defmethod #.*stream-read-byte-function* ((stream encrypting-input-stream))

281

(with-slots (wrapped-stream cipher buffer n-bytes-valid position)

282

stream

283

(when (= position n-bytes-valid)

284

(setf n-bytes-valid (read-sequence buffer wrapped-stream)

285

position 0)

286

(when (zerop n-bytes-valid)

287

(return-from #.*stream-read-byte-function* :eof))

288

(encrypt cipher buffer buffer :plaintext-end n-bytes-valid))

289

(prog1 (aref buffer position)

290

(incf position))))

291

292

(defmethod #.*stream-read-byte-function* ((stream decrypting-input-stream))

293

(with-slots (wrapped-stream cipher buffer n-bytes-valid position)

294

stream

295

(when (= position n-bytes-valid)

296

(setf n-bytes-valid (read-sequence buffer wrapped-stream)

297

position 0)

298

(when (zerop n-bytes-valid)

299

(return-from #.*stream-read-byte-function* :eof))

300

(decrypt cipher buffer buffer :ciphertext-end n-bytes-valid))

301

(prog1 (aref buffer position)

302

(incf position))))

303

304

(defmethod #.*stream-write-byte-function* ((stream encrypting-output-stream) byte)

305

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

306

(with-slots (wrapped-stream cipher buffer)

307

stream

308

(setf (aref buffer 0) byte)

309

(encrypt cipher buffer buffer :plaintext-end 1)

310

(write-byte (aref buffer 0) wrapped-stream)

311

byte))

312

313

(defmethod #.*stream-write-byte-function* ((stream decrypting-output-stream) byte)

314

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

315

(with-slots (wrapped-stream cipher buffer)

316

stream

317

(setf (aref buffer 0) byte)

318

(decrypt cipher buffer buffer :ciphertext-end 1)

319

(write-byte (aref buffer 0) wrapped-stream)

320

byte))

321

322

(define-stream-read-sequence encrypting-input-stream simple-octet-vector

323

(with-slots (wrapped-stream cipher buffer n-bytes-valid position)

324

stream

325

(do ((n 0))

326

((= start end) start)

327

(when (= position n-bytes-valid)

328

(setf n-bytes-valid (read-sequence buffer wrapped-stream)

329

position 0)

330

(when (zerop n-bytes-valid)

331

(return start))

332

(encrypt cipher buffer buffer :plaintext-end n-bytes-valid))

333

(setf n (min (- end start) (- n-bytes-valid position)))

334

(replace seq buffer :start1 start :end1 end :start2 position :end2 n-bytes-valid)

335

(incf start n)

336

(incf position n))))

337

338

(define-stream-read-sequence decrypting-input-stream simple-octet-vector

339

(with-slots (wrapped-stream cipher buffer n-bytes-valid position)

340

stream

341

(do ((n 0))

342

((= start end) start)

343

(when (= position n-bytes-valid)

344

(setf n-bytes-valid (read-sequence buffer wrapped-stream)

345

position 0)

346

(when (zerop n-bytes-valid)

347

(return start))

348

(decrypt cipher buffer buffer :ciphertext-end n-bytes-valid))

349

(setf n (min (- end start) (- n-bytes-valid position)))

350

(replace seq buffer :start1 start :end1 end :start2 position :end2 n-bytes-valid)

351

(incf start n)

352

(incf position n))))

353

354

(define-stream-write-sequence encrypting-output-stream simple-octet-vector

355

(with-slots (wrapped-stream cipher buffer)

356

stream

357

(do ((buffer-length (length buffer))

358

(length (- end start))

359

(n 0))

360

((zerop length))

361

(setf n (min buffer-length length))

362

(encrypt cipher seq buffer :plaintext-start start :plaintext-end (+ start n))

363

(write-sequence buffer wrapped-stream :end n)

364

(decf length n)

365

(incf start n))

366

seq))

367

368

(define-stream-write-sequence decrypting-output-stream simple-octet-vector

369

(with-slots (wrapped-stream cipher buffer)

370

stream

371

(do ((buffer-length (length buffer))

372

(length (- end start))

373

(n 0))

374

((zerop length))

375

(setf n (min buffer-length length))

376

(decrypt cipher seq buffer :ciphertext-start start :ciphertext-end (+ start n))

377

(write-sequence buffer wrapped-stream :end n)

378

(decf length n)

379

(incf start n))

380

seq))

381

382

(defmacro with-encrypting-stream ((var stream cipher mode key

383

                                    &key initialization-vector (direction :output))

384

&body body)

385

`(with-open-stream (,var (make-encrypting-stream ,stream ,cipher ,mode ,key

386

                                                    :initialization-vector ,initialization-vector

387

                                                    :direction ,direction))

388

,@body))

389

390

(defmacro with-decrypting-stream ((var stream cipher mode key

391

                                    &key initialization-vector (direction :input))

392

&body body)

393

`(with-open-stream (,var (make-decrypting-stream ,stream ,cipher ,mode ,key

394

                                                    :initialization-vector ,initialization-vector

395

                                                    :direction ,direction))

396

,@body))

397

398

;;; authenticating streams

399

(defclass authenticating-stream (#.*binary-output-stream-class*)

400

((mac :initarg :mac :reader stream-mac)

401

(buffer :initform (make-array 64 :element-type '(unsigned-byte 8)) :reader stream-buffer)

402

(position :initform 0 :reader stream-buffer-position)))

403

404

(defmethod #.*stream-element-type-function* ((stream authenticating-stream))

405

'(unsigned-byte 8))

406

407

(defun make-authenticating-stream (mac key &rest args)

408

(make-instance 'authenticating-stream :mac (apply #'make-mac mac key args)))

409

410

(defmethod #.*stream-write-byte-function* ((stream authenticating-stream) byte)

411

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

412

(with-slots (mac buffer position) stream

413

(setf (aref buffer position) byte)

414

(when (= (incf position) 64)

415

(update-mac mac buffer :start 0 :end 64)

416

(setf position 0))

417

byte))

418

419

(define-stream-write-sequence authenticating-stream simple-octet-vector

420

(unless (zerop (stream-buffer-position stream))

421

(update-mac (stream-mac stream) (stream-buffer stream) :end (stream-buffer-position stream))

422

(setf (slot-value stream 'position) 0))

423

(update-mac (stream-mac stream) seq :start start :end end)

424

seq)

425

426

(defmethod produce-mac ((stream authenticating-stream) &key digest (digest-start 0))

427

(with-slots (mac buffer position) stream

428

(unless (zerop position)

429

(update-mac mac buffer :start 0 :end position)

430

(setf position 0))

431

(produce-mac mac :digest digest :digest-start digest-start)))

432

433

(defmacro with-authenticating-stream ((var mac key &rest args) &body body)

434

`(with-open-stream (,var (make-authenticating-stream ,mac ,key ,@args))

435

,@body

436

(produce-mac ,var)))