Recently Written · git

clic

MIRROR ONLY Gopher client with pretty colours in Common Lisp

git clone https://github.com/equwal/clic

Log | Files | Refs

3rdparties/software/cl+ssl-20200427-git/src/x509.lisp (9877 bytes)

1 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2 
3 (in-package :cl+ssl)
4 
5 #|
6 ASN1 string validation references:
7  - https://github.com/digitalbazaar/forge/blob/909e312878838f46ba6d70e90264650b05eb8bde/js/asn1.js
8  - http://www.obj-sys.com/asn1tutorial/node128.html
9  - https://github.com/deadtrickster/ssl_verify_hostname.erl/blob/master/src/ssl_verify_hostname.erl
10  - https://golang.org/src/encoding/asn1/asn1.go?m=text
11 |#
12 (defgeneric decode-asn1-string (asn1-string type))
13 
14 (defun copy-bytes-to-lisp-vector (src-ptr vector count)
15   (declare (type (simple-array (unsigned-byte 8)) vector)
16            (type fixnum count)
17            (optimize (safety 0) (debug 0) (speed 3)))
18   (dotimes (i count vector)
19     (setf (aref vector i) (cffi:mem-aref src-ptr :unsigned-char i))))
20 
21 (defun asn1-string-bytes-vector (asn1-string)
22   (let* ((data (asn1-string-data asn1-string))
23          (length (asn1-string-length asn1-string))
24          (vector (cffi:make-shareable-byte-vector length)))
25     (copy-bytes-to-lisp-vector data vector length)
26     vector))
27 
28 (defun asn1-iastring-char-p (byte)
29   (declare (type (unsigned-byte 8) byte)
30            (optimize (speed 3)
31                      (debug 0)
32                      (safety 0)))
33   (< byte #x80))
34 
35 (defun asn1-iastring-p (bytes)
36   (declare (type (simple-array (unsigned-byte 8)) bytes)
37            (optimize (speed 3)
38                      (debug 0)
39                      (safety 0)))
40   (every #'asn1-iastring-char-p bytes))
41 
42 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-iastring+)))
43   (let ((bytes (asn1-string-bytes-vector asn1-string)))
44     (if (asn1-iastring-p bytes)
45         (flex:octets-to-string bytes :external-format :ascii)
46         (error 'invalid-asn1-string :type '+v-asn1-iastring+))))
47 
48 (defun asn1-printable-char-p (byte)
49   (declare (type (unsigned-byte 8) byte)
50            (optimize (speed 3)
51                      (debug 0)
52                      (safety 0)))
53   (cond
54     ;; a-z
55     ((and (>= byte #.(char-code #\a))
56           (<= byte #.(char-code #\z)))
57      t)
58     ;; '-/
59     ((and (>= byte #.(char-code #\'))
60           (<= byte #.(char-code #\/)))
61      t)
62     ;; 0-9
63     ((and (>= byte #.(char-code #\0))
64           (<= byte #.(char-code #\9)))
65      t)
66     ;; A-Z
67     ((and (>= byte #.(char-code #\A))
68           (<= byte #.(char-code #\Z)))
69      t)
70     ;; other
71     ((= byte #.(char-code #\ )) t)
72     ((= byte #.(char-code #\:)) t)
73     ((= byte #.(char-code #\=)) t)
74     ((= byte #.(char-code #\?)) t)))
75 
76 (defun asn1-printable-string-p (bytes)
77   (declare (type (simple-array (unsigned-byte 8)) bytes)
78            (optimize (speed 3)
79                      (debug 0)
80                      (safety 0)))
81   (every #'asn1-printable-char-p bytes))
82 
83 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-printablestring+)))
84   (let* ((bytes (asn1-string-bytes-vector asn1-string)))
85     (if (asn1-printable-string-p bytes)
86         (flex:octets-to-string bytes :external-format :ascii)
87         (error 'invalid-asn1-string :type '+v-asn1-printablestring+))))
88 
89 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-utf8string+)))
90   (let* ((data (asn1-string-data asn1-string))
91          (length (asn1-string-length asn1-string)))
92     (cffi:foreign-string-to-lisp data :count length :encoding :utf-8)))
93 
94 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-universalstring+)))
95   (if (= 0 (mod (asn1-string-length asn1-string) 4))
96       ;; cffi sometimes fails here on sbcl? idk why (maybe threading?)
97       ;; fail: Illegal :UTF-32 character starting at position 48...
98       ;; when (length bytes) is 48...
99       ;; so I'm passing :count explicitly
100       (or (ignore-errors (cffi:foreign-string-to-lisp (asn1-string-data asn1-string) :count (asn1-string-length asn1-string) :encoding :utf-32))
101           (error 'invalid-asn1-string :type '+v-asn1-universalstring+))
102       (error 'invalid-asn1-string :type '+v-asn1-universalstring+)))
103 
104 (defun asn1-teletex-char-p (byte)
105   (declare (type (unsigned-byte 8) byte)
106            (optimize (speed 3)
107                      (debug 0)
108                      (safety 0)))
109   (and (>= byte #x20)
110        (< byte #x80)))
111 
112 (defun asn1-teletex-string-p (bytes)
113   (declare (type (simple-array (unsigned-byte 8)) bytes)
114            (optimize (speed 3)
115                      (debug 0)
116                      (safety 0)))
117   (every #'asn1-teletex-char-p bytes))
118 
119 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-teletexstring+)))
120   (let ((bytes (asn1-string-bytes-vector asn1-string)))
121     (if (asn1-teletex-string-p bytes)
122         (flex:octets-to-string bytes :external-format :ascii)
123         (error 'invalid-asn1-string :type '+v-asn1-teletexstring+))))
124 
125 (defmethod decode-asn1-string (asn1-string (type (eql +v-asn1-bmpstring+)))
126   (if (= 0 (mod (asn1-string-length asn1-string) 2))
127       (or (ignore-errors (cffi:foreign-string-to-lisp (asn1-string-data asn1-string) :count (asn1-string-length asn1-string) :encoding :utf-16/be))
128           (error 'invalid-asn1-string :type '+v-asn1-bmpstring+))
129       (error 'invalid-asn1-string :type '+v-asn1-bmpstring+)))
130 
131 ;; TODO: respect asn1-string type
132 (defun try-get-asn1-string-data (asn1-string allowed-types)
133   (let ((type (asn1-string-type asn1-string)))
134     (assert (member (asn1-string-type asn1-string) allowed-types) nil "Invalid asn1 string type")
135     (decode-asn1-string asn1-string type)))
136 
137 (defun slurp-stream (stream)
138   "Returns a sequence containing the STREAM bytes; the
139 sequence is created by CFFI:MAKE-SHAREABLE-BYTE-VECTOR,
140 therefore it can safely be passed to
141  CFFI:WITH-POINTER-TO-VECTOR-DATA."
142   (let ((seq (cffi:make-shareable-byte-vector (file-length stream))))
143     (read-sequence seq stream)
144     seq))
145 
146 (defgeneric decode-certificate (format bytes)
147   (:documentation
148    "The BYTES must be created by CFFI:MAKE-SHAREABLE-BYTE-VECTOR (because
149 we are going to pass them to CFFI:WITH-POINTER-TO-VECTOR-DATA)"))
150 
151 (defmethod decode-certificate ((format (eql :der)) bytes)
152   (cffi:with-pointer-to-vector-data (buf* bytes)
153     (cffi:with-foreign-object (buf** :pointer)
154       (setf (cffi:mem-ref buf** :pointer) buf*)
155       (let ((cert (d2i-x509 (cffi:null-pointer) buf** (length bytes))))
156         (when (cffi:null-pointer-p cert)
157           (error 'ssl-error-call :message "d2i-X509 failed" :queue (read-ssl-error-queue)))
158         cert))))
159 
160 (defun cert-format-from-path (path)
161   ;; or match "pem" type too and raise unknown format error?
162   (if (equal "der" (pathname-type path))
163       :der
164       :pem))
165 
166 (defun decode-certificate-from-file (path &key format)
167   (let ((bytes (with-open-file (stream path :element-type '(unsigned-byte 8))
168                  (slurp-stream stream)))
169         (format (or format (cert-format-from-path path))))
170     (decode-certificate format bytes)))
171 
172 (defun certificate-alt-names (cert)
173   #|
174   * The return value is the decoded extension or NULL on
175   * error. The actual error can have several different causes,
176   * the value of *crit reflects the cause:
177   * >= 0, extension found but not decoded (reflects critical value).
178   * -1 extension not found.
179   * -2 extension occurs more than once.
180   |#
181   (cffi:with-foreign-object (crit* :int)
182     (let ((result (x509-get-ext-d2i cert +NID-subject-alt-name+ crit* (cffi:null-pointer))))
183       (if (cffi:null-pointer-p result)
184           (let ((crit (cffi:mem-ref crit* :int)))
185             (cond
186               ((>= crit 0)
187                (error "X509_get_ext_d2i: subject-alt-name extension decoding error"))
188               ((= crit -1) ;; extension not found, return NULL
189                result)
190               ((= crit -2)
191                (error "X509_get_ext_d2i: subject-alt-name extension occurs more than once"))))
192           result))))
193 
194 (defun certificate-dns-alt-names (cert)
195   (let ((altnames (certificate-alt-names cert)))
196     (unless (cffi:null-pointer-p altnames)
197       (unwind-protect
198            (flet ((alt-name-to-string (alt-name)
199                     (cffi:with-foreign-slots ((type data) alt-name (:struct general-name))
200                       (when (= type +GEN-DNS+)
201                         (alexandria:if-let ((string (try-get-asn1-string-data data '(#.+v-asn1-iastring+))))
202                           string
203                           (error "Malformed certificate: possibly NULL in dns-alt-name"))))))
204              (let ((altnames-count (sk-general-name-num altnames)))
205                (loop for i from 0 below altnames-count
206                      as alt-name = (sk-general-name-value altnames i)
207                      collect (alt-name-to-string alt-name))))
208         (general-names-free altnames)))))
209 
210 (defun certificate-subject-common-names (cert)
211   (let ((i -1)
212         (subject-name (x509-get-subject-name cert)))
213     (when (cffi:null-pointer-p subject-name)
214       (error "X509_get_subject_name returned NULL"))
215     (flet ((extract-cn ()
216              (setf i (x509-name-get-index-by-nid subject-name +NID-commonName+ i))
217              (when (>= i 0)
218                (let* ((entry (x509-name-get-entry subject-name i)))
219                  (when (cffi:null-pointer-p entry)
220                    (error "X509_NAME_get_entry returned NULL"))
221                  (let ((entry-data (x509-name-entry-get-data entry)))
222                    (when (cffi:null-pointer-p entry-data)
223                      (error "X509_NAME_ENTRY_get_data returned NULL"))
224                    (try-get-asn1-string-data entry-data '(#.+v-asn1-utf8string+
225                                                           #.+v-asn1-bmpstring+
226                                                           #.+v-asn1-printablestring+
227                                                           #.+v-asn1-universalstring+
228                                                           #.+v-asn1-teletexstring+)))))))
229       (loop
230         as cn = (extract-cn)
231         if cn collect cn
232         if (not cn) do
233            (loop-finish)))))