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 #'(lambda (slot)
37 (let ((name (car slot)))
38 `(,name :initarg ,(intern (symbol-name name) (find-package :keyword))))) slots)))
40 (defclass ,name (resource-record) ,slot-desc)
41 (setf *rr-coding-types* (cons '(,name (,class ,type) ,format)
42 (remove ',name *rr-coding-types* :key #'car))))))
44 (define-rr-type a-record #x1 #x1
45 ((address ipv4-address)))
46 (define-rr-type ns-record #x1 #x2
47 ((ns-name domain-name)))
48 (define-rr-type cname-record #x1 #x5
49 ((cname domain-name)))
50 (define-rr-type soa-record #x1 #x6
57 (define-rr-type ptr-record #x1 #xc
58 ((pointed domain-name)))
59 (define-rr-type mx-record #x1 #xf
61 (mail-host domain-name)))
62 (define-rr-type txt-record #x1 #x10
64 (define-rr-type aaaa-record #x1 #x1c
65 ((address ipv6-address)))
66 (define-rr-type srv-record #x1 #x21
70 (host-name domain-name)))
72 ;;; Packet decoding logic
74 (defstruct dns-decode-state
75 (packet nil :type (array (unsigned-byte 8)))
76 (pos 0 :type (mod 65536))
77 (prev-names '() :type list))
79 (define-condition dns-error (error) ())
80 (define-condition dns-decode-error (dns-error)
81 ((packet :initarg :packet)))
82 (define-condition simple-dns-decode-error (dns-decode-error simple-error) ())
84 (defun simple-dns-decode-error (packet format &rest args)
85 (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
87 (defun decode-uint-8 (buf)
88 (declare (type dns-decode-state buf))
89 (with-slots (packet pos) buf
90 (when (< (- (length packet) pos) 1)
91 (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
92 (prog1 (aref packet pos)
95 (defun decode-uint-16 (buf)
96 (declare (type dns-decode-state buf))
97 (with-slots (packet pos) buf
98 (when (< (- (length packet) pos) 2)
99 (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
101 (+ (* (aref packet pos) 256)
102 (aref packet (1+ pos)))
105 (defun decode-uint-32 (buf)
106 (declare (type dns-decode-state buf))
107 (with-slots (packet pos) buf
108 (when (< (- (length packet) pos) 4)
109 (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
111 (+ (* (aref packet pos) #x1000000)
112 (* (aref packet (+ pos 1)) #x10000)
113 (* (aref packet (+ pos 2)) #x100)
114 (aref packet (+ pos 3)))
117 (defun decode-domain-name (buf)
118 (declare (type dns-decode-state buf))
119 (labels ((decode-label ()
120 (let* ((orig-off (dns-decode-state-pos buf))
121 (len (decode-uint-8 buf)))
122 (case (ldb (byte 2 6) len)
126 (with-slots (packet pos) buf
129 ((charcode:coding-error
132 (simple-dns-decode-error buf "DNS label was not ASCII."))))
133 (charcode:decode-string (subseq packet
137 (decoded (append (list label) (decode-label))))
138 (push (cons orig-off decoded) (slot-value buf 'prev-names))
140 ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
141 (decode-uint-8 buf)))
142 (prev (assoc offset (dns-decode-state-prev-names buf))))
144 (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
146 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
149 (defun decode-dns-query (buf)
150 (declare (type dns-decode-state buf))
151 (let* ((name (decode-domain-name buf))
152 (type (decode-uint-16 buf))
153 (class (decode-uint-16 buf))
154 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
156 (make-instance 'resource-query :name name :type (first desc))
157 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
160 (defun decode-dns-record (buf)
161 (declare (type dns-decode-state buf))
162 (let* ((name (decode-domain-name buf))
163 (type (decode-uint-16 buf))
164 (class (decode-uint-16 buf))
165 (ttl (decode-uint-32 buf))
166 (dlen (decode-uint-16 buf))
167 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
168 (when (< (length (dns-decode-state-packet buf))
169 (+ (dns-decode-state-pos buf) dlen))
170 (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
172 (let ((orig-off (dns-decode-state-pos buf))
173 (rr (make-instance (first desc)
176 (dolist (slot-desc (third desc))
177 (destructuring-bind (slot-name type) slot-desc
178 (setf (slot-value rr slot-name)
179 (with-slots (packet pos) buf
181 ((uint-16) (decode-uint-16 buf))
182 ((uint-32) (decode-uint-32 buf))
183 ((domain-name) (decode-domain-name buf))
185 (let ((len (decode-uint-8 buf)))
186 (prog1 (subseq packet pos (+ pos len))
189 (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
192 (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
194 (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
195 (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
197 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
198 (incf (dns-decode-state-pos buf) dlen)
201 (defun decode-dns-packet (buf)
202 (declare (type dns-decode-state buf))
203 (let* ((txid (decode-uint-16 buf))
204 (flags (decode-uint-16 buf))
205 (qnum (decode-uint-16 buf))
206 (ansnum (decode-uint-16 buf))
207 (autnum (decode-uint-16 buf))
208 (auxnum (decode-uint-16 buf))
209 (packet (make-dns-packet :txid txid
210 :is-response (ldb-test (byte 1 15) flags)
211 :opcode (case (ldb (byte 4 11) flags)
215 (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
216 :authoritative (ldb-test (byte 1 10) flags)
217 :truncated (ldb-test (byte 1 9) flags)
218 :recurse (ldb-test (byte 1 8) flags)
219 :will-recurse (ldb-test (byte 1 7) flags)
220 :resp-code (case (ldb (byte 4 0) flags)
223 ((2) :server-failure)
225 ((4) :not-implemented)
227 (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
228 (with-slots (queries answers authority additional) packet
230 (setf queries (append queries (list (decode-dns-query buf)))))
232 (setf answers (append answers (list (decode-dns-record buf)))))
234 (setf authority (append authority (list (decode-dns-record buf)))))
236 (setf additional (append additional (list (decode-dns-record buf))))))
239 (defun dns-decode (packet)
240 (decode-dns-packet (make-dns-decode-state :packet packet)))
242 ;;; Packet encoding logic
244 (defstruct dns-encode-state
245 (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
246 (prev-names '() :type list))
248 (defun encode-uint-8 (buf num)
249 (declare (type dns-encode-state buf)
250 (type (unsigned-byte 8) num))
251 (with-slots (packet-buf) buf
252 (vector-push-extend num packet-buf)))
254 (defun encode-uint-16 (buf num)
255 (declare (type dns-encode-state buf)
256 (type (unsigned-byte 16) num))
257 (with-slots (packet-buf) buf
258 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
259 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
261 (defun encode-uint-32 (buf num)
262 (declare (type dns-encode-state buf)
263 (type (unsigned-byte 32) num))
264 (with-slots (packet-buf) buf
265 (vector-push-extend (ldb (byte 8 24) num) packet-buf)
266 (vector-push-extend (ldb (byte 8 16) num) packet-buf)
267 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
268 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
270 (defun encode-bytes (buf bytes)
271 (declare (type dns-encode-state buf)
272 (type (array (unsigned-byte 8)) bytes))
273 (with-slots (packet-buf) buf
274 (dotimes (i (length bytes) (values))
275 (vector-push-extend (elt bytes i) packet-buf))))
277 (defun encode-domain-name (buf name)
278 (declare (type dns-encode-state buf)
280 (with-slots (packet-buf prev-names) buf
281 (labels ((encode-label (name)
282 (let ((prev (find name prev-names :key 'first :test 'equal)))
284 (encode-uint-8 buf 0))
286 (encode-uint-16 buf (+ #xc000 (cdr prev))))
288 (when (< (length packet-buf) 16384)
289 (push (cons name (length packet-buf)) prev-names))
290 (let ((encoded (charcode:encode-string (car name) :ascii)))
291 (unless (< (length encoded) 64)
292 (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
293 (encode-uint-8 buf (length encoded))
294 (encode-bytes buf encoded))
295 (encode-label (cdr name)))))))
296 (encode-label name))))
298 (defun encode-dns-query (buf query)
299 (declare (type dns-encode-state buf)
300 (type resource-query query))
301 (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
302 (encode-domain-name buf (slot-value query 'name))
303 (encode-uint-16 buf (second (second desc)))
304 (encode-uint-16 buf (first (second desc)))))
306 (defun encode-dns-record (buf record)
307 (declare (type dns-encode-state buf)
308 (type resource-record record))
309 (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
310 (encode-domain-name buf (slot-value record 'name))
311 (encode-uint-16 buf (second (second desc)))
312 (encode-uint-16 buf (first (second desc)))
313 (encode-uint-32 buf (slot-value record 'ttl))
314 (with-slots (packet-buf) buf
315 (let ((orig-off (length packet-buf)))
316 (encode-uint-16 buf 0)
317 (dolist (slot-desc (third desc))
318 (destructuring-bind (slot-name type) slot-desc
319 (let ((val (slot-value record slot-name)))
321 ((uint-16) (encode-uint-16 buf val))
322 ((uint-32) (encode-uint-32 buf val))
323 ((domain-name) (encode-domain-name buf val))
324 ((text) (let ((data (etypecase val
325 (string (charcode:encode-string val :ascii))
326 ((array (unsigned-byte 8)) val))))
327 (unless (< (length data) 256)
328 (error "DNS text data length cannot exceed 255 octets."))
329 (encode-uint-8 buf (length data))
330 (encode-bytes buf data)))
332 (check-type val ipv4-host-address)
333 (encode-bytes buf (slot-value val 'host-bytes)))
335 (check-type val ipv6-host-address)
336 (encode-bytes buf (slot-value val 'host-bytes)))))))
337 (let ((dlen (- (length packet-buf) orig-off)))
338 (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
339 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
341 (defun encode-dns-packet (buf packet)
342 (declare (type dns-encode-state buf)
343 (type dns-packet packet))
344 (with-slots (txid is-response opcode authoritative truncated
345 recurse will-recurse resp-code
346 queries answers authority additional) packet
347 (encode-uint-16 buf txid)
349 (setf (ldb (byte 1 15) flags) (if is-response 1 0)
350 (ldb (byte 4 11) flags) (ecase opcode
354 (ldb (byte 1 10) flags) (if authoritative 1 0)
355 (ldb (byte 1 9) flags) (if truncated 1 0)
356 (ldb (byte 1 8) flags) (if recurse 1 0)
357 (ldb (byte 1 7) flags) (if will-recurse 1 0)
358 (ldb (byte 4 0) flags) (ecase resp-code
361 ((:server-failure) 2)
363 ((:not-implemented) 4)
365 (encode-uint-16 buf flags))
366 (encode-uint-16 buf (length queries))
367 (encode-uint-16 buf (length answers))
368 (encode-uint-16 buf (length authority))
369 (encode-uint-16 buf (length additional))
370 (dolist (query queries)
371 (encode-dns-query buf query))
373 (encode-dns-record buf rr))
374 (dolist (rr authority)
375 (encode-dns-record buf rr))
376 (dolist (rr additional)
377 (encode-dns-record buf rr)))
380 (defun dns-encode (packet)
381 (check-type packet dns-packet)
382 (let ((buf (make-dns-encode-state)))
383 (encode-dns-packet buf packet)
384 (slot-value buf 'packet-buf)))
388 (defun parse-domain-name (name)
389 (declare (type string name))
392 (loop (let ((p2 (position #\. name :start p)))
394 (if (= p2 (1- (length name)))
395 (return (values l t))
396 (setf l (append l (list (subseq name p p2)))
398 (return (values (append l (list (subseq name p))) nil)))))))
400 (defun unparse-domain-name (name)
401 (declare (type list name))
403 (dolist (label name buf)
405 (concatenate 'string buf "." label)
408 ;;; Basic communication
410 (defun dns-do-request (server packet)
411 (declare (type address server)
412 (type dns-packet packet))
413 (with-connection (sk server)
414 (socket-send sk (dns-encode packet))
416 (let ((resp (dns-decode (socket-recv sk))))
417 (when (= (dns-packet-txid resp)
418 (dns-packet-txid packet))
421 (defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
422 (let ((qlist (map 'list #'(lambda (o)
423 (let ((name (first o))
425 (make-instance 'resource-query
426 :name (etypecase name
427 (string (parse-domain-name name))
431 (make-dns-packet :txid txid
437 (defstruct domain-cache-entry
438 (time (get-internal-real-time) :type unsigned-byte)
439 (records '() :type list))
441 (defun domain-cache-get-entry (cache name type &optional create)
442 (let* ((key (list name (etypecase type
444 (resource-record (class-name (class-of type))))))
445 (cur (gethash key cache)))
447 (when (and cur (domain-cache-entry-records cur)
448 (> (get-internal-real-time)
449 (+ (domain-cache-entry-time cur)
450 (apply 'min (mapcar #'(lambda (o)
451 (declare (type resource-record o))
453 (unless ttl (return-from no-expire))
455 (domain-cache-entry-records cur))))))
460 (setf (gethash key cache) (make-domain-cache-entry))))))
462 (defun domain-cache-put (cache record)
463 (with-slots (name ttl) record
464 (let ((entry (domain-cache-get-entry cache name record t)))
465 (push record (domain-cache-entry-records entry)))))
467 (defun make-domain-cache ()
468 (let ((table (make-hash-table :test 'equal)))
469 (dolist (server (labels ((ipv4 (address)
470 (make-instance 'ipv4-host-address :host-string address)))
471 `(("a.root-servers.net" ,(ipv4 "198.41.0.4"))
472 ("b.root-servers.net" ,(ipv4 "192.228.79.201"))
473 ("c.root-servers.net" ,(ipv4 "192.33.4.12"))
474 ("d.root-servers.net" ,(ipv4 "128.8.10.90"))
475 ("e.root-servers.net" ,(ipv4 "192.203.230.10"))
476 ("f.root-servers.net" ,(ipv4 "192.5.5.241"))
477 ("g.root-servers.net" ,(ipv4 "192.112.36.4"))
478 ("h.root-servers.net" ,(ipv4 "128.63.2.53"))
479 ("i.root-servers.net" ,(ipv4 "192.36.148.17"))
480 ("j.root-servers.net" ,(ipv4 "192.58.128.30"))
481 ("k.root-servers.net" ,(ipv4 "193.0.14.129"))
482 ("l.root-servers.net" ,(ipv4 "199.7.83.42"))
483 ("m.root-servers.net" ,(ipv4 "202.12.27.33")))))
484 (let ((parsed (parse-domain-name (first server))))
485 (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed))
486 (dolist (address (cdr server))
487 (domain-cache-put table (etypecase address
488 (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address)))))))
493 (defstruct resolver-config
494 (cache (make-domain-cache))
495 (default-domains '() :type list)
496 (help-servers '() :type list))
498 (defun initialize-default-resolver ()
499 #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil)
501 (let ((cfg (make-resolver-config)))
502 (labels ((whitespace-p (char)
503 (declare (type character char))
504 (or (char= char #\space)
509 (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p)
511 (p2 (position-if #'whitespace-p line :start p1)))
513 (setf l (append l (list (subseq line p1 p2)))
515 (progn (setf l (append l (list (subseq line p1 p2))))
519 (loop (let ((line (read-line s nil nil)))
520 (unless line (return))
521 (let ((line (split-line line)))
523 (cond ((equal (car line) "nameserver")
524 (push (make-instance 'ipv4-address :host-string (second line))
525 (resolver-config-help-servers cfg)))
526 ((equal (car line) "search")
527 (setf search (append search (cdr line))))
528 ((equal (car line) "domain")
529 (setf domain (second line))))))))
530 (setf (resolver-config-default-domains cfg)
531 (or search (and domain (list domain)))))
535 (defvar *resolver-config* (initialize-default-resolver))
541 (defmethod print-object ((q resource-query) stream)
542 (with-slots (name type) q
544 (format stream "~A: ~A" type (unparse-domain-name name))
545 (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))