commit b6e4b6fc6594ab42430accb7c253a2bba18e6da2
parent f06a3a498093255a94ffa6adefa6023ef58a66d6
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 30 Aug 2014 14:54:03 +0200
der encoder implemented
Diffstat:
| M | der.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")
