[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 2))))

(defun decode-domain-name (buf)
  (declare (type dns-decode-state buf))
  (let* ((orig-off (dns-decode-state-pos buf))
	 (decoded (block decoded
		    (let ((l '()))
		      (loop (let ((len (decode-uint-8 buf)))
			      (case (ldb (byte 2 6) len)
				((0)
				 (when (zerop len)
				   (return-from decoded l))
				 (with-slots (packet pos) buf
				   (setf l (append l (list (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)))
				((3) (return-from decoded
				       (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"))
					 (append l (cdr prev)))))
				(t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))))))
    (push (cons orig-off decoded)
	  (slot-value buf 'prev-names))))

(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)))
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)))
113	(incf pos 2))))
114
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
119	(let ((l '()))
120	(loop (let ((len (decode-uint-8 buf)))
121	(case (ldb (byte 2 6) len)
122	((0)
123	(when (zerop len)
124	(return-from decoded l))
125	(with-slots (packet pos) buf
126	(setf l (append l (list (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	((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))))
139	(unless prev
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))))
145
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)))
152	(if desc
153	(make-instance 'resource-query :name name :type (first desc))
154	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
155	nil))))
156
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."))
168	(if desc
169	(let ((orig-off (dns-decode-state-pos buf))
170	(rr (make-instance (first desc)
171	:name name
172	:ttl ttl)))
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
177	(ecase type
178	((uint-16) (decode-uint-16 buf))
179	((uint-32) (decode-uint-32 buf))
180	((domain-name) (decode-domain-name buf))
181	((text)
182	(let ((len (decode-uint-8 buf)))
183	(prog1 (subseq packet pos (+ pos len))
184	(incf pos len))))
185	((ipv4-address)
186	(prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
187	(incf pos 4)))
188	((ipv6-address)
189	(prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
190	(incf 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."))
193	rr)
194	(progn (warn "Unknown DNS RR type: ~D, ~D" class type)
195	(incf (dns-decode-state-pos buf) dlen)
196	nil))))
197
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)
209	((0) :query)
210	((1) :iquery)
211	((2) :status)
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)
218	((0) :success)
219	((1) :format-error)
220	((2) :server-failure)
221	((3) :name-error)
222	((4) :not-implemented)
223	((5) :refused)
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
226	(dotimes (i qnum)
227	(setf queries (append queries (list (decode-dns-query buf)))))
228	(dotimes (i ansnum)
229	(setf answers (append answers (list (decode-dns-record buf)))))
230	(dotimes (i autnum)
231	(setf authority (append authority (list (decode-dns-record buf)))))
232	(dotimes (i auxnum)
233	(setf additional (append additional (list (decode-dns-record buf))))))
234	packet))
235
236	(defun dns-decode (packet)
237	(decode-dns-packet (make-dns-decode-state :packet packet)))
238
239	;;; Packet encoding logic
240
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))
244
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)))
250
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)))
257
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)))
266
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))))
273
274	(defun encode-domain-name (buf name)
275	(declare (type dns-encode-state buf)
276	(type list name))
277	(with-slots (packet-buf prev-names) buf
278	(labels ((encode-label (name)
279	(let ((prev (find name prev-names :key 'first :test 'equal)))
280	(cond ((null name)
281	(encode-uint-8 buf 0))
282	(prev
283	(encode-uint-16 buf (+ #xc000 (cdr prev))))
284	(t
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))))
294
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)))))
302
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)))
317	(ecase type
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)))
328	((ipv4-address)
329	(check-type val ipv4-host-address)
330	(encode-bytes buf (slot-value val 'host-bytes)))
331	((ipv6-address)
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)))))))
337
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)
345	(let ((flags 0))
346	(setf (ldb (byte 1 15) flags) (if is-response 1 0)
347	(ldb (byte 4 11) flags) (ecase opcode
348	((:query) 0)
349	((:iquery) 1)
350	((:status) 2))
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
356	((:success) 0)
357	((:format-error) 1)
358	((:server-failure) 2)
359	((:name-error) 3)
360	((:not-implemented) 4)
361	((:refused) 5)))
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))
369	(dolist (rr answers)
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)))
375	(values))
376
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)))