cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit 9b173e2b93cc88b06b8fd7f29cd1655edc3df89f
parent 8d003f61b730453806db6149dce10700eae272f0
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun,  3 Aug 2014 20:53:14 +0200

der decoder added

Diffstat:
Mcl-rw.asd | 3++-
Ader.lisp | 218+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 220 insertions(+), 1 deletion(-)

diff --git a/cl-rw.asd b/cl-rw.asd @@ -51,4 +51,5 @@ (:file "calendar") (:file "ui") (:file "cas") - (:file "zip"))) + (:file "zip") + (:file "der"))) diff --git a/der.lisp b/der.lisp @@ -0,0 +1,218 @@ +;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com> +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(defpackage :rw.der + (:use :cl) + (:export :decode + :encode)) + +(in-package :rw.der) + +;; http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf +;; http://www.planetlarg.net/encyclopedia/ssl-secure-sockets-layer/der-distinguished-encoding-rules-certificate-encoding +;; ftp://ftp.rsasecurity.com/pub/pkcs/ascii/layman.asc +;; http://luca.ntop.org/Teaching/Appunti/asn1.html +;; http://tools.ietf.org/html/rfc5280 +;; http://www.ietf.org/rfc/rfc3280.txt +;; https://en.wikipedia.org/wiki/X.509 + +(defun octets-to-utf8-string (x) + #-(or sbcl) + (error "TODO port RW.DER::OCTETS-TO-UTF8-STRING") + #+sbcl + (sb-ext:octets-to-string x :external-format :utf-8)) + +(defun utf8-string-to-octets (x) + #-(or sbcl) + (error "TODO port RW.DER::UTF8-STRING-TO-OCTETS") + #+sbcl + (sb-ext:string-to-octets x :external-format :utf-8)) + +(defun decode (reader) + (labels ((len () + (let ((n (rw:next-u8 reader))) + (if (zerop (ldb (byte 8 7) n)) + n + (let ((z 0)) + (dotimes (i (logand #x7f n) z) + (setq z (logior (ash z 8) (rw:next-u8 reader)))))))) + (ascii () + (let* ((n (len)) + (z (make-string n))) + (dotimes (i n z) + (let ((c (rw:next-u8 reader))) + (assert (< 0 c #x80)) + (setf (char z i) (code-char c))))))) + (let ((tag (rw:next-u8 reader))) + ;;(print tag) + (ecase tag + ;; primitive + (1 ;; boolean + (assert (eql 1 (rw:next-u8 reader))) + (cons 'boolean (ecase (rw:next-u8 reader) (0 nil) (255 t)))) + (2 ;; integer + (let ((n (len))) + (assert (plusp n)) + (let* ((z (rw:next-u8 reader)) + (p (zerop (ldb (byte 8 7) z)))) + (dotimes (i (1- n)) + (setq z (logior (ash z 8) (rw:next-u8 reader)))) + (if p z (- z (expt 2 (* 8 n))))))) + (3 ;; bit_string + (let ((n (len))) + (assert (plusp n)) + (let ((m (rw:next-u8 reader)) + (z 0)) + ;; TODO as octet string? + (dotimes (i (1- n) (cons 'bit_string (ash z (- m)))) + (setq z (logior (ash z 8) (rw:next-u8 reader))))))) + (4 ;; octet_string + ;; TODO variant with bounds + #+nil + (let* ((n (len)) ;; TODO why like SEQ in certificates? + (r (rw:peek-reader (rw:shorter-reader reader n)))) + (loop + while (rw:peek r) + collect (decode r))) + ;;(decode (rw:shorter-reader reader (len))) + ;;#+nil + (let* ((n (len)) + (z (make-array n + :element-type '(unsigned-byte 8) + :initial-element 0))) + (dotimes (i n z) + (setf (aref z i) (rw:next-u8 reader))))) + (5 ;; null + (assert (eql 0 (rw:next-u8 reader)))) + (6 ;; object_identifier + (let (z (n (len))) + (assert (plusp n)) + (multiple-value-bind (d m) (floor (rw:next-u8 reader) 40) + (push d z) + (push m z)) + (decf n) + (loop + while (plusp n) + do (let (e (a 0)) + (loop + until (zerop (ldb (byte 8 7) + (setq e (rw:next-u8 reader)))) + do (progn + (decf n) + (setq a (logior (ash a 7) (logand #x7f e))))) + (decf n) + (push (logior (ash a 7) e) z))) + (cons 'oid (nreverse z)))) + (12 ;; UTF8String + (let* ((n (len)) + (z (make-array n + :element-type '(unsigned-byte 8) + :initial-element 0))) + (dotimes (i n (cons 'utf8string (octets-to-utf8-string z))) + (setf (aref z i) (rw:next-u8 reader))))) + (19 ;; printablestring + (cons 'printable_string (ascii))) + #+nil + (20 ;; t61string TeletexString #x14 + (let* ((n (rw:next-u8 reader)) + (z (make-string n))) + (dotimes (i n (cons 't61string z)) + (setf (char z i) (code-char (rw:next-u8 reader)))))) + (22 ;; ia5string + (cons 'ia5string (ascii))) + (23 ;; utctime + ;; YYMMDDhhmmZ + ;; YYMMDDhhmm+hh'mm' + ;; YYMMDDhhmm-hh'mm' + ;; YYMMDDhhmmssZ + ;; YYMMDDhhmmss+hh'mm' + ;; YYMMDDhhmmss-hh'mm' + (cons 'utctime (ascii))) + #+nil + (30 ;; BMPString #x1e + ) + ;; constructed + (48 ;; SEQUENCE #x30 + (loop + with r = (rw:peek-reader (rw:shorter-reader reader (len))) + while (rw:peek r) + collect (decode r))) + (49 ;; SET #x31 + (cons 'set (decode (rw:shorter-reader reader (len))))) + (80 + (cons '???-key-identifier + (decode (rw:shorter-reader reader (len))))) + (160 ;; ??? crl_extensions signed certificate version #xa0 + ;; (int inside) 2 = signed certificate v3 + (cons '???-signed-certificate-version + (decode (rw:shorter-reader reader (len))))) + (163 ;; ??? signed certificate extensions #xa3 + (cons '???-signed-certificate-extensions + (decode (rw:shorter-reader reader (len))))) + ;; ;;;;;;;;;; + #+nil + (128 + (cons '???-128 (decode (rw:shorter-reader reader (len))))) + )))) + +(let ((tests + '((nil (5 0)) + (0 (2 1 0)) + (127 (2 1 #x7f)) + (-128 (2 1 #x80)) + (-129 (2 2 #xff #x7f)) + (128 (2 2 0 #x80)) + (256 (2 2 1 0)) + ((utctime . "910506234540Z") + (#x17 #x0d #x39 #x31 #x30 #x35 #x30 #x36 #x32 #x33 #x34 #x35 #x34 #x30 + #x5a)) + ((utctime . "910506164540-0700") + (#x17 #x11 #x39 #x31 #x30 #x35 #x30 #x36 #x31 #x36 #x34 #x35 #x34 #x30 + #x2D #x30 #x37 #x30 #x30)) + ((ia5string . "test1@rsa.com") + (#x16 #x0d #x74 #x65 #x73 #x74 #x31 #x40 #x72 #x73 #x61 #x2e #x63 #x6f + #x6d)) + (#(1 #x23 #x45 #x67 #x89 #xab #xcd #xef) + (4 8 1 #x23 #x45 #x67 #x89 #xab #xcd #xef)) + ;;(#x1b977 . (3 4 6 #x6e #x5d #xc0)) + ;; ("cl'es publiques" + ;; (#x14 #x0f #x63 #x6c #xc2 #x65 #x73 #x20 #x70 #x75 #x62 #x6c #x69 #x71 + ;; #x75 #x65 #x73)) + ((oid 1 3 6 1 4 1 311 21 20) + (6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) + ((oid 1 2 840 113549 1 1 1) + (6 9 #x2a #x86 #x48 #x86 #xf7 #x0d 1 1 1)) + ((printable_string . "TestCN") + (#x13 6 #x54 #x65 #x73 #x74 #x43 #x4e)) + ((utf8string . "certreq") + (#x0c 7 #x63 #x65 #x72 #x74 #x72 #x65 #x71)) + ((-128 (oid 1 3 6 1 4 1 311 21 20)) + (48 14 2 1 #x80 6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) + ((set -128 (oid 1 3 6 1 4 1 311 21 20)) + (49 16 48 14 2 1 #x80 6 9 #x2b 6 1 4 1 #x82 #x37 #x15 #x14)) + ))) + (dolist (test tests t) + (assert (equalp (car test) (decode (rw:reader (cadr test))))))) + +;;(decode (rw:reader '(6 6 #x2a #x86 #x48 #x86 #xf7 #x0d))) +;;(decode (rw:reader '(3 4 6 #x6e #x5d #xc0))) ; '(:bit-string "011011100101110111") +;;(encode w '(:bit-string "011011100101110111")) ;; '(3 4 6 #x6e #x5d #xc0)