1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2006, 2007 Stelian Ionescu
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the
9 ;; preamble found here:
10 ;; http://opensource.franz.com/preamble.html
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU Lesser General
18 ;; Public License along with this library; if not, write to the
19 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
20 ;; Boston, MA 02110-1301, USA
22 (in-package :net.sockets
)
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;; CLASS DEFINITIONS ;;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (defclass dns-message
()
31 ((id :initform
0 :initarg
:id
:accessor dns-message-id
)
32 (flags :initform
0 :initarg
:flags
:accessor dns-message-flags
)
33 (decoded-flags :reader decoded-flags
)
34 (qdcount :initarg
:qdcount
:reader dns-message-question-count
)
35 (ancount :initarg
:ancount
:reader dns-message-answer-count
)
36 (nscount :initarg
:nscount
:reader dns-message-authority-count
)
37 (arcount :initarg
:arcount
:reader dns-message-additional-count
)
38 (question :reader dns-message-question
)
39 (answer :reader dns-message-answer
)
40 (authority :reader dns-message-authority
)
41 (additional :reader dns-message-additional
))
42 (:default-initargs
:qdcount
1 :ancount
0 :nscount
0 :arcount
0))
44 (defmacro define-flags-bitfield
(name offset length
&optional
(type :integer
))
45 (let ((method-name (concat-symbol name
:-field
)))
47 (defgeneric ,method-name
(message))
48 (defmethod ,method-name
((message dns-message
))
50 (:integer
`(ldb (byte ,length
,offset
) (dns-message-flags message
)))
51 (:boolean
`(logbitp ,offset
(dns-message-flags message
)))
53 (ldb (byte ,length
,offset
) (dns-message-flags message
))))))
54 (defgeneric (setf ,method-name
) (value message
))
55 (defmethod (setf ,method-name
) (value (message dns-message
))
57 (:integer
`(setf (ldb (byte ,length
,offset
) (dns-message-flags message
))
59 (:boolean
`(setf (ldb (byte ,length
,offset
) (dns-message-flags message
))
60 (lisp->c-bool value
)))
61 (:rcode
`(setf (ldb (byte ,length
,offset
) (dns-message-flags message
))
62 (rcode-number value
))))))))
64 (define-flags-bitfield response
15 1 :boolean
)
65 (define-flags-bitfield opcode
11 4 :integer
)
66 (define-flags-bitfield authoritative
10 1 :boolean
)
67 (define-flags-bitfield truncated
9 1 :boolean
)
68 (define-flags-bitfield recursion-desired
8 1 :boolean
)
69 (define-flags-bitfield recursion-available
7 1 :boolean
)
70 (define-flags-bitfield rcode
0 4 :rcode
)
72 (defgeneric decode-flags
(message))
73 (defmethod decode-flags ((msg dns-message
))
75 (push (if (response-field msg
) :response
:query
) flags
)
76 (push (if (eql (opcode-field msg
) +opcode-standard
+)
77 :opcode-standard
:opcode-unknown
)
79 (when (authoritative-field msg
) (push :authoritative flags
))
80 (when (truncated-field msg
) (push :truncated flags
))
81 (when (recursion-desired-field msg
) (push :recursion-desired flags
))
82 (when (recursion-available-field msg
) (push :recursion-available flags
))
83 (push (or (rcode-field msg
) :rcode-unknown
) flags
)
86 (defmethod initialize-instance :after
((msg dns-message
) &key
87 (qdcount 0) (ancount 0)
88 (nscount 0) (arcount 0))
89 (with-slots (id flags decoded-flags question answer authority additional
) msg
90 (setf decoded-flags
(decode-flags msg
))
91 (setf question
(make-array qdcount
:adjustable t
:fill-pointer
0))
92 (setf answer
(make-array ancount
:adjustable t
:fill-pointer
0))
93 (setf authority
(make-array nscount
:adjustable t
:fill-pointer
0))
94 (setf additional
(make-array arcount
:adjustable t
:fill-pointer
0))))
96 (defclass dns-record
()
97 ((name :initarg
:name
:accessor dns-record-name
)
98 (type :initarg
:type
:accessor dns-record-type
)
99 (class :initarg
:class
:accessor dns-record-class
)))
101 (defmethod initialize-instance :after
((record dns-record
) &key
)
102 (with-slots (name type class
) record
103 (check-type name string
"a string")
104 (check-type type
(satisfies valid-type-p
) "a valid record type")
105 (check-type class
(member :in
) "a valid record class")))
107 (defclass dns-question
(dns-record) ())
109 (defmethod initialize-instance :after
((record dns-question
) &key
)
110 (with-slots (name) record
111 (let ((name-length (length name
)))
112 (when (char-not-equal (aref name
(1- name-length
))
114 (setf name
(concatenate 'string name
(string #\.
)))))))
117 ;;;;;;;;;;;;;;;;;;;;;;
121 ;;;;;;;;;;;;;;;;;;;;;;
123 (defun make-question (qname qtype qclass
)
124 (make-instance 'dns-question
129 (defun make-query (id question
&optional recursion-desired
)
130 (let ((msg (make-instance 'dns-message
:id id
)))
131 (setf (opcode-field msg
) +opcode-standard
+)
132 (setf (recursion-desired-field msg
) recursion-desired
)
133 (vector-push-extend question
(dns-message-question msg
))
137 ;;;;;;;;;;;;;;;;;;;;;;;
139 ;;; OUTPUT-RECORD ;;;
141 ;;;;;;;;;;;;;;;;;;;;;;;
143 (defgeneric write-dns-string
(buffer string
))
144 (defmethod write-dns-string ((buffer dynamic-output-buffer
)
146 (write-unsigned-8 buffer
(length string
))
147 (write-vector buffer
(io.encodings
:string-to-octets string
)))
149 (defun domain-name-to-dns-format (domain-name)
150 (let* ((octets (io.encodings
:string-to-octets domain-name
))
151 (tmp-vec (make-array (1+ (length octets
))
152 :element-type
'octet
)))
153 (replace tmp-vec octets
:start1
1)
154 (let ((vector-length (length tmp-vec
)))
156 :for start-off
:= 1 then
(1+ end-off
)
157 :for end-off
:= (or (position (char-code #\.
) tmp-vec
:start start-off
)
159 :do
(setf (aref tmp-vec
(1- start-off
)) (- end-off start-off
))
160 :when
(>= end-off vector-length
) :do
(loop-finish)))
163 (defgeneric write-domain-name
(buffer name
))
164 (defmethod write-domain-name ((buffer dynamic-output-buffer
)
165 (domain-name string
))
166 (write-vector buffer
(domain-name-to-dns-format domain-name
)))
168 (defgeneric write-record
(buffer record
))
169 (defmethod write-record ((buffer dynamic-output-buffer
)
170 (record dns-question
))
171 (with-slots (name type class
) record
172 (write-domain-name buffer name
)
173 (write-unsigned-16 buffer
(query-type-number type
))
174 (write-unsigned-16 buffer
(query-class-number class
))))
176 (defgeneric write-message-header
(buffer message
))
177 (defmethod write-message-header ((buffer dynamic-output-buffer
)
178 (message dns-message
))
179 (with-slots (id flags question answer authority additional
)
181 (write-unsigned-16 buffer id
)
182 (write-unsigned-16 buffer flags
)
183 (write-unsigned-16 buffer
(length question
))
184 (write-unsigned-16 buffer
(length answer
))
185 (write-unsigned-16 buffer
(length authority
))
186 (write-unsigned-16 buffer
(length additional
))))
188 (defgeneric write-dns-message
(message))
189 (defmethod write-dns-message ((message dns-message
))
190 (with-slots (question) message
191 (with-output-buffer buffer
192 (write-message-header buffer message
)
193 (write-record buffer
(aref question
0)))))