1 ;;;; DNS implementation for COMMON-NET
3 (in-package :common-net)
6 (txid (random 65536) :type (unsigned-byte 16))
8 (opcode :query :type (member :query :iquery :status))
13 (resp-code :success :type (member :success :format-error :server-failure :name-error :not-implemented :refused))
14 (queries '() :type list)
15 (answers '() :type list)
16 (authority '() :type list)
17 (additional '() :type list))
19 (defclass resource-query ()
20 ((name :initarg :name)
21 (type :initarg :type)))
23 (defclass resource-record ()
24 ((name :initarg :name)
27 (defvar *rr-coding-types* '())
29 (defmacro define-rr-type (name class type slots)
30 (let ((format (mapcar #'(lambda (slot)
31 (list* (if (listp (car slot))
36 (slot-desc (mapcar #'car slots)))
38 (defclass ,name (resource-record) ,slot-desc)
39 (setf *rr-coding-types* (cons '(,name (,class ,type) ,format)
40 (remove ',name *rr-coding-types* :key #'car))))))
42 (define-rr-type a-record #x1 #x1
43 ((address ipv4-address)))
44 (define-rr-type ns-record #x1 #x2
45 ((ns-name domain-name)))
46 (define-rr-type cname-record #x1 #x5
47 ((cname domain-name)))
48 (define-rr-type soa-record #x1 #x6
55 (define-rr-type ptr-record #x1 #xc
56 ((pointed domain-name)))
57 (define-rr-type mx-record #x1 #xf
59 (mail-host domain-name)))
60 (define-rr-type txt-record #x1 #x10
62 (define-rr-type aaaa-record #x1 #x1c
63 ((address ipv6-address)))
64 (define-rr-type srv-record #x1 #x21
68 (host-name domain-name)))
70 ;;; Packet decoding logic
72 (defstruct dns-decode-state
73 (packet nil :type (array (unsigned-byte 8)))
74 (pos 0 :type (mod 65536))
75 (prev-names '() :type list))
77 (define-condition dns-error (error) ())
78 (define-condition dns-decode-error (dns-error)
79 ((packet :initarg :packet)))
80 (define-condition simple-dns-decode-error (dns-decode-error simple-error) ())
82 (defun simple-dns-decode-error (packet format &rest args)
83 (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
85 (defun decode-uint-8 (buf)
86 (declare (type dns-decode-state buf))
87 (with-slots (packet pos) buf
88 (when (< (- (length packet) pos) 1)
89 (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
90 (prog1 (aref packet pos)
93 (defun decode-uint-16 (buf)
94 (declare (type dns-decode-state buf))
95 (with-slots (packet pos) buf
96 (when (< (- (length packet) pos) 2)
97 (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
99 (+ (* (aref packet pos) 256)
100 (aref packet (1+ pos)))
103 (defun decode-uint-32 (buf)
104 (declare (type dns-decode-state buf))
105 (with-slots (packet pos) buf
106 (when (< (- (length packet) pos) 4)
107 (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
109 (+ (* (aref packet pos) #x1000000)
110 (* (aref packet (+ pos 1)) #x10000)
111 (* (aref packet (+ pos 2)) #x100)
112 (aref packet (+ pos 3)))
115 (defun decode-domain-name (buf)
116 (declare (type dns-decode-state buf))
117 (let* ((orig-off (dns-decode-state-pos buf))
118 (decoded (block decoded
120 (loop (let ((len (decode-uint-8 buf)))
121 (case (ldb (byte 2 6) len)
124 (return-from decoded l))
125 (with-slots (packet pos) buf
126 (setf l (append l (list (handler-bind
127 ((charcode:coding-error
130 (simple-dns-decode-error buf "DNS label was not ASCII."))))
131 (charcode:decode-string (subseq packet
135 ((3) (return-from decoded
136 (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
137 (decode-uint-8 buf)))
138 (prev (assoc offset (dns-decode-state-prev-names buf))))
140 (simple-dns-decode-error buf "Domain name label pointed to non-label position"))
141 (append l (cdr prev)))))
142 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))))))
143 (push (cons orig-off decoded)
144 (slot-value buf 'prev-names))))
146 (defun decode-dns-query (buf)
147 (declare (type dns-decode-state buf))
148 (let* ((name (decode-domain-name buf))
149 (type (decode-uint-16 buf))
150 (class (decode-uint-16 buf))
151 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
153 (make-instance 'resource-query :name name :type (first desc))
154 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
157 (defun decode-dns-record (buf)
158 (declare (type dns-decode-state buf))
159 (let* ((name (decode-domain-name buf))
160 (type (decode-uint-16 buf))
161 (class (decode-uint-16 buf))
162 (ttl (decode-uint-32 buf))
163 (dlen (decode-uint-16 buf))
164 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
165 (when (< (length (dns-decode-state-packet buf))
166 (+ (dns-decode-state-pos buf) dlen))
167 (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
169 (let ((orig-off (dns-decode-state-pos buf))
170 (rr (make-instance (first desc)
173 (dolist (slot-desc (third desc))
174 (destructuring-bind (slot-name type) slot-desc
175 (setf (slot-value rr slot-name)
176 (with-slots (packet pos) buf
178 ((uint-16) (decode-uint-16 buf))
179 ((uint-32) (decode-uint-32 buf))
180 ((domain-name) (decode-domain-name buf))
182 (let ((len (decode-uint-8 buf)))
183 (prog1 (subseq packet pos (+ pos len))
186 (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
189 (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
191 (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
192 (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
194 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
195 (incf (dns-decode-state-pos buf) dlen)
198 (defun decode-dns-packet (buf)
199 (declare (type dns-decode-state buf))
200 (let* ((txid (decode-uint-16 buf))
201 (flags (decode-uint-16 buf))
202 (qnum (decode-uint-16 buf))
203 (ansnum (decode-uint-16 buf))
204 (autnum (decode-uint-16 buf))
205 (auxnum (decode-uint-16 buf))
206 (packet (make-dns-packet :txid txid
207 :is-response (ldb-test (byte 1 15) flags)
208 :opcode (case (ldb (byte 4 11) flags)
212 (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
213 :authoritative (ldb-test (byte 1 10) flags)
214 :truncated (ldb-test (byte 1 9) flags)
215 :recurse (ldb-test (byte 1 8) flags)
216 :will-recurse (ldb-test (byte 1 7) flags)
217 :resp-code (case (ldb (byte 4 0) flags)
220 ((2) :server-failure)
222 ((4) :not-implemented)
224 (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
225 (with-slots (queries answers authority additional) packet
227 (setf queries (append queries (list (decode-dns-query buf)))))
229 (setf answers (append answers (list (decode-dns-record buf)))))
231 (setf authority (append authority (list (decode-dns-record buf)))))
233 (setf additional (append additional (list (decode-dns-record buf))))))
236 (defun dns-decode (packet)
237 (decode-dns-packet (make-dns-decode-state :packet packet)))
239 ;;; Packet encoding logic
241 (defstruct dns-encode-state
242 (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
243 (prev-names '() :type list))
245 (defun encode-uint-8 (buf num)
246 (declare (type dns-encode-state buf)
247 (type (unsigned-byte 8) num))
248 (with-slots (packet-buf) buf
249 (vector-push-extend num packet-buf)))
251 (defun encode-uint-16 (buf num)
252 (declare (type dns-encode-state buf)
253 (type (unsigned-byte 16) num))
254 (with-slots (packet-buf) buf
255 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
256 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
258 (defun encode-uint-32 (buf num)
259 (declare (type dns-encode-state buf)
260 (type (unsigned-byte 32) num))
261 (with-slots (packet-buf) buf
262 (vector-push-extend (ldb (byte 8 24) num) packet-buf)
263 (vector-push-extend (ldb (byte 8 16) num) packet-buf)
264 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
265 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
267 (defun encode-bytes (buf bytes)
268 (declare (type dns-encode-state buf)
269 (type (array (unsigned-byte 8)) bytes))
270 (with-slots (packet-buf) buf
271 (dotimes (i (length bytes) (values))
272 (vector-push-extend (elt bytes i) packet-buf))))
274 (defun encode-domain-name (buf name)
275 (declare (type dns-encode-state buf)
277 (with-slots (packet-buf prev-names) buf
278 (labels ((encode-label (name)
279 (let ((prev (find name prev-names :key 'first :test 'equal)))
281 (encode-uint-8 buf 0))
283 (encode-uint-16 buf (+ #xc000 (cdr prev))))
285 (when (< (length packet-buf) 16384)
286 (push (cons name (length packet-buf)) prev-names))
287 (let ((encoded (charcode:encode-string (car name) :ascii)))
288 (unless (< (length encoded) 64)
289 (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
290 (encode-uint-8 buf (length encoded))
291 (encode-bytes buf encoded))
292 (encode-label (cdr name)))))))
293 (encode-label name))))
295 (defun encode-dns-query (buf query)
296 (declare (type dns-encode-state buf)
297 (type resource-query query))
298 (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
299 (encode-domain-name buf (slot-value query 'name))
300 (encode-uint-16 buf (second (second desc)))
301 (encode-uint-16 buf (first (second desc)))))
303 (defun encode-dns-record (buf record)
304 (declare (type dns-encode-state buf)
305 (type resource-record record))
306 (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
307 (encode-domain-name buf (slot-value record 'name))
308 (encode-uint-16 buf (second (second desc)))
309 (encode-uint-16 buf (first (second desc)))
310 (encode-uint-32 buf (slot-value record 'ttl))
311 (with-slots (packet-buf) buf
312 (let ((orig-off (length packet-buf)))
313 (encode-uint-16 buf 0)
314 (dolist (slot-desc (third desc))
315 (destructuring-bind (slot-name type) slot-desc
316 (let ((val (slot-value record slot-name)))
318 ((uint-16) (encode-uint-16 buf val))
319 ((uint-32) (encode-uint-32 buf val))
320 ((domain-name) (encode-domain-name buf val))
321 ((text) (let ((data (etypecase val
322 (string (charcode:encode-string val :ascii))
323 ((array (unsigned-byte 8)) val))))
324 (unless (< (length data) 256)
325 (error "DNS text data length cannot exceed 255 octets."))
326 (encode-uint-8 buf (length data))
327 (encode-bytes buf data)))
329 (check-type val ipv4-host-address)
330 (encode-bytes buf (slot-value val 'host-bytes)))
332 (check-type val ipv6-host-address)
333 (encode-bytes buf (slot-value val 'host-bytes)))))))
334 (let ((dlen (- (length packet-buf) orig-off)))
335 (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
336 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
338 (defun encode-dns-packet (buf packet)
339 (declare (type dns-encode-state buf)
340 (type dns-packet packet))
341 (with-slots (txid is-response opcode authoritative truncated
342 recurse will-recurse resp-code
343 queries answers authority additional) packet
344 (encode-uint-16 buf txid)
346 (setf (ldb (byte 1 15) flags) (if is-response 1 0)
347 (ldb (byte 4 11) flags) (ecase opcode
351 (ldb (byte 1 10) flags) (if authoritative 1 0)
352 (ldb (byte 1 9) flags) (if truncated 1 0)
353 (ldb (byte 1 8) flags) (if recurse 1 0)
354 (ldb (byte 1 7) flags) (if will-recurse 1 0)
355 (ldb (byte 4 0) flags) (ecase resp-code
358 ((:server-failure) 2)
360 ((:not-implemented) 4)
362 (encode-uint-16 buf flags))
363 (encode-uint-16 buf (length queries))
364 (encode-uint-16 buf (length answers))
365 (encode-uint-16 buf (length authority))
366 (encode-uint-16 buf (length additional))
367 (dolist (query queries)
368 (encode-dns-query buf query))
370 (encode-dns-record buf rr))
371 (dolist (rr authority)
372 (encode-dns-record buf rr))
373 (dolist (rr additional)
374 (encode-dns-record buf rr)))
377 (defun dns-encode (packet)
378 (check-type packet dns-packet)
379 (let ((buf (make-dns-encode-state)))
380 (encode-dns-packet buf packet)
381 (slot-value buf 'packet-buf)))