Coverage report: /home/ellis/.stash/lisp/cl-plus-ssl/src/x509.lisp

Kind	Covered	All	%
expression	83	532	15.6
branch	3	80	3.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-

2

;;;

3

;;; Copyright (C) contributors as per cl+ssl git history

4

;;;

5

;;; See LICENSE for details.

6

7

(in-package :cl+ssl)

8

9

#|

10

ASN1 string validation references:

11

- https://github.com/digitalbazaar/forge/blob/909e312878838f46ba6d70e90264650b05eb8bde/js/asn1.js

12

- http://www.obj-sys.com/asn1tutorial/node128.html

13

- https://github.com/deadtrickster/ssl_verify_hostname.erl/blob/master/src/ssl_verify_hostname.erl

14

- https://golang.org/src/encoding/asn1/asn1.go?m=text

15

|#

16

(defgeneric decode-asn1-string (asn1-string type))

17

18

(defun copy-bytes-to-lisp-vector (src-ptr vector count)

19

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

20

(type fixnum count)

21

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

22

(dotimes (i count vector)

23

(setf (aref vector i) (cffi:mem-aref src-ptr :unsigned-char i))))

24

25

(defun asn1-string-bytes-vector (asn1-string)

26

(let* ((data (asn1-string-data asn1-string))

27

(length (asn1-string-length asn1-string))

28

(vector (cffi:make-shareable-byte-vector length)))

29

(copy-bytes-to-lisp-vector data vector length)

30

vector))

31

32

(defun asn1-iastring-char-p (byte)

33

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

34

(optimize (speed 3)

35

(debug 0)

36

(safety 0)))

37

(< byte #x80))

38

39

(defun asn1-iastring-p (bytes)

40

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

41

(optimize (speed 3)

42

(debug 0)

43

(safety 0)))

44

(every #'asn1-iastring-char-p bytes))

45

46

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-iastring+)))

47

(let ((bytes (asn1-string-bytes-vector asn1-string)))

48

(if (asn1-iastring-p bytes)

49

(flex:octets-to-string bytes :external-format :ascii)

50

(error 'invalid-asn1-string :type '+v-asn1-iastring+))))

51

52

(defun asn1-printable-char-p (byte)

53

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

54

(optimize (speed 3)

55

(debug 0)

56

(safety 0)))

57

(cond

58

;; a-z

59

((and (>= byte #.(char-code #\a))

60

(<= byte #.(char-code #\z)))

61

t)

62

;; '-/

63

((and (>= byte #.(char-code #\'))

64

(<= byte #.(char-code #\/)))

65

t)

66

;; 0-9

67

((and (>= byte #.(char-code #\0))

68

(<= byte #.(char-code #\9)))

69

t)

70

;; A-Z

71

((and (>= byte #.(char-code #\A))

72

(<= byte #.(char-code #\Z)))

73

t)

74

;; other

75

((= byte #.(char-code #\ )) t)

76

((= byte #.(char-code #\:)) t)

77

((= byte #.(char-code #\=)) t)

78

((= byte #.(char-code #\?)) t)))

79

80

(defun asn1-printable-string-p (bytes)

81

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

82

(optimize (speed 3)

83

(debug 0)

84

(safety 0)))

85

(every #'asn1-printable-char-p bytes))

86

87

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-printablestring+)))

88

(let* ((bytes (asn1-string-bytes-vector asn1-string)))

89

(if (asn1-printable-string-p bytes)

90

(flex:octets-to-string bytes :external-format :ascii)

91

(error 'invalid-asn1-string :type '+v-asn1-printablestring+))))

92

93

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-utf8string+)))

94

(let* ((data (asn1-string-data asn1-string))

95

(length (asn1-string-length asn1-string)))

96

(cffi:foreign-string-to-lisp data :count length :encoding :utf-8)))

97

98

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-universalstring+)))

99

(if (= 0 (mod (asn1-string-length asn1-string) 4))

100

;; cffi sometimes fails here on sbcl? idk why (maybe threading?)

101

;; fail: Illegal :UTF-32 character starting at position 48...

102

;; when (length bytes) is 48...

103

;; so I'm passing :count explicitly

104

       (or (ignore-errors (cffi:foreign-string-to-lisp (asn1-string-data asn1-string) :count (asn1-string-length asn1-string) :encoding :utf-32))

105

(error 'invalid-asn1-string :type '+v-asn1-universalstring+))

106

(error 'invalid-asn1-string :type '+v-asn1-universalstring+)))

107

108

(defun asn1-teletex-char-p (byte)

109

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

110

(optimize (speed 3)

111

(debug 0)

112

(safety 0)))

113

(and (>= byte #x20)

114

(< byte #x80)))

115

116

(defun asn1-teletex-string-p (bytes)

117

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

118

(optimize (speed 3)

119

(debug 0)

120

(safety 0)))

121

(every #'asn1-teletex-char-p bytes))

122

123

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-teletexstring+)))

124

(let ((bytes (asn1-string-bytes-vector asn1-string)))

125

(if (asn1-teletex-string-p bytes)

126

(flex:octets-to-string bytes :external-format :ascii)

127

(error 'invalid-asn1-string :type '+v-asn1-teletexstring+))))

128

129

(defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-bmpstring+)))

130

(if (= 0 (mod (asn1-string-length asn1-string) 2))

131

       (or (ignore-errors (cffi:foreign-string-to-lisp (asn1-string-data asn1-string) :count (asn1-string-length asn1-string) :encoding :utf-16/be))

132

(error 'invalid-asn1-string :type '+v-asn1-bmpstring+))

133

(error 'invalid-asn1-string :type '+v-asn1-bmpstring+)))

134

135

;; TODO: respect asn1-string type

136

(defun try-get-asn1-string-data (asn1-string allowed-types)

137

(let ((type (asn1-string-type asn1-string)))

138

(assert (member (asn1-string-type asn1-string) allowed-types) nil "Invalid asn1 string type")

139

(decode-asn1-string asn1-string type)))

140

141

;; ASN1 Times are represented with ASN1 Strings

142

(defun decode-asn1-time (asn1-time)

143

(when (zerop (asn1-time-check asn1-time))

144

(error "asn1-time is not a syntactically valid ASN1 UTCTime"))

145

(let ((time-string (flex:octets-to-string (asn1-string-bytes-vector asn1-time)

146

:external-format :ascii)))

147

(let* ((utctime-p (= 1 (asn1-utctime-check asn1-time)))

148

(year-len (if utctime-p 2 4))

149

(year-part (parse-integer (subseq time-string 0 year-len)))

150

(year (if utctime-p

151

(if (>= year-part 50)

152

(+ 1900 year-part)

153

(+ 2000 year-part))

154

year-part)))

155

(flet ((get-element-after-year (position)

156

(parse-integer

157

(subseq time-string

158

(+ position year-len)

159

(+ position year-len 2)))))

160

(let ((month (get-element-after-year 0))

161

(day (get-element-after-year 2))

162

(hour (get-element-after-year 4))

163

(minute (get-element-after-year 6))

164

(second (get-element-after-year 8)))

165

(encode-universal-time second minute hour day month year 0))))))

166

167

(defun slurp-stream (stream)

168

"Returns a sequence containing the STREAM bytes; the

169

sequence is created by CFFI:MAKE-SHAREABLE-BYTE-VECTOR,

170

therefore it can safely be passed to

171

CFFI:WITH-POINTER-TO-VECTOR-DATA."

172

(let ((seq (cffi:make-shareable-byte-vector (file-length stream))))

173

(read-sequence seq stream)

174

seq))

175

176

(defgeneric decode-certificate (format bytes)

177

(:documentation

178

"The BYTES must be created by CFFI:MAKE-SHAREABLE-BYTE-VECTOR (because

179

we are going to pass them to CFFI:WITH-POINTER-TO-VECTOR-DATA)"))

180

181

(defmethod decode-certificate ((format (eql :der)) bytes)

182

(cffi:with-pointer-to-vector-data (buf* bytes)

183

(cffi:with-foreign-object (buf** :pointer)

184

(setf (cffi:mem-ref buf** :pointer) buf*)

185

(let ((cert (d2i-x509 (cffi:null-pointer) buf** (length bytes))))

186

(when (cffi:null-pointer-p cert)

187

(error 'ssl-error-call :message "d2i-X509 failed" :queue (read-ssl-error-queue)))

188

cert))))

189

190

(defun cert-format-from-path (path)

191

;; or match "pem" type too and raise unknown format error?

192

(if (equal "der" (pathname-type path))

193

:der

194

:pem))

195

196

(defun decode-certificate-from-file (path &key format)

197

(let ((bytes (with-open-file (stream path :element-type '(unsigned-byte 8))

198

(slurp-stream stream)))

199

(format (or format (cert-format-from-path path))))

200

(decode-certificate format bytes)))

201

202

(defun certificate-alt-names (cert)

203

#|

204

* The return value is the decoded extension or NULL on

205

* error. The actual error can have several different causes,

206

* the value of *crit reflects the cause:

207

* >= 0, extension found but not decoded (reflects critical value).

208

* -1 extension not found.

209

* -2 extension occurs more than once.

210

|#

211

(cffi:with-foreign-object (crit* :int)

212

(let ((result (x509-get-ext-d2i cert +NID-subject-alt-name+ crit* (cffi:null-pointer))))

213

(if (cffi:null-pointer-p result)

214

(let ((crit (cffi:mem-ref crit* :int)))

215

(cond

216

((>= crit 0)

217

(error "X509_get_ext_d2i: subject-alt-name extension decoding error"))

218

((= crit -1) ;; extension not found, return NULL

219

result)

220

((= crit -2)

221

(error "X509_get_ext_d2i: subject-alt-name extension occurs more than once"))))

222

result))))

223

224

(defun certificate-dns-alt-names (cert)

225

(let ((altnames (certificate-alt-names cert)))

226

(unless (cffi:null-pointer-p altnames)

227

(unwind-protect

228

(flet ((alt-name-to-string (alt-name)

229

(cffi:with-foreign-slots ((type data) alt-name (:struct general-name))

230

(case type

231

(#. +GEN-IPADD+

232

(let ((address (asn1-string-bytes-vector data)))

233

(usocket:host-to-hostname address)))

234

(#. +GEN-DNS+

235

(or (try-get-asn1-string-data data '(#. +v-asn1-iastring+))

236

                              (error "Malformed certificate: possibly NULL in dns-alt-name")))))))

237

(let ((altnames-count (sk-general-name-num altnames)))

238

(loop for i from 0 below altnames-count

239

as alt-name = (sk-general-name-value altnames i)

240

collect (alt-name-to-string alt-name))))

241

(general-names-free altnames)))))

242

243

(defun certificate-subject-common-names (cert)

244

(let ((i -1)

245

(subject-name (x509-get-subject-name cert)))

246

(when (cffi:null-pointer-p subject-name)

247

(error "X509_get_subject_name returned NULL"))

248

(flet ((extract-cn ()

249

(setf i (x509-name-get-index-by-nid subject-name +NID-commonName+ i))

250

(when (>= i 0)

251

(let* ((entry (x509-name-get-entry subject-name i)))

252

(when (cffi:null-pointer-p entry)

253

(error "X509_NAME_get_entry returned NULL"))

254

(let ((entry-data (x509-name-entry-get-data entry)))

255

(when (cffi:null-pointer-p entry-data)

256

(error "X509_NAME_ENTRY_get_data returned NULL"))

257

(try-get-asn1-string-data entry-data '(#.+v-asn1-utf8string+

258

                                                           #.+v-asn1-bmpstring+

259

                                                           #.+v-asn1-printablestring+

260

                                                           #.+v-asn1-universalstring+

261

                                                           #.+v-asn1-teletexstring+)))))))

262

(loop

263

as cn = (extract-cn)

264

if cn collect cn

265

if (not cn) do

266

(loop-finish)))))

267

268

(defun certificate-not-after-time (certificate)

269

"Returns a universal-time representing the time after

270

which the CERTIFICATE is not valid. Signals an ERROR if the

271

CERTIFICATE does not have a properly formatted time. "

272

273

(when (or (openssl-is-not-even 1 1 0)

274

(libresslp))

275

(error "certificate-not-after-time currently requires version OpenSSL 1.1.0 or newer"))

276

277

(let ((asn1-time (x509-get0-not-after certificate)))

278

(when (cffi:null-pointer-p asn1-time)

279

(error "X509_get0_notAfter returned NULL"))

280

(decode-asn1-time asn1-time)))

281

282

(defun certificate-not-before-time (certificate)

283

"Returns a universal-time representing the time before

284

which the CERTIFICATE is not valid. Signals an ERROR if

285

the CERTIFICATE does not have a properly formatted time."

286

287

(when (or (openssl-is-not-even 1 1 0)

288

(libresslp))

289

(error "certificate-not-before-time currently requires version OpenSSL 1.1.0 or newer"))

290

291

(let ((asn1-time (x509-get0-not-before certificate)))

292

(when (cffi:null-pointer-p asn1-time)

293

(error "X509_get0_notBefore returned NULL"))

294

(decode-asn1-time asn1-time)))

295

296

(defun certificate-fingerprint (certificate &optional (algorithm :sha1))

297

"Return the fingerprint of CERTIFICATE as a byte-vector. ALGORITHM is a string

298

designator for the digest algorithm to use (it defaults to SHA-1)."

299

(ensure-initialized)

300

(let ((evp (evp-get-digest-by-name (string algorithm))))

301

(when (cffi:null-pointer-p evp)

302

(error 'ssl-error-call

303

:message (format nil "unknown digest algorithm ~A" algorithm)

304

:queue (read-ssl-error-queue)))

305

(let* ((size (funcall (if (openssl-is-at-least 3 0 0)

306

'evp-md-get-size

307

'evp-md-size)

308

evp))

309

(fingerprint (cffi:make-shareable-byte-vector size)))

310

(cffi:with-pointer-to-vector-data (buf fingerprint)

311

(unless (= 1 (x509-digest certificate evp buf (cffi:null-pointer)))

312

(error 'ssl-error-call

313

:message "failed to compute fingerprint of certificate"

314

:queue (read-ssl-error-queue))))

315

fingerprint)))

316

317

(defun x509-cert-from-pem (pem)

318

(with-bio-input-from-string (bio pem)

319

(pem-read-x509 bio 0 0 0)))

320

321

(defun certificate-pem (x509)

322

(with-bio-output-to-string (bio)

323

;; man PEM_write_bio_X509:

324

;; The write routines return 1 for success or 0 for failure.

325

(unless (= 1 (pem-write-x509 bio x509))

326

(error "X509 cert cant be printed: ~s"

327

(cl+ssl::err-error-string (cl+ssl::err-get-error) (cffi:null-pointer))))))