Author: ctian Date: Thu Sep 13 06:42:18 2007 New Revision: 33

Added: trunk/asn.1/ trunk/asn.1/ber.lisp trunk/asn.1/mib.lisp trunk/asn.1/package.lisp trunk/asn.1/stream-test.lisp Modified: trunk/net-snmp-dff.lisp trunk/net-snmp.asd Log: Add pure lisp ASN.1 support

Added: trunk/asn.1/ber.lisp ============================================================================== --- (empty file) +++ trunk/asn.1/ber.lisp Thu Sep 13 06:42:18 2007 @@ -0,0 +1,205 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; BER Base Support ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :asn.1) + +(let ((dispatch-table + (make-hash-table :test #'equal))) + (defun get-asn.1-type (class p/c tags) + (gethash (list class p/c tags) dispatch-table :unknown)) + (defun install-asn.1-type (type class p/c tags) + (setf (gethash (list class p/c tags) dispatch-table) type))) + +;;;; 8 7 6 5 4 3 2 1 +;;;; +-------+-----+-----------+ +;;;; | class | P/C | tags | +;;;; +-------+-----+-----------+ +;;;; ^ ^ +;;;; 00=universal 0=primitive +;;;; 01=app. 1=construct +;;;; 10=context. +;;;; 11=private +;;;; (type domain (tag = 0-30) + +;;;; |<-------head byte------->| |<---------------other bytes---------------->| +;;;; 1st byte last byte +;;;; |<------>| |<------>| +;;;; 8 7 6 5 4 3 2 1 +;;;; +-------+-----+-----------+ +---+----+ +---+----+ +---+----+ +---+----+ +;;;; | class | P/C | 1 1 1 1 1 | | 1 |////| | 1 |////|... | 1 |////| | 0 |////| +;;;; +-------+-----+-----------+ +---+----+ +---+----+ +---+----+ +---+----+ +;;;; +----+ +----+ +----+ +----+ +;;;; tags = |////| + |////|... + |////| + |////| +;;;; +----+ +----+ +----+ +----+ +;;;; (type domain (tag >= 31) + +(defun ber-encode-type (class p/c tags) + "Encode BER Type Domain" + (declare (type (integer 0 3) class) + (type (integer 0 1) p/c) + (type (integer 0) tags)) + (assert (and (<= 0 class 3) (<= 0 p/c 1) (<= 0 tags))) + (labels ((iter (n p acc) + (if (= n 0) acc + (multiple-value-bind (q r) (floor n 128) + (iter q 1 (cons (logior (ash p 7) r) acc)))))) + (if (< tags 31) + (list (logior (ash class 6) (ash p/c 5) tags)) + (cons (logior (ash class 6) (ash p/c 5) 31) + (iter tags 0 nil))))) + +(defun ber-decode-type (stream) + "Decode BER Type Domain" + (declare (type stream stream)) + (let ((byte (stream-read-byte stream)) + (type-length 1)) + (let ((class (ldb (byte 2 6) byte)) + (p/c (ldb (byte 1 5) byte)) + (tags (ldb (byte 5 0) byte))) + (when (= tags 31) + (setf tags (labels ((iter (acc) + (setf byte (stream-read-byte stream)) + (incf type-length) + (let ((temp (logior (ash acc 7) (ldb (byte 7 0) byte)))) + (if (= (ldb (byte 1 7) byte) 1) (iter temp) temp)))) + (iter 0)))) + (values (get-asn.1-type class p/c tags) + type-length)))) + +;;;; 8 7 6 5 4 3 2 1 +;;;; +---+-+-+-+-+-+-+-+ +;;;; | 0 | +;;;; +---+-+-+-+-+-+-+-+ +;;;; (short form: Length = 0-127 octets) + +;;;; 8 7 6 5 4 3 2 1 8 7 6 5 4 3 2 1 8 7 6 5 4 3 2 1 +;;;; +---+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +;;;; | 1 | | | ... | | +;;;; +---+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +;;;; |<--number--->| ^ ^ +;;;; of other byte 1: MSB byte n: MLB +;;;; bytes +;;;; (0<n<127) +;;;; (long form: Length = 0-(2^1008-1) octets) + +(defun ber-encode-length (length) + "Encode BER Length Domain" + (declare (type (integer 0) length)) + (assert (<= 0 length (1- (expt 2 1008)))) + (labels ((iter (n acc l) + (if (= n 0) (cons (mod (logior 128 l) 256) acc) + (multiple-value-bind (q r) (floor n 256) + (iter q (cons r acc) (1+ l)))))) + (if (< length 128) (list length) + (iter length nil 0)))) + +(defun ber-decode-length (stream) + "Decode BER Length Domain" + (declare (type stream stream)) + (let ((byte (stream-read-byte stream)) + (length-length 1)) + (let ((flag (ldb (byte 1 7) byte)) + (l-or-n (ldb (byte 7 0) byte))) + (let ((res (if (= flag 0) l-or-n + (let ((acc 0)) + (dotimes (i l-or-n) + (setf acc (logior (ash acc 8) + (stream-read-byte stream))) + (incf length-length) + acc))))) + (values res length-length))))) + +(defgeneric ber-encode (value)) + +(defun ber-decode (stream) + (declare (type stream stream)) + (let ((type (ber-decode-type stream)) + (length (ber-decode-length stream))) + (ber-decode-value stream type length))) + +(defgeneric ber-decode-value (stream type length)) + +(defmethod ber-decode-value ((stream stream) (type (eql :unknown)) (length integer)) + (declare (type stream stream) (ignore type)) + (dotimes (i length) + (stream-read-byte stream)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;; +;;;; Special Types ;;;; +;;;;;;;;;;;;;;;;;;;;;;; + +;;; Integer (:integer) + +(defmethod ber-encode ((value integer)) + (assert (<= 0 value)) + (labels ((iter (n acc l) + (if (= n 0) (values acc l) + (multiple-value-bind (q r) (floor n 256) + (iter q (cons r acc) (1+ l)))))) + (multiple-value-bind (v l) (iter value nil 0) + (nconc (ber-encode-type 0 0 2) + (ber-encode-length l) + v)))) + +(defmethod ber-decode-value ((stream stream) (type (eql :integer)) (length integer)) + (declare (type stream stream) (ignore type)) + (labels ((iter (i acc) + (if (= i length) acc + (iter (1+ i) (logior (ash acc 8) (stream-read-byte stream)))))) + (iter 0 0))) + +;;; OCTET STRING (:octet-string) + +(defmethod ber-encode ((value simple-base-string)) + (nconc (ber-encode-type 0 0 4) + (ber-encode-length (length value)) + (map 'list #'char-code value))) + +(defmethod ber-decode-value ((stream stream) (type (eql :octet-string)) (length integer)) + (declare (type stream stream) (ignore type)) + (let ((str (make-string length))) + (map-into str #'(lambda () (code-char (stream-read-byte stream)))))) + +;;; SEQUENCE (:sequence) + +(defmethod ber-encode ((value sequence)) + (let ((sub-encode (apply #'nconc + (map 'list #'ber-encode value)))) + (nconc (ber-encode-type 0 1 16) + (ber-encode-length (length sub-encode)) + sub-encode))) + +(defmethod ber-decode-value ((stream stream) (type (eql :sequence)) (length integer)) + (declare (type stream stream) (ignore type)) + (labels ((iter (left acc) + (if (= left 0) + (nreverse acc) + (multiple-value-bind (sub-type sub-type-length) + (ber-decode-type stream) + (multiple-value-bind (sub-length sub-length-length) + (ber-decode-length stream) + (iter (- left + sub-type-length + sub-length-length + sub-length) + (cons (ber-decode-value stream sub-type sub-length) acc))))))) + (iter length nil))) + +;;; NULL (:null) +(defmethod ber-encode ((value (eql nil))) + (declare (ignore value)) + (nconc (ber-encode-type 0 0 5) + (ber-encode-length 0))) + +(defmethod ber-decode-value ((stream stream) (type (eql :null)) (length integer)) + (declare (type stream stream)) + (assert (= length 0)) + nil) + +(eval-when (:load-toplevel :execute) + (install-asn.1-type :integer 0 0 2) + (install-asn.1-type :octet-string 0 0 4) + (install-asn.1-type :null 0 0 5) + (install-asn.1-type :sequence 0 1 16))

Added: trunk/asn.1/mib.lisp ============================================================================== --- (empty file) +++ trunk/asn.1/mib.lisp Thu Sep 13 06:42:18 2007 @@ -0,0 +1,6 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; MIB Base Support ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :asn.1) +

Added: trunk/asn.1/package.lisp ============================================================================== --- (empty file) +++ trunk/asn.1/package.lisp Thu Sep 13 06:42:18 2007 @@ -0,0 +1,7 @@ +(in-package :cl-user) + +(defpackage :asn.1 + (:use :common-lisp + #+lispworks :stream)) + +(in-package :asn.1)

Added: trunk/asn.1/stream-test.lisp ============================================================================== --- (empty file) +++ trunk/asn.1/stream-test.lisp Thu Sep 13 06:42:18 2007 @@ -0,0 +1,17 @@ +(in-package :asn.1) + +(defclass ber-stream (fundamental-input-stream) + ((sequence :type sequence :initarg :seq :reader ber-sequence) + (length :type integer :accessor ber-length) + (position :type integer :initform 0 :accessor ber-position))) + +(defmethod shared-initialize :after ((instance ber-stream) slot-names &rest initargs) + (declare (ignore slot-names initargs)) + (setf (ber-length instance) (length (ber-sequence instance)))) + +(defmethod stream-read-byte ((instance ber-stream)) + (if (= (ber-position instance) (ber-length instance)) + :eof + (let ((byte (elt (ber-sequence instance) (ber-position instance)))) + (incf (ber-position instance)) + byte)))

Modified: trunk/net-snmp-dff.lisp ============================================================================== --- trunk/net-snmp-dff.lisp (original) +++ trunk/net-snmp-dff.lisp Thu Sep 13 06:42:18 2007 @@ -267,4 +267,4 @@ :result-type :int :language - :ansi-c) \ No newline at end of file + :ansi-c)

Modified: trunk/net-snmp.asd ============================================================================== --- trunk/net-snmp.asd (original) +++ trunk/net-snmp.asd Thu Sep 13 06:42:18 2007 @@ -2,18 +2,20 @@

(in-package :cl-user)

-(defpackage :net-snmp-system - (:use :cl :asdf)) - +(defpackage net-snmp-system (:use :common-lisp :asdf)) (in-package :net-snmp-system)

(defsystem net-snmp :description "Common Lisp interface for Net-SNMP" :version "0.6" :author "Chun Tian (binghe) binghe.lisp@gmail.com" - :depends-on (:cffi) - :components ((:file "package") - (:file "constants" :depends-on ("package")) + :depends-on (:cffi + :ironclad + :net-telent-date) + :components ((:module asn.1 :components ((:file "package") + (:file "ber" :depends-on ("package")))) + (:file "package") + (:file "constants" :depends-on ("package")) (:file "typedefs" :depends-on ("constants")) (:file "snmp-api" :depends-on ("typedefs")) (:file "load" :depends-on ("snmp-api")) @@ -26,7 +28,6 @@ :version "0.1" :author "Chun Tian (binghe) binghe.lisp@gmail.com" :depends-on (:net-snmp - :net-telent-date :hunchentoot :clsql-postgresql) :components ((:file "sabrina")