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 (labels ((decode-label ()
118 (let* ((orig-off (dns-decode-state-pos buf))
119 (len (decode-uint-8 buf)))
120 (case (ldb (byte 2 6) len)
124 (with-slots (packet pos) buf
127 ((charcode:coding-error
130 (simple-dns-decode-error buf "DNS label was not ASCII."))))
131 (charcode:decode-string (subseq packet
135 (decoded (append (list label) (decode-label))))
136 (push (cons orig-off decoded) (slot-value buf 'prev-names))
138 ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
139 (decode-uint-8 buf)))
140 (prev (assoc offset (dns-decode-state-prev-names buf))))
142 (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
144 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
147 (defun decode-dns-query (buf)
148 (declare (type dns-decode-state buf))
149 (let* ((name (decode-domain-name buf))
150 (type (decode-uint-16 buf))
151 (class (decode-uint-16 buf))
152 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
154 (make-instance 'resource-query :name name :type (first desc))
155 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
158 (defun decode-dns-record (buf)
159 (declare (type dns-decode-state buf))
160 (let* ((name (decode-domain-name buf))
161 (type (decode-uint-16 buf))
162 (class (decode-uint-16 buf))
163 (ttl (decode-uint-32 buf))
164 (dlen (decode-uint-16 buf))
165 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
166 (when (< (length (dns-decode-state-packet buf))
167 (+ (dns-decode-state-pos buf) dlen))
168 (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
170 (let ((orig-off (dns-decode-state-pos buf))
171 (rr (make-instance (first desc)
174 (dolist (slot-desc (third desc))
175 (destructuring-bind (slot-name type) slot-desc
176 (setf (slot-value rr slot-name)
177 (with-slots (packet pos) buf
179 ((uint-16) (decode-uint-16 buf))
180 ((uint-32) (decode-uint-32 buf))
181 ((domain-name) (decode-domain-name buf))
183 (let ((len (decode-uint-8 buf)))
184 (prog1 (subseq packet pos (+ pos len))
187 (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
190 (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
192 (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
193 (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
195 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
196 (incf (dns-decode-state-pos buf) dlen)
199 (defun decode-dns-packet (buf)
200 (declare (type dns-decode-state buf))
201 (let* ((txid (decode-uint-16 buf))
202 (flags (decode-uint-16 buf))
203 (qnum (decode-uint-16 buf))
204 (ansnum (decode-uint-16 buf))
205 (autnum (decode-uint-16 buf))
206 (auxnum (decode-uint-16 buf))
207 (packet (make-dns-packet :txid txid
208 :is-response (ldb-test (byte 1 15) flags)
209 :opcode (case (ldb (byte 4 11) flags)
213 (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
214 :authoritative (ldb-test (byte 1 10) flags)
215 :truncated (ldb-test (byte 1 9) flags)
216 :recurse (ldb-test (byte 1 8) flags)
217 :will-recurse (ldb-test (byte 1 7) flags)
218 :resp-code (case (ldb (byte 4 0) flags)
221 ((2) :server-failure)
223 ((4) :not-implemented)
225 (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
226 (with-slots (queries answers authority additional) packet
228 (setf queries (append queries (list (decode-dns-query buf)))))
230 (setf answers (append answers (list (decode-dns-record buf)))))
232 (setf authority (append authority (list (decode-dns-record buf)))))
234 (setf additional (append additional (list (decode-dns-record buf))))))
237 (defun dns-decode (packet)
238 (decode-dns-packet (make-dns-decode-state :packet packet)))
240 ;;; Packet encoding logic
242 (defstruct dns-encode-state
243 (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
244 (prev-names '() :type list))
246 (defun encode-uint-8 (buf num)
247 (declare (type dns-encode-state buf)
248 (type (unsigned-byte 8) num))
249 (with-slots (packet-buf) buf
250 (vector-push-extend num packet-buf)))
252 (defun encode-uint-16 (buf num)
253 (declare (type dns-encode-state buf)
254 (type (unsigned-byte 16) num))
255 (with-slots (packet-buf) buf
256 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
257 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
259 (defun encode-uint-32 (buf num)
260 (declare (type dns-encode-state buf)
261 (type (unsigned-byte 32) num))
262 (with-slots (packet-buf) buf
263 (vector-push-extend (ldb (byte 8 24) num) packet-buf)
264 (vector-push-extend (ldb (byte 8 16) num) packet-buf)
265 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
266 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
268 (defun encode-bytes (buf bytes)
269 (declare (type dns-encode-state buf)
270 (type (array (unsigned-byte 8)) bytes))
271 (with-slots (packet-buf) buf
272 (dotimes (i (length bytes) (values))
273 (vector-push-extend (elt bytes i) packet-buf))))
275 (defun encode-domain-name (buf name)
276 (declare (type dns-encode-state buf)
278 (with-slots (packet-buf prev-names) buf
279 (labels ((encode-label (name)
280 (let ((prev (find name prev-names :key 'first :test 'equal)))
282 (encode-uint-8 buf 0))
284 (encode-uint-16 buf (+ #xc000 (cdr prev))))
286 (when (< (length packet-buf) 16384)
287 (push (cons name (length packet-buf)) prev-names))
288 (let ((encoded (charcode:encode-string (car name) :ascii)))
289 (unless (< (length encoded) 64)
290 (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
291 (encode-uint-8 buf (length encoded))
292 (encode-bytes buf encoded))
293 (encode-label (cdr name)))))))
294 (encode-label name))))
296 (defun encode-dns-query (buf query)
297 (declare (type dns-encode-state buf)
298 (type resource-query query))
299 (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
300 (encode-domain-name buf (slot-value query 'name))
301 (encode-uint-16 buf (second (second desc)))
302 (encode-uint-16 buf (first (second desc)))))
304 (defun encode-dns-record (buf record)
305 (declare (type dns-encode-state buf)
306 (type resource-record record))
307 (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
308 (encode-domain-name buf (slot-value record 'name))
309 (encode-uint-16 buf (second (second desc)))
310 (encode-uint-16 buf (first (second desc)))
311 (encode-uint-32 buf (slot-value record 'ttl))
312 (with-slots (packet-buf) buf
313 (let ((orig-off (length packet-buf)))
314 (encode-uint-16 buf 0)
315 (dolist (slot-desc (third desc))
316 (destructuring-bind (slot-name type) slot-desc
317 (let ((val (slot-value record slot-name)))
319 ((uint-16) (encode-uint-16 buf val))
320 ((uint-32) (encode-uint-32 buf val))
321 ((domain-name) (encode-domain-name buf val))
322 ((text) (let ((data (etypecase val
323 (string (charcode:encode-string val :ascii))
324 ((array (unsigned-byte 8)) val))))
325 (unless (< (length data) 256)
326 (error "DNS text data length cannot exceed 255 octets."))
327 (encode-uint-8 buf (length data))
328 (encode-bytes buf data)))
330 (check-type val ipv4-host-address)
331 (encode-bytes buf (slot-value val 'host-bytes)))
333 (check-type val ipv6-host-address)
334 (encode-bytes buf (slot-value val 'host-bytes)))))))
335 (let ((dlen (- (length packet-buf) orig-off)))
336 (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
337 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
339 (defun encode-dns-packet (buf packet)
340 (declare (type dns-encode-state buf)
341 (type dns-packet packet))
342 (with-slots (txid is-response opcode authoritative truncated
343 recurse will-recurse resp-code
344 queries answers authority additional) packet
345 (encode-uint-16 buf txid)
347 (setf (ldb (byte 1 15) flags) (if is-response 1 0)
348 (ldb (byte 4 11) flags) (ecase opcode
352 (ldb (byte 1 10) flags) (if authoritative 1 0)
353 (ldb (byte 1 9) flags) (if truncated 1 0)
354 (ldb (byte 1 8) flags) (if recurse 1 0)
355 (ldb (byte 1 7) flags) (if will-recurse 1 0)
356 (ldb (byte 4 0) flags) (ecase resp-code
359 ((:server-failure) 2)
361 ((:not-implemented) 4)
363 (encode-uint-16 buf flags))
364 (encode-uint-16 buf (length queries))
365 (encode-uint-16 buf (length answers))
366 (encode-uint-16 buf (length authority))
367 (encode-uint-16 buf (length additional))
368 (dolist (query queries)
369 (encode-dns-query buf query))
371 (encode-dns-record buf rr))
372 (dolist (rr authority)
373 (encode-dns-record buf rr))
374 (dolist (rr additional)
375 (encode-dns-record buf rr)))
378 (defun dns-encode (packet)
379 (check-type packet dns-packet)
380 (let ((buf (make-dns-encode-state)))
381 (encode-dns-packet buf packet)
382 (slot-value buf 'packet-buf)))