1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; message.lisp --- DNS message creation.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :net.sockets
)
26 (defclass dns-message
()
27 ((id :initform
0 :initarg
:id
:accessor dns-message-id
)
28 (flags :initform
0 :initarg
:flags
:accessor dns-message-flags
)
29 (decoded-flags :initform nil
:accessor dns-message-decoded-flags
)
30 (qdcount :initarg
:qdcount
:accessor dns-message-question-count
)
31 (ancount :initarg
:ancount
:accessor dns-message-answer-count
)
32 (nscount :initarg
:nscount
:accessor dns-message-authority-count
)
33 (arcount :initarg
:arcount
:accessor dns-message-additional-count
)
34 (question :accessor dns-message-question
)
35 (answer :accessor dns-message-answer
)
36 (authority :accessor dns-message-authority
)
37 (additional :accessor dns-message-additional
))
38 (:default-initargs
:qdcount
1 :ancount
0 :nscount
0 :arcount
0))
40 (defmacro define-flags-bitfield
(name offset length
&optional
(type :integer
))
41 (let ((method-name (format-symbol t
"~A-FIELD" name
)))
43 (defgeneric ,method-name
(message)
44 (:method
((message dns-message
))
46 (:integer
`(ldb (byte ,length
,offset
)
47 (dns-message-flags message
)))
48 (:boolean
`(logbitp ,offset
(dns-message-flags message
)))
50 (ldb (byte ,length
,offset
)
51 (dns-message-flags message
)))))))
52 (defgeneric (setf ,method-name
) (value message
)
53 (:method
(value (message dns-message
))
55 (:integer
`(setf (ldb (byte ,length
,offset
)
56 (dns-message-flags message
))
58 (:boolean
`(setf (ldb (byte ,length
,offset
)
59 (dns-message-flags message
))
60 (lisp->c-bool value
)))
61 (:rcode
`(setf (ldb (byte ,length
,offset
)
62 (dns-message-flags message
))
63 (rcode-number value
)))))))))
65 (define-flags-bitfield response
15 1 :boolean
)
66 (define-flags-bitfield opcode
11 4 :integer
)
67 (define-flags-bitfield authoritative
10 1 :boolean
)
68 (define-flags-bitfield truncated
9 1 :boolean
)
69 (define-flags-bitfield recursion-desired
8 1 :boolean
)
70 (define-flags-bitfield recursion-available
7 1 :boolean
)
71 (define-flags-bitfield rcode
0 4 :rcode
)
73 (defgeneric decode-flags
(message)
74 (:method
((msg dns-message
))
76 (push (if (= (opcode-field msg
) +opcode-standard
+)
79 (when (authoritative-field msg
) (push :auth flags
))
80 (when (truncated-field msg
) (push :trunc flags
))
81 (when (recursion-desired-field msg
) (push :rd flags
))
82 (when (recursion-available-field msg
) (push :ra flags
))
83 (push (or (rcode-field msg
) :rc
/u
) flags
)
86 (defgeneric dns-flag-p
(message flag
)
87 (:method
((msg dns-message
) flag
)
88 (memq flag
(dns-message-decoded-flags msg
))))
90 (defmethod initialize-instance :after
((msg dns-message
) &key
91 (qdcount 0) (ancount 0)
92 (nscount 0) (arcount 0))
93 (with-accessors ((id dns-message-id
) (flags dns-message-flags
)
94 (decoded-flags dns-message-decoded-flags
)
95 (question dns-message-question
) (answer dns-message-answer
)
96 (authority dns-message-authority
) (additional dns-message-additional
))
98 (setf decoded-flags
(decode-flags msg
)
99 question
(make-array qdcount
:adjustable t
:fill-pointer
0)
100 answer
(make-array ancount
:adjustable t
:fill-pointer
0)
101 authority
(make-array nscount
:adjustable t
:fill-pointer
0)
102 additional
(make-array arcount
:adjustable t
:fill-pointer
0))))
104 (defmethod print-object ((msg dns-message
) stream
)
105 (print-unreadable-object (msg stream
:type nil
:identity nil
)
106 (with-accessors ((id dns-message-id
) (decoded-flags dns-message-decoded-flags
)
107 (question dns-message-question
)
108 (qdcount dns-message-question-count
) (ancount dns-message-answer-count
)
109 (nscount dns-message-authority-count
) (arcount dns-message-additional-count
))
111 (format stream
"DNS ~A Id: ~A, Question: ~A Flags: ~S, Sections: QD(~A) AN(~A) NS(~A) AD(~A)"
112 (if (response-field msg
) :response
:query
)
113 id question decoded-flags
114 qdcount ancount nscount arcount
))))
116 (defclass dns-record
()
117 ((name :initarg
:name
:accessor dns-record-name
)
118 (type :initarg
:type
:accessor dns-record-type
)
119 (class :initarg
:class
:accessor dns-record-class
)))
121 (defmethod initialize-instance :after
((record dns-record
) &key
)
122 (with-accessors ((name dns-record-name
)
123 (type dns-record-type
)
124 (class dns-record-class
))
126 (check-type name string
"a string")
127 (check-type type
(satisfies dns-record-type-p
) "a valid record type")
128 (check-type class
(member :in
) ":IN")))
130 (defclass dns-question
(dns-record) ())
132 (defmethod print-object ((question dns-question
) stream
)
133 (print-unreadable-object (question stream
:type nil
:identity nil
)
134 (with-accessors ((name dns-record-name
)
135 (type dns-record-type
)
136 (class dns-record-class
))
138 (format stream
"~S ~A ~A" name type class
))))
140 (defmethod initialize-instance :after
((record dns-question
) &key
)
141 (with-accessors ((name dns-record-name
)) record
142 (let ((name-length (length name
)))
143 (when (char/= #\.
(aref name
(1- name-length
)))
144 (setf name
(concatenate 'string name
"."))))))
148 (defun make-question (qname qtype qclass
)
149 (make-instance 'dns-question
154 (defun make-query (id question
&optional recursion-desired
)
155 (let ((msg (make-instance 'dns-message
:id id
)))
156 (setf (opcode-field msg
) +opcode-standard
+)
157 (setf (recursion-desired-field msg
) recursion-desired
)
158 (vector-push-extend question
(dns-message-question msg
))
163 (defgeneric write-dns-string
(buffer string
)
164 (:method
((buffer dynamic-buffer
) (string string
))
165 (write-ub8 buffer
(length string
))
166 ;; Probably want to use punnycode here.
167 (write-vector buffer
(babel:string-to-octets string
:encoding
:ascii
))))
169 (defun domain-name-to-dns-format (domain-name)
170 (let* ((octets (babel:string-to-octets domain-name
:encoding
:ascii
))
171 (tmp-vec (make-array (1+ (length octets
)) :element-type
'ub8
)))
172 (replace tmp-vec octets
:start1
1)
173 (let ((vector-length (length tmp-vec
)))
174 (loop :for start-off
:= 1 :then
(1+ end-off
)
175 :for end-off
:= (or (position (char-code #\.
) tmp-vec
178 :do
(setf (aref tmp-vec
(1- start-off
)) (- end-off start-off
))
179 :when
(>= end-off vector-length
) do
(loop-finish)))
182 (defgeneric write-domain-name
(buffer name
)
183 (:method
((buffer dynamic-buffer
)
184 (domain-name string
))
185 (write-vector buffer
(domain-name-to-dns-format domain-name
))))
187 (defgeneric write-record
(buffer record
)
188 (:method
((buffer dynamic-buffer
)
189 (record dns-question
))
190 (with-accessors ((name dns-record-name
)
191 (type dns-record-type
)
192 (class dns-record-class
))
194 (write-domain-name buffer name
)
195 (write-ub16 buffer
(query-type-number type
))
196 (write-ub16 buffer
(query-class-number class
)))))
198 (defgeneric write-message-header
(buffer message
)
199 (:method
((buffer dynamic-buffer
)
200 (message dns-message
))
201 (with-accessors ((id dns-message-id
) (flags dns-message-flags
)
202 (question dns-message-question
) (answer dns-message-answer
)
203 (authority dns-message-authority
) (additional dns-message-additional
))
205 (write-ub16 buffer id
)
206 (write-ub16 buffer flags
)
207 (write-ub16 buffer
(length question
))
208 (write-ub16 buffer
(length answer
))
209 (write-ub16 buffer
(length authority
))
210 (write-ub16 buffer
(length additional
)))))
212 (defgeneric write-dns-message
(message)
213 (:method
((message dns-message
))
214 (with-accessors ((question dns-message-question
)) message
215 (with-dynamic-buffer (buffer)
216 (write-message-header buffer message
)
217 (write-record buffer
(aref question
0))))))
219 ;;;; Resource Record Encoding
221 (defclass dns-rr
(dns-record)
222 ((ttl :initarg
:ttl
:accessor dns-rr-ttl
)
223 (data :initarg
:data
:accessor dns-rr-data
)))
225 (defmethod print-object ((rr dns-rr
) stream
)
226 (print-unreadable-object (rr stream
:type nil
:identity nil
)
227 (with-accessors ((name dns-record-name
) (type dns-record-type
)
228 (class dns-record-class
) (ttl dns-rr-ttl
)
231 (format stream
"~S ~A ~A: ~A" name type class
234 (defmethod initialize-instance :after
((rr dns-rr
) &key
)
235 (with-accessors ((ttl dns-rr-ttl
)) rr
236 (check-type ttl
(unsigned-byte 32) "a valid TTL")))
238 (defgeneric add-question
(message question
)
239 (:method
((message dns-message
)
240 (question dns-question
))
241 (vector-push-extend question
(dns-message-question message
))))
243 (defgeneric add-answer-rr
(message record
)
244 (:method
((message dns-message
)
246 (vector-push-extend record
(dns-message-answer message
))))
248 (defgeneric add-authority-rr
(message record
)
249 (:method
((message dns-message
)
251 (vector-push-extend record
(dns-message-authority message
))))
253 (defgeneric add-additional-rr
(message record
)
254 (:method
((message dns-message
)
256 (vector-push-extend record
(dns-message-additional message
))))
259 (define-condition dns-message-error
(error) ()
261 "Signaled when a format error is encountered while parsing a DNS message"))
263 (defgeneric read-dns-string
(buffer)
264 (:method
((buffer dynamic-buffer
))
265 (let ((length (read-ub8 buffer
)))
266 (babel:octets-to-string
(read-vector buffer length
) :encoding
:ascii
))))
268 (defun read-dns-pointer-recursively (sequence position
270 (when (or (<= depth
0) ; too deep recursion
271 (>= position
(length sequence
))) ; invalid offset
272 (error 'dns-message-error
))
273 (let* ((value (aref sequence position
))
274 (ms2bits (logand value
#xC0
)))
276 ;; it's not a pointer
277 ((zerop ms2bits
) (cons position
(< depth
5)))
280 ;; there must be at least two bytes to read
281 (when (>= position
(1+ (length sequence
)))
282 (error 'dns-message-error
))
283 (read-dns-pointer-recursively
285 (logand (read-ub16-from-vector sequence position
)
288 ;; the most significant 2 bits are either 01 or 10
289 (t (error 'dns-message-error
)))))
291 (defun join (delimiter strings
)
292 (collect-append 'string
(spread (catenate #Z
(0) (series 1))
294 (string delimiter
))))
296 (defgeneric dns-domain-name-to-string
(buffer)
297 (:method
((buffer dynamic-buffer
))
298 (let (string offset pointer-seen
)
299 (labels ((%deref-dns-string
(pointer rec
)
300 (when (not pointer-seen
)
302 (setf pointer-seen t
)
303 (setf offset
(+ (read-cursor-of buffer
) 2)))
305 (setf offset
(+ (read-cursor-of buffer
) 1)))))
306 (dynamic-buffer-seek-read-cursor buffer
:offset pointer
)
307 (setf string
(read-dns-string buffer
)))
309 (loop :for
(pointer . rec
) := (read-dns-pointer-recursively
311 (read-cursor-of buffer
))
312 :do
(%deref-dns-string pointer rec
)
314 :until
(string= string
""))))
315 (values (join "." (%read-tags
)) offset
)))))
317 (defgeneric read-domain-name
(buffer)
318 (:method
((buffer dynamic-buffer
))
319 (multiple-value-bind (string offset
)
320 (dns-domain-name-to-string buffer
)
321 (dynamic-buffer-seek-read-cursor buffer
:offset offset
)
324 (defgeneric read-question
(buffer)
325 (:method
((buffer dynamic-buffer
))
326 (let ((name (read-domain-name buffer
))
327 (type (query-type-id (read-ub16 buffer
)))
328 (class (query-class-id (read-ub16 buffer
))))
329 (make-question name type class
))))
331 (defgeneric read-rr-data
(buffer type class
&optional length
))
333 (defmethod read-rr-data ((buffer dynamic-buffer
)
334 (type (eql :a
)) (class (eql :in
))
335 &optional resource-length
)
336 (unless (= resource-length
4)
337 (error 'dns-message-error
))
338 (let ((address (make-array 4 :element-type
'ub8
)))
340 (setf (aref address i
) (read-ub8 buffer
)))
343 (defmethod read-rr-data ((buffer dynamic-buffer
)
344 (type (eql :aaaa
)) (class (eql :in
))
345 &optional resource-length
)
346 (unless (= resource-length
16)
347 (error 'dns-message-error
))
348 (let ((address (make-array 8 :element-type
'(unsigned-byte 16))))
350 (setf (aref address i
) (read-ub16 buffer
)))
353 (defmethod read-rr-data ((buffer dynamic-buffer
)
354 (type (eql :cname
)) (class (eql :in
))
355 &optional resource-length
)
356 (declare (ignore resource-length
))
357 (read-domain-name buffer
)) ; CNAME
359 (defmethod read-rr-data ((buffer dynamic-buffer
)
360 (type (eql :hinfo
)) (class (eql :in
))
361 &optional resource-length
)
362 (declare (ignore resource-length
))
363 (list (read-dns-string buffer
) ; CPU
364 (read-dns-string buffer
))) ; OS
366 (defmethod read-rr-data ((buffer dynamic-buffer
)
367 (type (eql :mx
)) (class (eql :in
))
368 &optional resource-length
)
369 (declare (ignore resource-length
))
370 (list (read-ub16 buffer
) ; PREFERENCE
371 (read-domain-name buffer
))) ; EXCHANGE
373 (defmethod read-rr-data ((buffer dynamic-buffer
)
374 (type (eql :ns
)) (class (eql :in
))
375 &optional resource-length
)
376 (declare (ignore resource-length
))
377 (read-domain-name buffer
)) ; NSDNAME
379 (defmethod read-rr-data ((buffer dynamic-buffer
)
380 (type (eql :ptr
)) (class (eql :in
))
381 &optional resource-length
)
382 (declare (ignore resource-length
))
383 (read-domain-name buffer
)) ; PTRDNAME
385 (defmethod read-rr-data ((buffer dynamic-buffer
)
386 (type (eql :soa
)) (class (eql :in
))
387 &optional resource-length
)
388 (declare (ignore type class resource-length
))
389 (list (read-domain-name buffer
) ; MNAME
390 (read-domain-name buffer
) ; RNAME
391 (read-ub32 buffer
) ; SERIAL
392 (read-ub32 buffer
) ; REFRESH
393 (read-ub32 buffer
) ; RETRY
394 (read-ub32 buffer
) ; EXPIRE
395 (read-ub32 buffer
))) ; MINIMUM
397 (defmethod read-rr-data ((buffer dynamic-buffer
)
398 (type (eql :txt
)) (class (eql :in
))
399 &optional resource-length
)
400 (declare (ignore type class
))
401 (loop :for string
:= (read-dns-string buffer
) ; TXT-DATA
402 :for total-length
:= (1+ (length string
))
403 :then
(+ total-length
1 (length string
))
405 :until
(>= total-length resource-length
)
406 :finally
(when (> total-length resource-length
)
407 (error 'dns-message-error
))))
409 (defmethod read-rr-data ((buffer dynamic-buffer
)
410 type class
&optional resource-length
)
411 (declare (ignore buffer type class resource-length
))
412 (error 'dns-message-error
))
414 (defgeneric read-dns-rr
(buffer)
415 (:method
((buffer dynamic-buffer
))
416 (let* ((name (read-domain-name buffer
))
417 (type (query-type-id (read-ub16 buffer
)))
418 (class (query-class-id (read-ub16 buffer
)))
419 (ttl (read-ub32 buffer
))
420 (rdlen (read-ub16 buffer
))
421 (rdata (read-rr-data buffer type class rdlen
)))
422 (make-instance 'dns-rr
429 (defgeneric read-message-header
(buffer)
430 (:method
((buffer dynamic-buffer
))
431 (let ((id (read-ub16 buffer
))
432 (flags (read-ub16 buffer
))
433 (qdcount (read-ub16 buffer
))
434 (ancount (read-ub16 buffer
))
435 (nscount (read-ub16 buffer
))
436 (arcount (read-ub16 buffer
)))
437 (make-instance 'dns-message
439 :qdcount qdcount
:ancount ancount
440 :nscount nscount
:arcount arcount
))))
442 (defgeneric read-dns-message
(buffer)
443 (:method
((buffer dynamic-buffer
))
444 (defparameter *msg
* buffer
)
445 (let ((msg (read-message-header buffer
)))
446 (with-accessors ((qdcount dns-message-question-count
)
447 (ancount dns-message-answer-count
)
448 (nscount dns-message-authority-count
)
449 (arcount dns-message-additional-count
))
451 (loop :for i
:below
(dns-message-question-count msg
)
452 :for q
:= (read-question buffer
)
453 :do
(add-question msg q
))
454 (loop :for i
:below
(dns-message-answer-count msg
)
455 :for rr
:= (read-dns-rr buffer
)
456 :do
(add-answer-rr msg rr
))
457 (loop :for i
:below
(dns-message-authority-count msg
)
458 :for rr
:= (read-dns-rr buffer
)
459 :do
(add-authority-rr msg rr
))
460 (loop :for i
:below
(dns-message-additional-count msg
)
461 :for rr
:= (read-dns-rr buffer
)
462 :do
(add-additional-rr msg rr
)))