cl-rw

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

commit b6e4b6fc6594ab42430accb7c253a2bba18e6da2
parent f06a3a498093255a94ffa6adefa6023ef58a66d6
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat, 30 Aug 2014 14:54:03 +0200

der encoder implemented

Diffstat:
Mder.lisp | 152+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
1 file changed, 137 insertions(+), 15 deletions(-)

diff --git a/der.lisp b/der.lisp @@ -50,11 +50,11 @@ (defun decode (reader) (labels ((len () (let ((n (rw:next-u8 reader))) - (if (zerop (ldb (byte 8 7) n)) - n + (if (logbitp 7 n) (let ((z 0)) (dotimes (i (logand #x7f n) z) - (setq z (logior (ash z 8) (rw:next-u8 reader)))))))) + (setq z (logior (ash z 8) (rw:next-u8 reader))))) + n))) (ascii () (let* ((n (len)) (z (make-string n))) @@ -73,19 +73,19 @@ (let ((n (len))) (assert (plusp n)) (let* ((z (rw:next-u8 reader)) - (p (zerop (ldb (byte 8 7) z)))) + (p (logbitp 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 + (if p (- z (expt 2 (* 8 n))) z)))) + (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)))) + (dotimes (i (1- n) (cons 'bit-string (ash z (- m)))) (setq z (logior (ash z 8) (rw:next-u8 reader))))))) - (4 ;; octet_string + (4 ;; octet-string ;; TODO variant with bounds #+nil (let* ((n (len)) ;; TODO why like SEQ in certificates? @@ -103,7 +103,7 @@ (setf (aref z i) (rw:next-u8 reader))))) (5 ;; null (assert (eql 0 (rw:next-u8 reader)))) - (6 ;; object_identifier + (6 ;; oid (let (z (n (len))) (assert (plusp n)) (multiple-value-bind (d m) (floor (rw:next-u8 reader) 40) @@ -114,8 +114,7 @@ while (plusp n) do (let (e (a 0)) (loop - until (zerop (ldb (byte 8 7) - (setq e (rw:next-u8 reader)))) + while (logbitp 7 (setq e (rw:next-u8 reader))) do (progn (decf n) (setq a (logior (ash a 7) (logand #x7f e))))) @@ -130,7 +129,7 @@ (dotimes (i n (cons 'utf8string (octets-to-utf8-string z))) (setf (aref z i) (rw:next-u8 reader))))) (19 ;; printablestring - (cons 'printable_string (ascii))) + (cons 'printable-string (ascii))) #+nil (20 ;; t61string TeletexString #x14 (let* ((n (rw:next-u8 reader)) @@ -161,7 +160,7 @@ (80 (cons '???-key-identifier (decode (rw:shorter-reader reader (len))))) - (160 ;; ??? crl_extensions signed certificate version #xa0 + (160 ;; ??? crl-extensions signed certificate version #xa0 ;; (int inside) 2 = signed certificate v3 (cons '???-signed-certificate-version (decode (rw:shorter-reader reader (len))))) @@ -174,6 +173,123 @@ (cons '???-128 (decode (rw:shorter-reader reader (len))))) )))) +(defun encode (writer x) + (labels ((len (n) + (assert (<= 0 n)) + (if (logbitp 7 n) + (let ((nn (ceiling (log n 256)))) + (assert (<= nn #x7f)) + (rw:write-u8 writer (logior #x80 nn)) + (loop + for i from (1- nn) downto 0 + do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) n)))) + (rw:write-u8 writer n))) + (ascii (x) + (len (length x)) + (loop + for x across x + do (let ((c (char-code x))) + (assert (< 0 c #x80)) + (rw:write-u8 writer c)))) + (seq (x) + (let* ((b (make-array 42 :fill-pointer 0 :adjustable t)) + (w (rw:writer b))) + (dolist (x x) + (encode w x)) + (len (length b)) + (loop + for x across b + do (rw:write-u8 writer x))))) + (etypecase x + (null + (rw:write-u8 writer 5) + (rw:write-u8 writer 0)) + (integer + (rw:write-u8 writer 2) + (cond + ((zerop x) + (rw:write-u8 writer 1) + (rw:write-u8 writer 0)) + ((plusp x) + (let* ((nbits (floor (+ 2 (log x 2)))) + (nbytes (ceiling nbits 8))) + (len nbytes) + (loop + for i from (1- nbytes) downto 0 + do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) x))))) + (t ;; minusp + (let* ((y (- x)) + (nbits (ceiling (+ 1 (log y 2)))) + (nbytes (ceiling nbits 8))) + (len nbytes) + (loop + for i from (1- nbytes) downto 0 + do (rw:write-u8 writer (ldb (byte 8 (* 8 i)) x))))))) + (vector ;; octet-string + (rw:write-u8 writer 4) + (len (length x)) + (loop + for x across x + do (rw:write-u8 writer x))) + (cons + (case (car x) + (boolean + (rw:write-u8 writer 1) + (rw:write-u8 writer 1) + (rw:write-u8 writer (if (cdr x) 255 0))) + ;;(bit-string 3) + (oid + (rw:write-u8 writer 6) + (let* ((b (make-array 42 :fill-pointer 0 :adjustable t)) + (w (rw:writer b))) + (let ((x (cdr x))) + (rw:write-u8 w (+ (* 40 (pop x)) (pop x))) + (dolist (x x) + (let (z) + (do ((x x (ash x -7))) + ((< x #x80) + (push x z)) + (push (logand #x7f x) z)) + (do () + ((not (cdr z)) + (rw:write-u8 w (car z))) + (rw:write-u8 w (logior #x80 (pop z))))))) + (len (length b)) + (loop + for x across b + do (rw:write-u8 writer x)))) + (utf8string + (rw:write-u8 writer 12) + (let ((x (utf8-string-to-octets (cdr x)))) + (len (length x)) + (loop + for x across x + do (rw:write-u8 writer x)))) + ;;(sequence 16) + ;;(set 17) + (printable-string + (rw:write-u8 writer 19) + (ascii (cdr x))) + ;;(t61string 20) + (ia5string + (rw:write-u8 writer 22) + (ascii (cdr x))) + (utctime + (rw:write-u8 writer 23) + (ascii (cdr x))) + (set + (rw:write-u8 writer 49) + (let* ((b (make-array 42 :fill-pointer 0 :adjustable t)) + (w (rw:writer b))) + (encode w (cdr x)) + (len (length b)) + (loop + for x across b + do (rw:write-u8 writer x)))) + (t ;; sequence + (rw:write-u8 writer 48) + (seq x))))))) + (let ((tests '((nil (5 0)) (0 (2 1 0)) @@ -201,7 +317,7 @@ (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") + ((printable-string . "TestCN") (#x13 6 #x54 #x65 #x73 #x74 #x43 #x4e)) ((utf8string . "certreq") (#x0c 7 #x63 #x65 #x72 #x74 #x72 #x65 #x71)) @@ -211,7 +327,13 @@ (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))))))) + ;; (print (list :@@@ test)) + ;; (finish-output) + (assert (equalp (car test) (decode (rw:reader (cadr test))))) + (assert (equalp (cadr test) + (let ((b (make-array 42 :fill-pointer 0 :adjustable t))) + (encode (rw:writer b) (car test)) + (coerce b 'list)))))) ;;(decode (rw:reader '(6 6 #x2a #x86 #x48 #x86 #xf7 #x0d))) ;;(decode (rw:reader '(3 4 6 #x6e #x5d #xc0))) ; '(:bit-string "011011100101110111")