[lisp-utils.git] / dns.lisp

;;;; DNS implementation for COMMON-NET

(in-package :common-net)

(defstruct dns-packet
  (txid (random 65536) :type (unsigned-byte 16))
  (is-response nil)
  (opcode :query :type (member :query :iquery :status))
  (authoritative nil)
  (truncated nil)
  (recurse nil)
  (will-recurse nil)
  (resp-code :success :type (member :success :format-error :server-failure :name-error :not-implemented :refused))
  (queries '() :type list)
  (answers '() :type list)
  (authority '() :type list)
  (additional '() :type list))

(defclass resource-query ()
  ((name :initarg :name)
   (type :initarg :type)))

(defclass resource-record ()
  ((name :initarg :name)
   (ttl :initarg :ttl)))

(defvar *rr-coding-types* '())

(defmacro define-rr-type (name class type slots)
  (let ((format (mapcar #'(lambda (slot)
			    (list* (if (listp (car slot))
				      (caar slot)
				      (car slot))
				   (cdr slot)))
			slots))
	(slot-desc (mapcar #'car slots)))
    `(progn
       (defclass ,name (resource-record) ,slot-desc)
       (setf *rr-coding-types* (cons '(,name (,class ,type) ,format)
				     (remove ',name *rr-coding-types* :key #'car))))))

(define-rr-type a-record #x1 #x1
		((address ipv4-address)))
(define-rr-type ns-record #x1 #x2
		((ns-name domain-name)))
(define-rr-type cname-record #x1 #x5
		((cname domain-name)))
(define-rr-type soa-record #x1 #x6
		((mname domain-name)
		 (rname domain-name)
		 (serial uint-32)
		 (refresh uint-32)
		 (retry uint-32)
		 (expire uint-32)))
(define-rr-type ptr-record #x1 #xc
		((pointed domain-name)))
(define-rr-type mx-record #x1 #xf
		((prio uint-16)
		 (mail-host domain-name)))
(define-rr-type txt-record #x1 #x10
		((text text)))
(define-rr-type aaaa-record #x1 #x1c
		((address ipv6-address)))
(define-rr-type srv-record #x1 #x21
		((prio uint-16)
		 (weigth uint-16)
		 (port uint-16)
		 (host-name domain-name)))

;;; Packet decoding logic

(defstruct dns-decode-state
  (packet nil :type (array (unsigned-byte 8)))
  (pos 0 :type (mod 65536))
  (prev-names '() :type list))

(define-condition dns-error (error) ())
(define-condition dns-decode-error (dns-error)
  ((packet :initarg :packet)))
(define-condition simple-dns-decode-error (dns-decode-error simple-error) ())

(defun simple-dns-decode-error (packet format &rest args)
  (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))

(defun decode-uint-8 (buf)
 (declare (type dns-decode-state buf))
  (with-slots (packet pos) buf
    (when (< (- (length packet) pos) 1)
      (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
    (prog1 (aref packet pos)
      (incf pos))))

(defun decode-uint-16 (buf)
  (declare (type dns-decode-state buf))
  (with-slots (packet pos) buf
    (when (< (- (length packet) pos) 2)
      (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
    (prog1
	(+ (* (aref packet pos) 256)
	   (aref packet (1+ pos)))
      (incf pos 2))))

(defun decode-uint-32 (buf)
  (declare (type dns-decode-state buf))
  (with-slots (packet pos) buf
    (when (< (- (length packet) pos) 4)
      (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
    (prog1
	(+ (* (aref packet pos) #x1000000)
	   (* (aref packet (+ pos 1)) #x10000)
	   (* (aref packet (+ pos 2)) #x100)
	   (aref packet (+ pos 3)))
      (incf pos 4))))

(defun decode-domain-name (buf)
  (declare (type dns-decode-state buf))
  (labels ((decode-label ()
	     (let* ((orig-off (dns-decode-state-pos buf))
		    (len (decode-uint-8 buf)))
	       (case (ldb (byte 2 6) len)
		 ((0)
		  (if (zerop len)
		      '()
		      (with-slots (packet pos) buf
			(let* ((label (prog1
					  (handler-bind
					      ((charcode:coding-error
						(lambda (c)
						  (declare (ignore c))
						  (simple-dns-decode-error buf "DNS label was not ASCII."))))
					    (charcode:decode-string (subseq packet
									    pos (+ pos len))
								    :ascii))
					(incf pos len)))
			       (decoded (append (list label) (decode-label))))
			  (push (cons orig-off decoded) (slot-value buf 'prev-names))
			  decoded))))
		 ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
					(decode-uint-8 buf)))
			     (prev (assoc offset (dns-decode-state-prev-names buf))))
			(unless prev
			  (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
			(cdr prev)))
		 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
    (decode-label)))

(defun decode-dns-query (buf)
  (declare (type dns-decode-state buf))
  (let* ((name (decode-domain-name buf))
	 (type (decode-uint-16 buf))
	 (class (decode-uint-16 buf))
	 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
    (if desc
	(make-instance 'resource-query :name name :type (first desc))
	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
	       nil))))

(defun decode-dns-record (buf)
  (declare (type dns-decode-state buf))
  (let* ((name (decode-domain-name buf))
	 (type (decode-uint-16 buf))
	 (class (decode-uint-16 buf))
	 (ttl (decode-uint-32 buf))
	 (dlen (decode-uint-16 buf))
	 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
    (when (< (length (dns-decode-state-packet buf))
	     (+ (dns-decode-state-pos buf) dlen))
      (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
    (if desc
	(let ((orig-off (dns-decode-state-pos buf))
	      (rr (make-instance (first desc)
				 :name name
				 :ttl ttl)))
	  (dolist (slot-desc (third desc))
	    (destructuring-bind (slot-name type) slot-desc
	      (setf (slot-value rr slot-name)
		    (with-slots (packet pos) buf
		      (ecase type
			((uint-16) (decode-uint-16 buf))
			((uint-32) (decode-uint-32 buf))
			((domain-name) (decode-domain-name buf))
			((text)
			 (let ((len (decode-uint-8 buf)))
			   (prog1 (subseq packet pos (+ pos len))
			     (incf pos len))))
			((ipv4-address)
			 (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
			   (incf pos 4)))
			((ipv6-address)
			 (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
			   (incf pos 16))))))))
	  (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
	    (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
	  rr)
	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
	       (incf (dns-decode-state-pos buf) dlen)
	       nil))))

(defun decode-dns-packet (buf)
  (declare (type dns-decode-state buf))
  (let* ((txid (decode-uint-16 buf))
	 (flags (decode-uint-16 buf))
	 (qnum (decode-uint-16 buf))
	 (ansnum (decode-uint-16 buf))
	 (autnum (decode-uint-16 buf))
	 (auxnum (decode-uint-16 buf))
	 (packet (make-dns-packet :txid txid
				  :is-response (ldb-test (byte 1 15) flags)
				  :opcode (case (ldb (byte 4 11) flags)
					    ((0) :query)
					    ((1) :iquery)
					    ((2) :status)
					    (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
				  :authoritative (ldb-test (byte 1 10) flags)
				  :truncated (ldb-test (byte 1 9) flags)
				  :recurse (ldb-test (byte 1 8) flags)
				  :will-recurse (ldb-test (byte 1 7) flags)
				  :resp-code (case (ldb (byte 4 0) flags)
					       ((0) :success)
					       ((1) :format-error)
					       ((2) :server-failure)
					       ((3) :name-error)
					       ((4) :not-implemented)
					       ((5) :refused)
					       (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
    (with-slots (queries answers authority additional) packet
	(dotimes (i qnum)
	  (setf queries (append queries (list (decode-dns-query buf)))))
	(dotimes (i ansnum)
	  (setf answers (append answers (list (decode-dns-record buf)))))
	(dotimes (i autnum)
	  (setf authority (append authority (list (decode-dns-record buf)))))
	(dotimes (i auxnum)
	  (setf additional (append additional (list (decode-dns-record buf))))))
    packet))

(defun dns-decode (packet)
  (decode-dns-packet (make-dns-decode-state :packet packet)))

;;; Packet encoding logic

(defstruct dns-encode-state
  (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
  (prev-names '() :type list))

(defun encode-uint-8 (buf num)
  (declare (type dns-encode-state buf)
	   (type (unsigned-byte 8) num))
  (with-slots (packet-buf) buf
    (vector-push-extend num packet-buf)))

(defun encode-uint-16 (buf num)
  (declare (type dns-encode-state buf)
	   (type (unsigned-byte 16) num))
  (with-slots (packet-buf) buf
    (vector-push-extend (ldb (byte 8 8) num) packet-buf)
    (vector-push-extend (ldb (byte 8 0) num) packet-buf)))

(defun encode-uint-32 (buf num)
  (declare (type dns-encode-state buf)
	   (type (unsigned-byte 32) num))
  (with-slots (packet-buf) buf
    (vector-push-extend (ldb (byte 8 24) num) packet-buf)
    (vector-push-extend (ldb (byte 8 16) num) packet-buf)
    (vector-push-extend (ldb (byte 8 8) num) packet-buf)
    (vector-push-extend (ldb (byte 8 0) num) packet-buf)))

(defun encode-bytes (buf bytes)
  (declare (type dns-encode-state buf)
	   (type (array (unsigned-byte 8)) bytes))
  (with-slots (packet-buf) buf
    (dotimes (i (length bytes) (values))
      (vector-push-extend (elt bytes i) packet-buf))))

(defun encode-domain-name (buf name)
  (declare (type dns-encode-state buf)
	   (type list name))
  (with-slots (packet-buf prev-names) buf
    (labels ((encode-label (name)
	       (let ((prev (find name prev-names :key 'first :test 'equal)))
		 (cond ((null name)
			(encode-uint-8 buf 0))
		       (prev
			(encode-uint-16 buf (+ #xc000 (cdr prev))))
		       (t
			(when (< (length packet-buf) 16384)
			  (push (cons name (length packet-buf)) prev-names))
			(let ((encoded (charcode:encode-string (car name) :ascii)))
			  (unless (< (length encoded) 64)
			    (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
			  (encode-uint-8 buf (length encoded))
			  (encode-bytes buf encoded))
			(encode-label (cdr name)))))))
      (encode-label name))))

(defun encode-dns-query (buf query)
  (declare (type dns-encode-state buf)
	   (type resource-query query))
  (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
    (encode-domain-name buf (slot-value query 'name))
    (encode-uint-16 buf (second (second desc)))
    (encode-uint-16 buf (first (second desc)))))

(defun encode-dns-record (buf record)
  (declare (type dns-encode-state buf)
	   (type resource-record record))
  (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
    (encode-domain-name buf (slot-value record 'name))
    (encode-uint-16 buf (second (second desc)))
    (encode-uint-16 buf (first (second desc)))
    (encode-uint-32 buf (slot-value record 'ttl))
    (with-slots (packet-buf) buf
      (let ((orig-off (length packet-buf)))
	(encode-uint-16 buf 0)
	(dolist (slot-desc (third desc))
	  (destructuring-bind (slot-name type) slot-desc
	    (let ((val (slot-value record slot-name)))
	      (ecase type
		((uint-16) (encode-uint-16 buf val))
		((uint-32) (encode-uint-32 buf val))
		((domain-name) (encode-domain-name buf val))
		((text) (let ((data (etypecase val
				      (string (charcode:encode-string val :ascii))
				      ((array (unsigned-byte 8)) val))))
			  (unless (< (length data) 256)
			    (error "DNS text data length cannot exceed 255 octets."))
			  (encode-uint-8 buf (length data))
			  (encode-bytes buf data)))
		((ipv4-address)
		 (check-type val ipv4-host-address)
		 (encode-bytes buf (slot-value val 'host-bytes)))
		((ipv6-address)
		 (check-type val ipv6-host-address)
		 (encode-bytes buf (slot-value val 'host-bytes)))))))
	(let ((dlen (- (length packet-buf) orig-off)))
	  (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
		(aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))

(defun encode-dns-packet (buf packet)
  (declare (type dns-encode-state buf)
	   (type dns-packet packet))
  (with-slots (txid is-response opcode authoritative truncated
		    recurse will-recurse resp-code
		    queries answers authority additional) packet
    (encode-uint-16 buf txid)
    (let ((flags 0))
      (setf (ldb (byte 1 15) flags) (if is-response 1 0)
	    (ldb (byte 4 11) flags) (ecase opcode
				      ((:query) 0)
				      ((:iquery) 1)
				      ((:status) 2))
	    (ldb (byte 1 10) flags) (if authoritative 1 0)
	    (ldb (byte 1 9) flags) (if truncated 1 0)
	    (ldb (byte 1 8) flags) (if recurse 1 0)
	    (ldb (byte 1 7) flags) (if will-recurse 1 0)
	    (ldb (byte 4 0) flags) (ecase resp-code
				     ((:success) 0)
				     ((:format-error) 1)
				     ((:server-failure) 2)
				     ((:name-error) 3)
				     ((:not-implemented) 4)
				     ((:refused) 5)))
      (encode-uint-16 buf flags))
    (encode-uint-16 buf (length queries))
    (encode-uint-16 buf (length answers))
    (encode-uint-16 buf (length authority))
    (encode-uint-16 buf (length additional))
    (dolist (query queries)
      (encode-dns-query buf query))
    (dolist (rr answers)
      (encode-dns-record buf rr))
    (dolist (rr authority)
      (encode-dns-record buf rr))
    (dolist (rr additional)
      (encode-dns-record buf rr)))
  (values))

(defun dns-encode (packet)
  (check-type packet dns-packet)
  (let ((buf (make-dns-encode-state)))
    (encode-dns-packet buf packet)
    (slot-value buf 'packet-buf)))

;;; DN format

(defun parse-domain-name (name)
  (declare (type string name))
  (let ((l '())
	(p 0))
    (loop (let ((p2 (position #\. name :start p)))
	    (if p2
		(if (= p2 (1- (length name)))
		    (return (values l t))
		    (setf l (append l (list (subseq name p p2)))
			  p (1+ p2)))
		(return (values (append l (list (subseq name p))) nil)))))))

(defun unparse-domain-name (name)
  (declare (type list name))
  (let ((buf nil))
    (dolist (label name buf)
      (setf buf (if buf
		    (concatenate 'string buf "." label)
		    label)))))

;;; Basic communication

(defun dns-do-request (server packet)
  (declare (type address server)
	   (type dns-packet packet))
  (with-connection (sk server)
    (socket-send sk (dns-encode packet))
    (loop
       (let ((resp (dns-decode (socket-recv sk))))
	 (when (= (dns-packet-txid resp)
		(dns-packet-txid packet))
	   (return resp))))))

(defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
  (let ((qlist (map 'list #'(lambda (o)
			      (let ((name (first o))
				    (type (second o)))
				(make-instance 'resource-query
					       :name (etypecase name
						       (string (parse-domain-name name))
						       (list name))
					       :type type)))
		    queries)))
    (make-dns-packet :txid txid
		     :recurse recurse
		     :queries qlist)))

;;; Misc.

(defmethod print-object ((q resource-query) stream)
  (with-slots (name type) q
    (if *print-readably*
	(format stream "~A: ~A" type (unparse-domain-name name))
	(format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
Commit	Line	Data
267b03c0 FT	1	;;;; DNS implementation for COMMON-NET
	2
	3	(in-package :common-net)
	4
	5	(defstruct dns-packet
	6	(txid (random 65536) :type (unsigned-byte 16))
	7	(is-response nil)
	8	(opcode :query :type (member :query :iquery :status))
	9	(authoritative nil)
	10	(truncated nil)
	11	(recurse nil)
	12	(will-recurse nil)
	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))
	18
	19	(defclass resource-query ()
	20	((name :initarg :name)
	21	(type :initarg :type)))
	22
	23	(defclass resource-record ()
	24	((name :initarg :name)
	25	(ttl :initarg :ttl)))
	26
	27	(defvar rr-coding-types '())
	28
	29	(defmacro define-rr-type (name class type slots)
	30	(let ((format (mapcar #'(lambda (slot)
	31	(list* (if (listp (car slot))
	32	(caar slot)
	33	(car slot))
	34	(cdr slot)))
	35	slots))
	36	(slot-desc (mapcar #'car slots)))
	37	`(progn
	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))))))
	41
	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
	49	((mname domain-name)
	50	(rname domain-name)
	51	(serial uint-32)
	52	(refresh uint-32)
	53	(retry uint-32)
	54	(expire uint-32)))
	55	(define-rr-type ptr-record #x1 #xc
	56	((pointed domain-name)))
	57	(define-rr-type mx-record #x1 #xf
	58	((prio uint-16)
	59	(mail-host domain-name)))
	60	(define-rr-type txt-record #x1 #x10
	61	((text text)))
	62	(define-rr-type aaaa-record #x1 #x1c
	63	((address ipv6-address)))
	64	(define-rr-type srv-record #x1 #x21
65	((prio uint-16)
66	(weigth uint-16)
67	(port uint-16)
68	(host-name domain-name)))
69
70	;;; Packet decoding logic
71
72	(defstruct dns-decode-state
73	(packet nil :type (array (unsigned-byte 8)))
74	(pos 0 :type (mod 65536))
75	(prev-names '() :type list))
76
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) ())
81
82	(defun simple-dns-decode-error (packet format &rest args)
83	(error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
84
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)
91	(incf pos))))
92
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)."))
98	(prog1
99	(+ (* (aref packet pos) 256)
100	(aref packet (1+ pos)))
101	(incf pos 2))))
102
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)."))
108	(prog1
109	(+ (* (aref packet pos) #x1000000)
110	(* (aref packet (+ pos 1)) #x10000)
111	(* (aref packet (+ pos 2)) #x100)
112	(aref packet (+ pos 3)))
426521e7	113	(incf pos 4))))
267b03c0 FT	114
	115	(defun decode-domain-name (buf)
	116	(declare (type dns-decode-state buf))
426521e7 FT	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)
	121	((0)
	122	(if (zerop len)
	123	'()
	124	(with-slots (packet pos) buf
	125	(let* ((label (prog1
	126	(handler-bind
	127	((charcode:coding-error
	128	(lambda (c)
	129	(declare (ignore c))
	130	(simple-dns-decode-error buf "DNS label was not ASCII."))))
	131	(charcode:decode-string (subseq packet
	132	pos (+ pos len))
	133	:ascii))
	134	(incf pos len)))
	135	(decoded (append (list label) (decode-label))))
	136	(push (cons orig-off decoded) (slot-value buf 'prev-names))
	137	decoded))))
	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))))
	141	(unless prev
	142	(simple-dns-decode-error buf "Domain name label pointed to non-label position."))
	143	(cdr prev)))
	144	(t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
	145	(decode-label)))
267b03c0 FT	146
	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)))
	153	(if desc
	154	(make-instance 'resource-query :name name :type (first desc))
	155	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
	156	nil))))
	157
	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."))
	169	(if desc
	170	(let ((orig-off (dns-decode-state-pos buf))
	171	(rr (make-instance (first desc)
	172	:name name
	173	:ttl ttl)))
	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
	178	(ecase type
	179	((uint-16) (decode-uint-16 buf))
	180	((uint-32) (decode-uint-32 buf))
	181	((domain-name) (decode-domain-name buf))
	182	((text)
	183	(let ((len (decode-uint-8 buf)))
	184	(prog1 (subseq packet pos (+ pos len))
	185	(incf pos len))))
	186	((ipv4-address)
	187	(prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
	188	(incf pos 4)))
	189	((ipv6-address)
	190	(prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
	191	(incf 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."))
	194	rr)
	195	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
	196	(incf (dns-decode-state-pos buf) dlen)
	197	nil))))
	198
	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)
210	((0) :query)
211	((1) :iquery)
212	((2) :status)
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)
219	((0) :success)
220	((1) :format-error)
221	((2) :server-failure)
222	((3) :name-error)
223	((4) :not-implemented)
224	((5) :refused)
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
227	(dotimes (i qnum)
228	(setf queries (append queries (list (decode-dns-query buf)))))
229	(dotimes (i ansnum)
230	(setf answers (append answers (list (decode-dns-record buf)))))
231	(dotimes (i autnum)
232	(setf authority (append authority (list (decode-dns-record buf)))))
233	(dotimes (i auxnum)
234	(setf additional (append additional (list (decode-dns-record buf))))))
235	packet))
236
237	(defun dns-decode (packet)
238	(decode-dns-packet (make-dns-decode-state :packet packet)))
239
240	;;; Packet encoding logic
241
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))
245
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)))
251
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)))
258
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)))
267
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))))
274
275	(defun encode-domain-name (buf name)
276	(declare (type dns-encode-state buf)
277	(type list name))
278	(with-slots (packet-buf prev-names) buf
279	(labels ((encode-label (name)
280	(let ((prev (find name prev-names :key 'first :test 'equal)))
281	(cond ((null name)
282	(encode-uint-8 buf 0))
283	(prev
284	(encode-uint-16 buf (+ #xc000 (cdr prev))))
285	(t
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))))
295
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)))))
303
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)))
318	(ecase type
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)))
329	((ipv4-address)
330	(check-type val ipv4-host-address)
331	(encode-bytes buf (slot-value val 'host-bytes)))
332	((ipv6-address)
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)))))))
338
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)
346	(let ((flags 0))
347	(setf (ldb (byte 1 15) flags) (if is-response 1 0)
348	(ldb (byte 4 11) flags) (ecase opcode
349	((:query) 0)
350	((:iquery) 1)
351	((:status) 2))
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
357	((:success) 0)
358	((:format-error) 1)
359	((:server-failure) 2)
360	((:name-error) 3)
361	((:not-implemented) 4)
362	((:refused) 5)))
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))
370	(dolist (rr answers)
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)))
376	(values))
377
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)))
b466cd48 FT	383
	384	;;; DN format
	385
	386	(defun parse-domain-name (name)
	387	(declare (type string name))
	388	(let ((l '())
	389	(p 0))
	390	(loop (let ((p2 (position #\. name :start p)))
	391	(if p2
	392	(if (= p2 (1- (length name)))
	393	(return (values l t))
	394	(setf l (append l (list (subseq name p p2)))
	395	p (1+ p2)))
	396	(return (values (append l (list (subseq name p))) nil)))))))
	397
	398	(defun unparse-domain-name (name)
	399	(declare (type list name))
	400	(let ((buf nil))
	401	(dolist (label name buf)
	402	(setf buf (if buf
	403	(concatenate 'string buf "." label)
	404	label)))))
	405
0818ef99 FT	406	;;; Basic communication
	407
	408	(defun dns-do-request (server packet)
	409	(declare (type address server)
	410	(type dns-packet packet))
	411	(with-connection (sk server)
	412	(socket-send sk (dns-encode packet))
	413	(loop
	414	(let ((resp (dns-decode (socket-recv sk))))
	415	(when (= (dns-packet-txid resp)
	416	(dns-packet-txid packet))
	417	(return resp))))))
	418
	419	(defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
	420	(let ((qlist (map 'list #'(lambda (o)
	421	(let ((name (first o))
	422	(type (second o)))
	423	(make-instance 'resource-query
	424	:name (etypecase name
	425	(string (parse-domain-name name))
	426	(list name))
	427	:type type)))
	428	queries)))
	429	(make-dns-packet :txid txid
	430	:recurse recurse
	431	:queries qlist)))
	432
b466cd48 FT	433	;;; Misc.
	434
	435	(defmethod print-object ((q resource-query) stream)
	436	(with-slots (name type) q
	437	(if print-readably
	438	(format stream "~A: ~A" type (unparse-domain-name name))
	439	(format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
	440