/[snmp1]/snmp1/ber.lisp
ViewVC logotype

Contents of /snmp1/ber.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Mar 23 21:17:19 2007 UTC (7 years, 1 month ago) by jriise
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +9 -18 lines
Changed license from GPL to LLGPL
1 ;; SNMP1 - Simple Network Management Protocol for Common Lisp
2
3 ;; This software is Copyright (c) Johan Ur Riise 2007
4 ;; Johan Ur Riise grants you the rights to distribute
5 ;; and use this software as governed by the terms
6 ;; of the Lisp Lesser GNU Public License
7 ;; (http://opensource.franz.com/preamble.html),
8 ;; known as the LLGPL.
9
10 (in-package "SNMP1")
11
12 (defun oid-string-to-oid (oid-string)
13 "Convert string in form .1.3.5.6.7.333.233 to oid #(1 3 5 6 7 333 233)"
14 (let ((result (make-array 0 :fill-pointer 0)))
15 (loop for subidentifier in (split-sequence:split-sequence #\. oid-string :remove-empty-subseqs t)
16 do (vector-push-extend (read-from-string subidentifier) result))
17 result))
18
19 (defun oid-to-oid-string (oid)
20 "Convert oid to string in form .1.3.5.6.7.333.233"
21 (with-output-to-string (s)
22 (loop for sub-identifier across oid do
23 (write-char #\. s)
24 (prin1 sub-identifier s))))
25
26 (let ((tag->octet (make-hash-table))
27 (octet->tag (make-hash-table))
28 (tag-list (list
29 (list :integer 2)
30 (list :octet-string 4)
31 (list :null 5)
32 (list :object-identifier 6)
33 (list :ipaddress 64)
34 (list :counter 65)
35 (list :gauge 66)
36 (list :timeticks 67)
37 (list :opaque 68)
38 (list :sequence #x30)
39 (list :get #xa0)
40 (list :getnext #xa1)
41 (list :response #xa2)
42 (list :set #xa3)
43 (list :trap #xa4))))
44 (loop for (id value) in tag-list do
45 (setf (gethash id tag->octet) value)
46 (setf (gethash value octet->tag) id))
47 (defun encode-tag (tag)
48 "Convert a symbolic tag value to an octet"
49 (gethash tag tag->octet))
50 (defun decode-tag (octet)
51 "Convert a tag octest to its symbolic value"
52 (gethash octet octet->tag))
53 )
54 (defun container-type-p (tag)
55 "Returns true if the tag is one of the container tags"
56 (member tag (list :sequence :get :getnext :response :set :trap)))
57
58 (defun integer-type-p (tag)
59 "Returns true if the tag is one of the ineger type tags"
60 (member tag (list :integer :counter :gauge :timeticks)))
61
62 (defun octet-string-type-p (tag)
63 "Returns true if tag is one of the tags that encode octet strings"
64 (member tag (list :octet-string :opaque :ipaddress)))
65
66 (defun object-identifier-type-p (tag)
67 "Return true if the tag is :object-identitier"
68 (member tag (list :object-identifier)))
69
70 (defun null-type-p (tag)
71 "Returns true if the tag is :null"
72 (member tag (list :null)))
73
74 (defun decode-length (from-array pos)
75 "Return length and newpos and length-of-length as values"
76 (let ((numbytes (aref from-array pos)))
77 (if (not (logbitp 7 numbytes))
78 (values numbytes (1+ pos) 1)
79 (let ((length-of-length (ldb (byte 7 0) numbytes))
80 (real-length 0))
81 (loop
82 for length-octet from (1- length-of-length) downto 0
83 for ref from (+ pos 1)
84 do (setf (ldb (byte 8 (* 8 length-octet)) real-length) (aref from-array ref)))
85 (values real-length (+ pos 1 length-of-length) (+ 1 length-of-length))))))
86
87 (defun ber-decode-integer-value (buffer start end)
88 "Return the integer-value starting"
89 (let (result)
90 (if (logbitp 7 (aref buffer start))
91 (setf result -1)
92 (setf result 0))
93 (loop
94 for buffer-pos downfrom (1- end) to start
95 for byte-pos from 0 by 8
96 do (setf (ldb (byte 8 byte-pos) result)
97 (aref buffer buffer-pos)))
98 result))
99
100 ;; The object identifier encoding
101 ;;
102 ;; An object is an array of integers, but can also be expressed in a string
103 ;; where each integer is separated by dots. For instance
104 ;;
105 ;; SNMP1> (oid-string-to-oid ".1.3.6.1.4.1.8072.3.2.10")
106 ;; #(1 3 6 1 4 1 8072 3 2 10)
107 ;; SNMP1>
108 ;;
109 ;; Note, this array is not the octet encoding, rather the most
110 ;; basic representation of the oid in this package.
111 ;;
112 ;; Encoding of the object identifier is mostly one byte per sub-identifier,
113 ;; with two exceptions.
114 ;;
115 ;; The first exception is that the two first sub-identifiers are compressed
116 ;; into one octet. So encoding of #(1 3 6) is octets #(43 6) (--ignoring tag and
117 ;; length here) rather than octets #(1 3 6)
118 ;;
119 ;; SNMP1> (ber-encode '(:object-identifier #(1 3 6)))
120 ;; #(6 2 43 6)
121 ;; SNMP1>
122 ;;
123 ;; The other exceptions is for sub-identifiers greater than 256, which is the
124 ;; maximum unsigned number that an octet can hold. To solve this problem,
125 ;; bit 7 of each octet is set when there are more octets for a sub-identifier.
126 ;; This also means we have only seven bits left to encode the sub-identifier,
127 ;; and the maximum sub-identifier that can be coded in one octet then
128 ;; becomes 127.
129 ;;
130 ;; This can be seen by encoding the first oid above.
131 ;;
132 ;; SNMP1> (ber-encode '(:object-identifier ".1.3.6.1.4.1.8072.3.2.10"))
133 ;; #(6 10 43 6 1 4 1 191 8 3 2 10)
134 ;; SNMP1>
135 ;;
136 ;; Now ignoring tag octet, length octet and the two first sub-identifiers,
137 ;; we can recognize 6 1 4 and 1 in the buffer. But the next one 8072, we
138 ;; can not see. It is larger than 127 and therefore encoded in
139 ;; more than one octet.
140 ;;
141 ;; We can split each octet in its seventh bit and the rest of the bits to
142 ;; see the idea clearer.
143 ;;
144 ;; SNMP1> (map 'vector #'(lambda (octet)
145 ;; (cons (ldb (byte 1 7) octet)(ldb (byte 7 0) octet)))
146 ;; *)
147 ;; #((0 . 6) (0 . 10) (0 . 43) (0 . 6) (0 . 1) (0 . 4) (0 . 1) (1 . 63) (0 . 8)
148 ;; (0 . 3) (0 . 2) (0 . 10))
149 ;; SNMP1>
150 ;;
151 ;; Here we see that the number 191 really is the seven bit number 63 with
152 ;; the octet's seventh bit set to signal that next octet, 8, is part of the same
153 ;; subidentifier.
154 ;;
155 ;; we find the real subidentifier with this formula:
156 ;;
157 ;; SNMP1> (+ (* 63 128) 8)
158 ;; 8072
159 ;; SNMP1>
160
161
162
163
164
165 (defun ber-decode-object-identifier-value (buffer start end)
166 "Decodes part of the octet string array and returns an array of subidentifiers
167 Each subidentifier can be one or more octets. Each octet that has its seventh
168 bit set, continues to the next octet. The first octet is special, as it
169 ecodes the two first subidentifiers."
170 (let ((result (make-array 20 :adjustable t :fill-pointer 0)))
171 ;; first and second oid are special
172
173 (multiple-value-bind (first-sub-identifier second-sub-identifier)
174 (truncate (aref buffer start) 40)
175 (vector-push-extend first-sub-identifier result)
176 (vector-push-extend second-sub-identifier result))
177 (let ((pos (1+ start))
178 octet
179 subidentifier)
180 (loop
181 while (< pos end )
182 do
183 (setf subidentifier 0)
184 (loop
185 do
186 (setf octet (aref buffer pos))
187 do
188
189 (setf subidentifier (+ (* subidentifier 128) (ldb (byte 7 0) octet)))
190 (incf pos)
191 while (logbitp 7 octet))
192 (vector-push-extend subidentifier result)
193 ))
194 result))
195
196 (defun ber-encode-integer-value (value to-array)
197 "Push value as integer to the tail oof the array. Every bit of
198 each octet is used, but we must make sure that the first octet
199 is less than 128 for positive numbers, as the 7.th bit in the
200 first octet signals a negative number"
201 (let ((numbytes (ceiling (1+ (integer-length value)) 8)))
202 (loop for pos from (1- numbytes) downto 0
203 do (vector-push-extend (ldb (byte 8 (* pos 8)) value) to-array))
204 to-array))
205
206
207 (defun ber-encode-octet-string-value (value to-array)
208 "Push value as octet-string. If the value is a string,
209 the result mitht be longer, depending on the current external
210 format"
211 (when (typep value 'string) (setf value (string-to-octets value)))
212 (loop for octet across value do (vector-push-extend octet to-array))
213 to-array)
214
215 (defun ber-encode-object-identifier-value (in-value to-array)
216 "Push value as octet-string Return to-array. The first two
217 subidentifers go into one octet. Most other subidentifiers go into
218 one octet each. If a subidentifier is greater than 127, several
219 octets are usec"
220 (let ((value (if (stringp in-value) (oid-string-to-oid in-value) in-value)))
221 ;; first and second subidentifier compressed into one octet
222 (vector-push-extend (+ (* 40 (aref value 0)) (aref value 1)) to-array)
223
224 (loop for sub-identifier across (subseq value 2) do
225
226 (if (zerop sub-identifier)
227 (vector-push-extend 0 to-array)
228 (loop for chunk from (1- (ceiling (integer-length sub-identifier) 7)) downto 0 do
229 (let ((out-octet (ldb (byte 7 (* chunk 7)) sub-identifier)))
230 (unless (zerop chunk) (setf out-octet (logior #b10000000 out-octet)))
231 (vector-push-extend out-octet to-array)))))
232 to-array))
233
234
235
236 (defun ber-encode (what &optional buffer)
237 "Encode a single tag and value, or recursively encode a sequence.
238 Example of input is '(:sequence (:object-identifier #(1 3 4 5 6)) (:integer 42))
239 Normally, this function is called on the complete snmp message, which is such
240 sequence"
241 (unless buffer (setf buffer (make-array 50 :element-type '(unsigned-byte 8) :fill-pointer 0)))
242 (let ((tag (first what))
243 (encoded-tag (encode-tag (first what)))
244 (start-pos (fill-pointer buffer)))
245 (vector-push-extend encoded-tag buffer)
246 ;; unfortunately we don't know length of length at this time.
247 ;; Guess length of length is 1, reserve an octet by pushing a zero to the buffer.
248 (vector-push-extend 0 buffer)
249 (cond
250 ((container-type-p tag)
251 (loop for thing in (cdr what) do (ber-encode thing buffer)))
252 ((octet-string-type-p tag) (ber-encode-octet-string-value (second what) buffer))
253 ((integer-type-p tag) (ber-encode-integer-value (second what) buffer))
254 ((object-identifier-type-p tag) (ber-encode-object-identifier-value (second what) buffer))
255 ((null-type-p tag) #|already done|#))
256 (let ((length-of-value (- (fill-pointer buffer) (+ start-pos 2))))
257 ;; if length is 127 or less, we can place it directly in the reserved octet
258 (if (< length-of-value 128)
259 (setf (aref buffer (+ start-pos 1)) length-of-value)
260 ;; our guess was wrong, now we have to move the value some places to the right
261 (let ((length-of-length (ceiling (1+ (integer-length length-of-value)) 8)))
262 (setf (aref buffer (+ start-pos 1)) (logior #b10000000 (ldb (byte 8 0) length-of-length )))
263 (adjust-array buffer #1=(+ length-of-length (fill-pointer buffer)) :fill-pointer #1#)
264 (loop
265 for to-pos from (1- (fill-pointer buffer)) downto (+ start-pos length-of-length 2)
266 for from-pos = (- (fill-pointer buffer) length-of-length 1) then (incf from-pos -1)
267 do (setf (aref buffer to-pos) (aref buffer from-pos)))
268 ;; now we can output the real length
269 (loop for pos from (1- length-of-length) downto 0
270 for out-pos from (+ start-pos 2)
271 do (setf (aref buffer out-pos) (ldb (byte 8 (* pos 8)) length-of-value)))
272
273 ))))
274 buffer)
275
276 (defun ber-decode (buffer &optional (input-start 0) input-end (level 0))
277 "the buffer is an octet string vector received from the net. It normally start with
278 a sequence containing the rest of the message. When a sequence tag is found, the
279 function calls itself recursively to decode the contents.
280 Resurn the buffer in list form and length of buffer that is used as second value"
281 (when (null buffer) (return-from ber-decode))
282 (unless input-end (setf input-end (length buffer)))
283 (let* ((start input-start)
284 start-of-length
285 start-value
286 tag
287 length
288 end-value
289 result)
290 (loop
291 do
292 (setf tag (decode-tag (aref buffer start)))
293 (setf start-of-length (1+ start))
294 (multiple-value-setq (length start-value) (decode-length buffer start-of-length))
295 (setf end-value (+ start-value length))
296 (cond
297 ((= start-value end-value) ; covers :null and empty sequences
298 (push (list tag) result))
299 ((container-type-p tag)
300 (let (container)
301 (push tag container)
302 (loop for sub-element in (ber-decode buffer start-value end-value (1+ level))
303 do (push sub-element container))
304 (push (reverse container) result)))
305 ((integer-type-p tag) (push (list tag (ber-decode-integer-value buffer start-value end-value)) result))
306 ((octet-string-type-p tag)
307 (push (list tag (subseq buffer start-value end-value)) result))
308 ((object-identifier-type-p tag)
309 (push (list tag (ber-decode-object-identifier-value buffer start-value end-value)) result))
310 )
311 (setf start end-value)
312 while (< start input-end))
313 (setf result (reverse result))
314 (if (and (= 0 level) (= 1 (length result)))
315 (values (first result) end-value)
316 (values result end-value))))
317
318

  ViewVC Help
Powered by ViewVC 1.1.5