der.lisp (20114B)
1 ;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.der 24 (:use :cl) 25 (:export :der 26 :next-der 27 :write-der)) 28 29 (in-package :rw.der) 30 31 ;; http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf 32 ;; http://www.planetlarg.net/encyclopedia/ssl-secure-sockets-layer/der-distinguished-encoding-rules-certificate-encoding 33 ;; ftp://ftp.rsasecurity.com/pub/pkcs/ascii/layman.asc 34 ;; http://luca.ntop.org/Teaching/Appunti/asn1.html 35 ;; http://tools.ietf.org/html/rfc5280 36 ;; http://www.ietf.org/rfc/rfc3280.txt 37 ;; https://en.wikipedia.org/wiki/X.509 38 ;; https://www.sslshopper.com/ssl-converter.html 39 ;; http://how2ssl.com/articles/working_with_pem_files/ 40 ;; https://www.novell.com/support/kb/doc.php?id=7013103 41 ;; http://www.herongyang.com/Cryptography/Certificate-Format-PEM-on-Certificates.html 42 ;; http://serverfault.com/questions/9708/what-is-a-pem-file-and-how-does-it-differ-from-other-openssl-generated-key-file 43 44 (defun next-der (reader) 45 (labels ((len () 46 (let ((n (rw:next-u8 reader))) 47 (if (logbitp 7 n) 48 (let ((z 0)) 49 (dotimes (i (logand #x7f n) z) 50 (setq z (logior (ash z 8) (rw:next-u8 reader))))) 51 n))) 52 (ascii () 53 (let* ((n (len)) 54 (z (make-string n))) 55 (dotimes (i n z) 56 (let ((c (rw:next-u8 reader))) 57 (assert (< 0 c #x80)) 58 (setf (char z i) (code-char c))))))) 59 (let ((tag (rw:next-u8 reader))) 60 ;;(print tag) 61 (ecase tag 62 ;; primitive 63 (1 ;; boolean 64 (assert (eql 1 (rw:next-u8 reader))) 65 (list 'boolean (ecase (rw:next-u8 reader) (0 nil) (255 t)))) 66 (2 ;; integer 67 (let ((n (len))) 68 (assert (plusp n)) 69 (let* ((z (rw:next-u8 reader)) 70 (p (logbitp 7 z))) 71 (dotimes (i (1- n)) 72 (setq z (logior (ash z 8) (rw:next-u8 reader)))) 73 (if p (- z (expt 2 (* 8 n))) z)))) 74 (3 ;; bit-string 75 (let ((n (len))) 76 (assert (plusp n)) 77 (let ((m (rw:next-u8 reader)) 78 (z 0)) 79 ;; TODO as octet string? 80 (dotimes (i (1- n) (list 'bit-string m (ash z (- m)))) 81 (setq z (logior (ash z 8) (rw:next-u8 reader))))))) 82 (4 ;; octet-string 83 ;; TODO variant with bounds 84 #+nil 85 (let* ((n (len)) ;; TODO why like SEQ in certificates? 86 (r (rw:peek-reader (rw:shorter-reader reader n)))) 87 (loop 88 while (rw:peek r) 89 collect (next-der r))) 90 ;;(next-der (rw:shorter-reader reader (len))) 91 ;;#+nil 92 (let* ((n (len)) 93 (z (make-array n 94 :element-type '(unsigned-byte 8) 95 :initial-element 0))) 96 (dotimes (i n z) 97 (setf (aref z i) (rw:next-u8 reader))))) 98 (5 ;; null 99 (assert (eql 0 (rw:next-u8 reader)))) 100 (6 ;; oid 101 (let (z (n (len))) 102 (assert (plusp n)) 103 (multiple-value-bind (d m) (floor (rw:next-u8 reader) 40) 104 (push d z) 105 (push m z)) 106 (decf n) 107 (loop 108 while (plusp n) 109 do (let (e (a 0)) 110 (loop 111 while (logbitp 7 (setq e (rw:next-u8 reader))) 112 do (progn 113 (decf n) 114 (setq a (logior (ash a 7) (logand #x7f e))))) 115 (decf n) 116 (push (logior (ash a 7) e) z))) 117 (cons 'oid (nreverse z)))) 118 (12 ;; UTF8String 119 (let* ((n (len)) 120 (z (make-array n 121 :element-type '(unsigned-byte 8) 122 :initial-element 0))) 123 (dotimes (i n (list 'utf8string (rw.string:octets-to-string z :utf-8))) 124 (setf (aref z i) (rw:next-u8 reader))))) 125 (19 ;; printablestring 126 (list 'printable-string (ascii))) 127 #+nil 128 (20 ;; t61string TeletexString #x14 129 (let* ((n (rw:next-u8 reader)) 130 (z (make-string n))) 131 (dotimes (i n (list 't61string z)) 132 (setf (char z i) (code-char (rw:next-u8 reader)))))) 133 (22 ;; ia5string 134 (list 'ia5string (ascii))) 135 (23 ;; utctime 136 ;; YYMMDDhhmmZ 137 ;; YYMMDDhhmm+hh'mm' 138 ;; YYMMDDhhmm-hh'mm' 139 ;; YYMMDDhhmmssZ 140 ;; YYMMDDhhmmss+hh'mm' 141 ;; YYMMDDhhmmss-hh'mm' 142 (list 'utctime (ascii))) 143 #+nil 144 (30 ;; BMPString #x1e 145 ) 146 ;; constructed 147 (48 ;; SEQUENCE #x30 148 (loop 149 with r = (rw:peek-reader (rw:shorter-reader reader (len))) 150 while (rw:peek r) 151 collect (next-der r))) 152 (49 ;; SET #x31 153 (cons 'set (next-der (rw:shorter-reader reader (len))))) 154 (80 155 (list '???-key-identifier 156 (next-der (rw:shorter-reader reader (len))))) 157 (160 ;; ??? crl-extensions signed certificate version #xa0 158 ;; (int inside) 2 = signed certificate v3 159 (list '???-signed-certificate-version 160 (next-der (rw:shorter-reader reader (len))))) 161 (163 ;; ??? signed certificate extensions #xa3 162 (list '???-signed-certificate-extensions 163 (next-der (rw:shorter-reader reader (len))))) 164 ;; ;;;;;;;;;; 165 #+nil 166 (128 167 (cons '???-128 (next-der (rw:shorter-reader reader (len))))) 168 )))) 169 170 (defun write-der (writer x) 171 (labels ((len (n) 172 (assert (<= 0 n)) 173 (if (< n #x80) 174 (rw:write-u8 writer n) 175 (let ((nn (ceiling (integer-length n) 8))) 176 (assert (<= 1 nn #x7f)) 177 (rw:write-u8 writer (logior #x80 nn)) 178 (loop 179 for i from (1- nn) downto 0 180 do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) n)))))) 181 (ascii (x) 182 (len (length x)) 183 (loop 184 for x across x 185 do (let ((c (char-code x))) 186 (assert (< 0 c #x80)) 187 (rw:write-u8 writer c)))) 188 (seq (x) 189 (let* ((b (make-array 42 :fill-pointer 0 :adjustable t)) 190 (w (rw:writer b))) 191 (dolist (x x) 192 (write-der w x)) 193 (len (length b)) 194 (loop 195 for x across b 196 do (rw:write-u8 writer x))))) 197 (etypecase x 198 (null 199 (rw:write-u8 writer 5) 200 (rw:write-u8 writer 0)) 201 (integer 202 (rw:write-u8 writer 2) 203 (cond 204 ((zerop x) 205 (rw:write-u8 writer 1) 206 (rw:write-u8 writer 0)) 207 (t 208 (let ((nbytes (ceiling (1+ (integer-length x)) 8))) 209 (len nbytes) 210 (loop 211 for i from (1- nbytes) downto 0 212 do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) x))))))) 213 (vector ;; octet-string 214 (rw:write-u8 writer 4) 215 (len (length x)) 216 (loop 217 for x across x 218 do (rw:write-u8 writer x))) 219 (cons 220 (case (car x) 221 (boolean 222 (rw:write-u8 writer 1) 223 (rw:write-u8 writer 1) 224 (rw:write-u8 writer (if (cadr x) 255 0))) 225 (bit-string 226 (rw:write-u8 writer 3) 227 (let* ((m (cadr x)) 228 (x (ash (caddr x) m)) 229 (nbytes (ceiling (integer-length x) 8))) 230 (len (+ 1 nbytes)) 231 (rw:write-u8 writer m) 232 (loop 233 for i from (1- nbytes) downto 0 234 do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) x))))) 235 (oid 236 (rw:write-u8 writer 6) 237 (let* ((b (make-array 42 :fill-pointer 0 :adjustable t)) 238 (w (rw:writer b))) 239 (let ((x (cdr x))) 240 (rw:write-u8 w (+ (* 40 (pop x)) (pop x))) 241 (dolist (x x) 242 (let (z) 243 (do ((x x (ash x -7))) 244 ((< x #x80) 245 (push x z)) 246 (push (logand #x7f x) z)) 247 (do () 248 ((not (cdr z)) 249 (rw:write-u8 w (car z))) 250 (rw:write-u8 w (logior #x80 (pop z))))))) 251 (len (length b)) 252 (loop 253 for x across b 254 do (rw:write-u8 writer x)))) 255 (utf8string 256 (rw:write-u8 writer 12) 257 (let ((x (rw.string:string-to-octets (cadr x) :utf-8))) 258 (len (length x)) 259 (loop 260 for x across x 261 do (rw:write-u8 writer x)))) 262 ;;(sequence 16) 263 ;;(set 17) 264 (printable-string 265 (rw:write-u8 writer 19) 266 (ascii (cadr x))) 267 ;;(t61string 20) 268 (ia5string 269 (rw:write-u8 writer 22) 270 (ascii (cadr x))) 271 (utctime 272 (rw:write-u8 writer 23) 273 (ascii (cadr x))) 274 (set 275 (rw:write-u8 writer 49) 276 (seq (list (cdr x)))) 277 (???-key-identifier 278 (rw:write-u8 writer 80) 279 (seq (list (cadr x)))) 280 (???-signed-certificate-version 281 (rw:write-u8 writer 160) 282 ;; (int inside) 2 = signed certificate v3 283 (seq (list (cadr x)))) 284 (???-signed-certificate-extensions 285 (rw:write-u8 writer 163) 286 (seq (list (cadr x)))) 287 (t ;; sequence 288 (rw:write-u8 writer 48) 289 (seq x))))))) 290 291 (let ((tests 292 '((nil (5 0)) 293 (0 (2 1 0)) 294 (127 (2 1 #x7f)) 295 (-128 (2 1 #x80)) 296 (-129 (2 2 #xff #x7f)) 297 (128 (2 2 0 #x80)) 298 (256 (2 2 1 0)) 299 ((utctime "910506234540Z") 300 (#x17 #x0d #x39 #x31 #x30 #x35 #x30 #x36 #x32 #x33 #x34 #x35 #x34 #x30 301 #x5a)) 302 ((utctime "910506164540-0700") 303 (#x17 #x11 #x39 #x31 #x30 #x35 #x30 #x36 #x31 #x36 #x34 #x35 #x34 #x30 304 #x2D #x30 #x37 #x30 #x30)) 305 ((ia5string "test1@rsa.com") 306 (#x16 #x0d #x74 #x65 #x73 #x74 #x31 #x40 #x72 #x73 #x61 #x2e #x63 #x6f 307 #x6d)) 308 (#(1 #x23 #x45 #x67 #x89 #xab #xcd #xef) 309 (4 8 1 #x23 #x45 #x67 #x89 #xab #xcd #xef)) 310 ;;(#x1b977 (3 4 6 #x6e #x5d #xc0)) 311 ;; ("cl'es publiques" 312 ;; (#x14 #x0f #x63 #x6c #xc2 #x65 #x73 #x20 #x70 #x75 #x62 #x6c #x69 #x71 313 ;; #x75 #x65 #x73)) 314 ((oid 1 3 6 1 4 1 311 21 20) 315 (6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) 316 ((oid 1 2 840 113549 1 1 1) 317 (6 9 #x2a #x86 #x48 #x86 #xf7 #x0d 1 1 1)) 318 ((printable-string "TestCN") 319 (#x13 6 #x54 #x65 #x73 #x74 #x43 #x4e)) 320 ((utf8string "certreq") 321 (#x0c 7 #x63 #x65 #x72 #x74 #x72 #x65 #x71)) 322 ((-128 (oid 1 3 6 1 4 1 311 21 20)) 323 (48 14 2 1 #x80 6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) 324 ((set -128 (oid 1 3 6 1 4 1 311 21 20)) 325 (49 16 48 14 2 1 #x80 6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) 326 ((bit-string 7 #x12345) 327 (3 4 7 145 162 128)) 328 ((bit-string 0 2698675166254423367516254728464483749335066557673396396108386839514779489334034500324580997831747386071008453389756292324108345979589057920899409611221513386337727594567671688384339497590058060942411175326729608798043193698773547875145474433044091370658538092792546412868245105307028798977746453087673869761039285801616342559358044930049) 329 (3 129 141 0 330 48 129 137 2 129 129 0 190 108 252 172 88 61 44 244 2 196 54 234 121 210 331 210 109 187 113 178 18 221 62 24 169 233 140 184 208 68 149 157 121 142 332 197 120 199 45 11 143 102 161 53 203 99 66 68 198 7 185 44 217 3 172 75 333 207 70 140 178 29 180 232 112 37 121 95 238 135 94 47 141 217 157 50 42 334 42 90 233 119 5 180 145 138 55 114 178 56 28 117 191 40 208 75 167 181 335 49 36 201 14 178 137 153 55 95 175 220 201 180 9 124 38 129 234 159 152 336 83 53 138 75 187 159 227 220 197 148 150 3 101 147 2 3 1 0 1)) 337 ((bit-string 0 118034060124092381042289152588939068226888691459037221227696280629223206095830260576779540892200452501272518674360944045140270719338674600852168851119591300542021466662967353378826595297215969104790405581663753704791058639429297119582166792869070820194273847407288579294634063908956456813605370210920536000302) 338 (3 129 129 0 339 168 22 9 103 226 192 63 113 163 84 253 199 177 202 0 36 253 22 43 188 340 146 85 229 191 251 36 223 176 216 103 195 166 18 84 153 187 248 65 159 341 135 222 114 80 11 75 66 62 112 10 212 26 56 102 149 163 50 50 221 21 87 342 226 208 93 252 194 170 148 181 129 151 70 81 62 179 99 53 164 235 3 196 343 252 10 68 125 227 216 117 185 44 34 62 227 205 92 244 197 25 251 123 126 344 128 169 217 173 8 16 188 13 240 145 107 68 240 135 130 38 22 15 237 227 345 161 152 2 127 171 248 199 46))))) 346 (dolist (test tests t) 347 ;; (print (list :@@@ test)) 348 ;; (finish-output) 349 (assert (equalp (car test) (next-der (rw:reader (cadr test))))) 350 (assert (equalp (cadr test) 351 (let ((b (make-array 42 :fill-pointer 0 :adjustable t))) 352 (write-der (rw:writer b) (car test)) 353 (coerce b 'list)))))) 354 355 ;;(next-der (rw:reader '(6 6 #x2a #x86 #x48 #x86 #xf7 #x0d))) 356 ;;(next-der (rw:reader '(3 4 6 #x6e #x5d #xc0))) ; '(:bit-string "011011100101110111") 357 ;;(write-der w '(bit-string "011011100101110111")) ;; '(3 4 6 #x6e #x5d #xc0) 358 359 ;; http://serverfault.com/questions/9708/what-is-a-pem-file-and-how-does-it-differ-from-other-openssl-generated-key-file 360 361 (defun read-pem-key (reader) 362 (let ((x (rw:till reader '(#\return #\newline)))) 363 (rw:skip reader) 364 (cond 365 ;; -----BEGIN PRIVATE KEY----- 366 ((equal x 367 '(#\- #\- #\- #\- #\- 368 #\B #\E #\G #\I #\N #\space 369 #\P #\R #\I #\V #\A #\T #\E #\space 370 #\K #\E #\Y 371 #\- #\- #\- #\- #\-)) 372 (prog1 (list 'private-key (next-der (rw.base64:decode-reader reader))) 373 ;;(rw:till (rw:peek-reader (rw.base64:decode-reader reader))) 374 (rw:skip reader) 375 (assert 376 (equal '(#\- #\- #\- #\- #\- 377 #\E #\N #\D #\space 378 #\P #\R #\I #\V #\A #\T #\E #\space 379 #\K #\E #\Y 380 #\- #\- #\- #\- #\-) 381 (rw:till reader '(#\return #\newline)))))) 382 ;; -----BEGIN CERTIFICATE----- 383 ((equal x 384 '(#\- #\- #\- #\- #\- 385 #\B #\E #\G #\I #\N #\space 386 #\C #\E #\R #\T #\I #\F #\I #\C #\A #\T #\E 387 #\- #\- #\- #\- #\-)) 388 (prog1 (list 'certificate (next-der (rw.base64:decode-reader reader))) 389 ;;(rw:till (rw:peek-reader (rw.base64:decode-reader reader))) 390 (rw:skip reader) 391 (assert 392 (equal '(#\- #\- #\- #\- #\- 393 #\E #\N #\D #\space 394 #\C #\E #\R #\T #\I #\F #\I #\C #\A #\T #\E 395 #\- #\- #\- #\- #\-) 396 (rw:till reader '(#\return #\newline)))))) 397 (t 398 (error "unexpected pem delimiter ~{~a~}" x))))) 399 400 (defun read-pem-file (pathname) 401 (with-open-file (s pathname) 402 (let ((r (rw:peek-reader (rw:char-reader s)))) 403 (loop 404 while (progn (rw:skip r) (rw:peek r)) 405 collect (read-pem-key r))))) 406 407 ;;(read-pem-file "~/sw/gvfs/test/files/testcert.pem") 408 ;;(read-pem-file "/tmp/a.pem") 409 ;;(read-pem-file "/tmp/b.pem") 410 ;;openssl x509 -in ~/sw/gvfs/test/files/testcert.pem -noout -text 411 412 (defun wrap-line-writer (writer columns) 413 (let ((n 0)) 414 (lambda (x) 415 (if (<= (incf n) columns) 416 (funcall writer x) 417 (progn 418 (setq n 0) 419 (funcall writer #\newline)))))) 420 421 (defun wrap-line-reader (reader columns) 422 (let ((n 0)) 423 (lambda () 424 (cond 425 ((<= (incf n) columns) 426 (rw:next reader)) 427 (t 428 (setq n 0) 429 #\newline))))) 430 431 ;; TODO write pem, wrap-line-writer 64 (76 normal) 432 433 (defun decode-reader (reader) 434 (lambda () 435 (next-der reader))) 436 437 (defun encode-writer (writer) 438 (lambda (x) 439 (write-der writer x))) 440 441 (defun encode-reader (reader &optional buffer) 442 (let* (done 443 (n 0) 444 (b (or buffer 445 (make-array 42 :fill-pointer 0 :adjustable t))) 446 (w (rw:writer b))) 447 (lambda () 448 (unless done 449 (if (< n (length b)) 450 (prog1 (aref b n) 451 (incf n)) 452 (let ((x (rw:next reader))) 453 (cond 454 (x 455 (setq n 0) 456 (setf (fill-pointer b) 0) 457 (write-der w x) 458 ;;(print b) 459 (prog1 (aref b n) 460 (incf n))) 461 (t 462 (setq done t) 463 nil)))))))) 464 465 (defun write-pem-key (writer x) 466 (destructuring-bind (tag &rest data) x 467 (rw:copy (rw:reader (ecase tag 468 (private-key "-----BEGIN PRIVATE KEY-----") 469 (certificate "-----BEGIN CERTIFICATE-----"))) 470 writer) 471 (funcall writer #\newline) 472 (rw:copy (wrap-line-reader 473 (rw.base64:encode-reader 474 (rw:peek-reader (encode-reader (rw:reader (list data))))) 475 64) 476 writer) 477 #+nil 478 (rw:copy (rw.base64:encode-reader 479 (rw:peek-reader (encode-reader (rw:reader x)))) 480 (wrap-line-writer (rw:char-writer s) 64)) 481 (funcall writer #\newline) 482 (rw:copy (rw:reader (ecase tag 483 (private-key "-----END PRIVATE KEY-----") 484 (certificate "-----END CERTIFICATE-----"))) 485 writer) 486 (funcall writer #\newline))) 487 488 (defun write-pem-file (keys pathname &key if-does-not-exist if-exists) 489 (with-open-file (s pathname 490 :direction :output 491 :if-does-not-exist if-does-not-exist 492 :if-exists if-exists) 493 (dolist (x keys) 494 (write-pem-key (rw:char-writer s) x)))) 495 496 ;; diff -du ~/sw/gvfs/test/files/testcert.pem /tmp/b.pem 497 #+nil 498 (write-pem-file (read-pem-file "~/sw/gvfs/test/files/testcert.pem") 499 "/tmp/b.pem" 500 :if-does-not-exist :create 501 :if-exists :supersede) 502 503 ;;(print (read-pem-file "~/sw/gvfs/test/files/testcert.pem")) 504 ;;(print (read-pem-file "/tmp/b.pem")) 505 ;;(equalp (read-pem-file "~/sw/gvfs/test/files/testcert.pem") (read-pem-file "/tmp/b.pem")) 506 507 ;;(mapc 'read-pem-file (directory "/home/tomas/**/*.pem")) 508 509 ;; TODO some crt binary, some PEM 510 #+nil 511 (with-open-file (s "/usr/share/doc/dirmngr/examples/extra-certs/S-TRUSTQualSigOCSP2008-022.final.v3.509.crt" 512 :element-type '(unsigned-byte 8)) 513 (next-der (rw:byte-reader s)))