| 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 #'(lambda (slot) |
| 37 | (let ((name (car slot))) |
| 38 | `(,name :initarg ,(intern (symbol-name name) (find-package :keyword))))) slots))) |
| 39 | `(progn |
| 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))) |
| 43 | (export '(,name))))) |
| 44 | |
| 45 | (define-rr-type a-record #x1 #x1 |
| 46 | ((address ipv4-address))) |
| 47 | (define-rr-type ns-record #x1 #x2 |
| 48 | ((ns-name domain-name))) |
| 49 | (define-rr-type cname-record #x1 #x5 |
| 50 | ((cname domain-name))) |
| 51 | (define-rr-type soa-record #x1 #x6 |
| 52 | ((mname domain-name) |
| 53 | (rname domain-name) |
| 54 | (serial uint-32) |
| 55 | (refresh uint-32) |
| 56 | (retry uint-32) |
| 57 | (expire uint-32))) |
| 58 | (define-rr-type ptr-record #x1 #xc |
| 59 | ((pointed domain-name))) |
| 60 | (define-rr-type mx-record #x1 #xf |
| 61 | ((prio uint-16) |
| 62 | (mail-host domain-name))) |
| 63 | (define-rr-type txt-record #x1 #x10 |
| 64 | ((text text))) |
| 65 | (define-rr-type aaaa-record #x1 #x1c |
| 66 | ((address ipv6-address))) |
| 67 | (define-rr-type srv-record #x1 #x21 |
| 68 | ((prio uint-16) |
| 69 | (weigth uint-16) |
| 70 | (port uint-16) |
| 71 | (host-name domain-name))) |
| 72 | |
| 73 | (export '(resource-record)) |
| 74 | |
| 75 | ;;; Packet decoding logic |
| 76 | |
| 77 | (defstruct dns-decode-state |
| 78 | (packet nil :type (array (unsigned-byte 8))) |
| 79 | (pos 0 :type (mod 65536)) |
| 80 | (prev-names '() :type list)) |
| 81 | |
| 82 | (define-condition dns-error (network-error) ()) |
| 83 | (define-condition dns-decode-error (dns-error) |
| 84 | ((packet :initarg :packet))) |
| 85 | (define-condition simple-dns-decode-error (dns-decode-error simple-error) ()) |
| 86 | |
| 87 | (defun simple-dns-decode-error (packet format &rest args) |
| 88 | (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args)) |
| 89 | |
| 90 | (defun decode-uint-8 (buf) |
| 91 | (declare (type dns-decode-state buf)) |
| 92 | (with-slots (packet pos) buf |
| 93 | (when (< (- (length packet) pos) 1) |
| 94 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number).")) |
| 95 | (prog1 (aref packet pos) |
| 96 | (incf pos)))) |
| 97 | |
| 98 | (defun decode-uint-16 (buf) |
| 99 | (declare (type dns-decode-state buf)) |
| 100 | (with-slots (packet pos) buf |
| 101 | (when (< (- (length packet) pos) 2) |
| 102 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number).")) |
| 103 | (prog1 |
| 104 | (+ (* (aref packet pos) 256) |
| 105 | (aref packet (1+ pos))) |
| 106 | (incf pos 2)))) |
| 107 | |
| 108 | (defun decode-uint-32 (buf) |
| 109 | (declare (type dns-decode-state buf)) |
| 110 | (with-slots (packet pos) buf |
| 111 | (when (< (- (length packet) pos) 4) |
| 112 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number).")) |
| 113 | (prog1 |
| 114 | (+ (* (aref packet pos) #x1000000) |
| 115 | (* (aref packet (+ pos 1)) #x10000) |
| 116 | (* (aref packet (+ pos 2)) #x100) |
| 117 | (aref packet (+ pos 3))) |
| 118 | (incf pos 4)))) |
| 119 | |
| 120 | (defun decode-domain-name (buf) |
| 121 | (declare (type dns-decode-state buf)) |
| 122 | (labels ((decode-label () |
| 123 | (let* ((orig-off (dns-decode-state-pos buf)) |
| 124 | (len (decode-uint-8 buf))) |
| 125 | (case (ldb (byte 2 6) len) |
| 126 | ((0) |
| 127 | (if (zerop len) |
| 128 | '() |
| 129 | (with-slots (packet pos) buf |
| 130 | (let* ((label (prog1 |
| 131 | (handler-bind |
| 132 | ((charcode:coding-error |
| 133 | (lambda (c) |
| 134 | (declare (ignore c)) |
| 135 | (simple-dns-decode-error buf "DNS label was not ASCII.")))) |
| 136 | (charcode:decode-string (subseq packet |
| 137 | pos (+ pos len)) |
| 138 | :ascii)) |
| 139 | (incf pos len))) |
| 140 | (decoded (append (list label) (decode-label)))) |
| 141 | (push (cons orig-off decoded) (slot-value buf 'prev-names)) |
| 142 | decoded)))) |
| 143 | ((3) (let* ((offset (+ (* 256 (ldb (byte 6 0) len)) |
| 144 | (decode-uint-8 buf))) |
| 145 | (prev (assoc offset (dns-decode-state-prev-names buf)))) |
| 146 | (unless prev |
| 147 | (simple-dns-decode-error buf "Domain name label pointed to non-label position.")) |
| 148 | (cdr prev))) |
| 149 | (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))) |
| 150 | (decode-label))) |
| 151 | |
| 152 | (defun decode-dns-query (buf) |
| 153 | (declare (type dns-decode-state buf)) |
| 154 | (let* ((name (decode-domain-name buf)) |
| 155 | (type (decode-uint-16 buf)) |
| 156 | (class (decode-uint-16 buf)) |
| 157 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 158 | (if desc |
| 159 | (make-instance 'resource-query :name name :type (first desc)) |
| 160 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 161 | nil)))) |
| 162 | |
| 163 | (defun decode-dns-record (buf) |
| 164 | (declare (type dns-decode-state buf)) |
| 165 | (let* ((name (decode-domain-name buf)) |
| 166 | (type (decode-uint-16 buf)) |
| 167 | (class (decode-uint-16 buf)) |
| 168 | (ttl (decode-uint-32 buf)) |
| 169 | (dlen (decode-uint-16 buf)) |
| 170 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 171 | (when (< (length (dns-decode-state-packet buf)) |
| 172 | (+ (dns-decode-state-pos buf) dlen)) |
| 173 | (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length.")) |
| 174 | (if desc |
| 175 | (let ((orig-off (dns-decode-state-pos buf)) |
| 176 | (rr (make-instance (first desc) |
| 177 | :name name |
| 178 | :ttl ttl))) |
| 179 | (dolist (slot-desc (third desc)) |
| 180 | (destructuring-bind (slot-name type) slot-desc |
| 181 | (setf (slot-value rr slot-name) |
| 182 | (with-slots (packet pos) buf |
| 183 | (ecase type |
| 184 | ((uint-16) (decode-uint-16 buf)) |
| 185 | ((uint-32) (decode-uint-32 buf)) |
| 186 | ((domain-name) (decode-domain-name buf)) |
| 187 | ((text) |
| 188 | (let ((len (decode-uint-8 buf))) |
| 189 | (prog1 (subseq packet pos (+ pos len)) |
| 190 | (incf pos len)))) |
| 191 | ((ipv4-address) |
| 192 | (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4))) |
| 193 | (incf pos 4))) |
| 194 | ((ipv6-address) |
| 195 | (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16))) |
| 196 | (incf pos 16)))))))) |
| 197 | (unless (= (dns-decode-state-pos buf) (+ orig-off dlen)) |
| 198 | (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data.")) |
| 199 | rr) |
| 200 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 201 | (incf (dns-decode-state-pos buf) dlen) |
| 202 | nil)))) |
| 203 | |
| 204 | (defun decode-dns-packet (buf) |
| 205 | (declare (type dns-decode-state buf)) |
| 206 | (let* ((txid (decode-uint-16 buf)) |
| 207 | (flags (decode-uint-16 buf)) |
| 208 | (qnum (decode-uint-16 buf)) |
| 209 | (ansnum (decode-uint-16 buf)) |
| 210 | (autnum (decode-uint-16 buf)) |
| 211 | (auxnum (decode-uint-16 buf)) |
| 212 | (packet (make-dns-packet :txid txid |
| 213 | :is-response (ldb-test (byte 1 15) flags) |
| 214 | :opcode (case (ldb (byte 4 11) flags) |
| 215 | ((0) :query) |
| 216 | ((1) :iquery) |
| 217 | ((2) :status) |
| 218 | (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags)))) |
| 219 | :authoritative (ldb-test (byte 1 10) flags) |
| 220 | :truncated (ldb-test (byte 1 9) flags) |
| 221 | :recurse (ldb-test (byte 1 8) flags) |
| 222 | :will-recurse (ldb-test (byte 1 7) flags) |
| 223 | :resp-code (case (ldb (byte 4 0) flags) |
| 224 | ((0) :success) |
| 225 | ((1) :format-error) |
| 226 | ((2) :server-failure) |
| 227 | ((3) :name-error) |
| 228 | ((4) :not-implemented) |
| 229 | ((5) :refused) |
| 230 | (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags))))))) |
| 231 | (with-slots (queries answers authority additional) packet |
| 232 | (dotimes (i qnum) |
| 233 | (setf queries (append queries (list (decode-dns-query buf))))) |
| 234 | (dotimes (i ansnum) |
| 235 | (setf answers (append answers (list (decode-dns-record buf))))) |
| 236 | (dotimes (i autnum) |
| 237 | (setf authority (append authority (list (decode-dns-record buf))))) |
| 238 | (dotimes (i auxnum) |
| 239 | (setf additional (append additional (list (decode-dns-record buf)))))) |
| 240 | packet)) |
| 241 | |
| 242 | (defun dns-decode (packet) |
| 243 | (decode-dns-packet (make-dns-decode-state :packet packet))) |
| 244 | |
| 245 | ;;; Packet encoding logic |
| 246 | |
| 247 | (defstruct dns-encode-state |
| 248 | (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8))) |
| 249 | (prev-names '() :type list)) |
| 250 | |
| 251 | (defun encode-uint-8 (buf num) |
| 252 | (declare (type dns-encode-state buf) |
| 253 | (type (unsigned-byte 8) num)) |
| 254 | (with-slots (packet-buf) buf |
| 255 | (vector-push-extend num packet-buf))) |
| 256 | |
| 257 | (defun encode-uint-16 (buf num) |
| 258 | (declare (type dns-encode-state buf) |
| 259 | (type (unsigned-byte 16) num)) |
| 260 | (with-slots (packet-buf) buf |
| 261 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 262 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 263 | |
| 264 | (defun encode-uint-32 (buf num) |
| 265 | (declare (type dns-encode-state buf) |
| 266 | (type (unsigned-byte 32) num)) |
| 267 | (with-slots (packet-buf) buf |
| 268 | (vector-push-extend (ldb (byte 8 24) num) packet-buf) |
| 269 | (vector-push-extend (ldb (byte 8 16) num) packet-buf) |
| 270 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 271 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 272 | |
| 273 | (defun encode-bytes (buf bytes) |
| 274 | (declare (type dns-encode-state buf) |
| 275 | (type (array (unsigned-byte 8)) bytes)) |
| 276 | (with-slots (packet-buf) buf |
| 277 | (dotimes (i (length bytes) (values)) |
| 278 | (vector-push-extend (elt bytes i) packet-buf)))) |
| 279 | |
| 280 | (defun encode-domain-name (buf name) |
| 281 | (declare (type dns-encode-state buf) |
| 282 | (type list name)) |
| 283 | (with-slots (packet-buf prev-names) buf |
| 284 | (labels ((encode-label (name) |
| 285 | (let ((prev (find name prev-names :key 'first :test 'equal))) |
| 286 | (cond ((null name) |
| 287 | (encode-uint-8 buf 0)) |
| 288 | (prev |
| 289 | (encode-uint-16 buf (+ #xc000 (cdr prev)))) |
| 290 | (t |
| 291 | (when (< (length packet-buf) 16384) |
| 292 | (push (cons name (length packet-buf)) prev-names)) |
| 293 | (let ((encoded (charcode:encode-string (car name) :ascii))) |
| 294 | (unless (< (length encoded) 64) |
| 295 | (simple-dns-decode-error buf "DNS labels cannot exceed 63 octets in length: ~S" (car name))) |
| 296 | (encode-uint-8 buf (length encoded)) |
| 297 | (encode-bytes buf encoded)) |
| 298 | (encode-label (cdr name))))))) |
| 299 | (encode-label name)))) |
| 300 | |
| 301 | (defun encode-dns-query (buf query) |
| 302 | (declare (type dns-encode-state buf) |
| 303 | (type resource-query query)) |
| 304 | (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first))) |
| 305 | (encode-domain-name buf (slot-value query 'name)) |
| 306 | (encode-uint-16 buf (second (second desc))) |
| 307 | (encode-uint-16 buf (first (second desc))))) |
| 308 | |
| 309 | (defun encode-dns-record (buf record) |
| 310 | (declare (type dns-encode-state buf) |
| 311 | (type resource-record record)) |
| 312 | (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first))) |
| 313 | (encode-domain-name buf (slot-value record 'name)) |
| 314 | (encode-uint-16 buf (second (second desc))) |
| 315 | (encode-uint-16 buf (first (second desc))) |
| 316 | (encode-uint-32 buf (slot-value record 'ttl)) |
| 317 | (with-slots (packet-buf) buf |
| 318 | (let ((orig-off (length packet-buf))) |
| 319 | (encode-uint-16 buf 0) |
| 320 | (dolist (slot-desc (third desc)) |
| 321 | (destructuring-bind (slot-name type) slot-desc |
| 322 | (let ((val (slot-value record slot-name))) |
| 323 | (ecase type |
| 324 | ((uint-16) (encode-uint-16 buf val)) |
| 325 | ((uint-32) (encode-uint-32 buf val)) |
| 326 | ((domain-name) (encode-domain-name buf val)) |
| 327 | ((text) (let ((data (etypecase val |
| 328 | (string (charcode:encode-string val :ascii)) |
| 329 | ((array (unsigned-byte 8)) val)))) |
| 330 | (unless (< (length data) 256) |
| 331 | (simple-dns-decode-error buf "DNS text data length cannot exceed 255 octets.")) |
| 332 | (encode-uint-8 buf (length data)) |
| 333 | (encode-bytes buf data))) |
| 334 | ((ipv4-address) |
| 335 | (check-type val ipv4-host-address) |
| 336 | (encode-bytes buf (slot-value val 'host-bytes))) |
| 337 | ((ipv6-address) |
| 338 | (check-type val ipv6-host-address) |
| 339 | (encode-bytes buf (slot-value val 'host-bytes))))))) |
| 340 | (let ((dlen (- (length packet-buf) orig-off))) |
| 341 | (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen) |
| 342 | (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen))))))) |
| 343 | |
| 344 | (defun encode-dns-packet (buf packet) |
| 345 | (declare (type dns-encode-state buf) |
| 346 | (type dns-packet packet)) |
| 347 | (with-slots (txid is-response opcode authoritative truncated |
| 348 | recurse will-recurse resp-code |
| 349 | queries answers authority additional) packet |
| 350 | (encode-uint-16 buf txid) |
| 351 | (let ((flags 0)) |
| 352 | (setf (ldb (byte 1 15) flags) (if is-response 1 0) |
| 353 | (ldb (byte 4 11) flags) (ecase opcode |
| 354 | ((:query) 0) |
| 355 | ((:iquery) 1) |
| 356 | ((:status) 2)) |
| 357 | (ldb (byte 1 10) flags) (if authoritative 1 0) |
| 358 | (ldb (byte 1 9) flags) (if truncated 1 0) |
| 359 | (ldb (byte 1 8) flags) (if recurse 1 0) |
| 360 | (ldb (byte 1 7) flags) (if will-recurse 1 0) |
| 361 | (ldb (byte 4 0) flags) (ecase resp-code |
| 362 | ((:success) 0) |
| 363 | ((:format-error) 1) |
| 364 | ((:server-failure) 2) |
| 365 | ((:name-error) 3) |
| 366 | ((:not-implemented) 4) |
| 367 | ((:refused) 5))) |
| 368 | (encode-uint-16 buf flags)) |
| 369 | (encode-uint-16 buf (length queries)) |
| 370 | (encode-uint-16 buf (length answers)) |
| 371 | (encode-uint-16 buf (length authority)) |
| 372 | (encode-uint-16 buf (length additional)) |
| 373 | (dolist (query queries) |
| 374 | (encode-dns-query buf query)) |
| 375 | (dolist (rr answers) |
| 376 | (encode-dns-record buf rr)) |
| 377 | (dolist (rr authority) |
| 378 | (encode-dns-record buf rr)) |
| 379 | (dolist (rr additional) |
| 380 | (encode-dns-record buf rr))) |
| 381 | (values)) |
| 382 | |
| 383 | (defun dns-encode (packet) |
| 384 | (check-type packet dns-packet) |
| 385 | (let ((buf (make-dns-encode-state))) |
| 386 | (encode-dns-packet buf packet) |
| 387 | (slot-value buf 'packet-buf))) |
| 388 | |
| 389 | ;;; DN format |
| 390 | |
| 391 | (defun parse-domain-name (name) |
| 392 | (declare (type string name)) |
| 393 | (let ((l '()) |
| 394 | (p 0)) |
| 395 | (loop (let ((p2 (position #\. name :start p))) |
| 396 | (if p2 |
| 397 | (if (= p2 (1- (length name))) |
| 398 | (return (values l t)) |
| 399 | (setf l (append l (list (subseq name p p2))) |
| 400 | p (1+ p2))) |
| 401 | (return (values (append l (list (subseq name p))) nil))))))) |
| 402 | |
| 403 | (defun unparse-domain-name (name) |
| 404 | (declare (type list name)) |
| 405 | (let ((buf nil)) |
| 406 | (dolist (label name buf) |
| 407 | (setf buf (if buf |
| 408 | (concatenate 'string buf "." label) |
| 409 | label))))) |
| 410 | |
| 411 | ;;; Basic communication |
| 412 | |
| 413 | (define-condition name-server-timeout (dns-error) |
| 414 | ((server :initarg :server))) |
| 415 | |
| 416 | (defun dns-do-request (server packet) |
| 417 | (declare (type address server) |
| 418 | (type dns-packet packet)) |
| 419 | (with-connection (sk server) |
| 420 | (socket-send sk (dns-encode packet)) |
| 421 | (loop |
| 422 | (let ((resp (dns-decode (socket-recv sk)))) |
| 423 | (when (= (dns-packet-txid resp) |
| 424 | (dns-packet-txid packet)) |
| 425 | (return resp)))))) |
| 426 | |
| 427 | (defun dns-std-request (queries &key (txid (random 65536)) (recurse t)) |
| 428 | (let ((qlist (map 'list #'(lambda (o) |
| 429 | (let ((name (first o)) |
| 430 | (type (second o))) |
| 431 | (make-instance 'resource-query |
| 432 | :name (etypecase name |
| 433 | (string (parse-domain-name name)) |
| 434 | (list name)) |
| 435 | :type type))) |
| 436 | queries))) |
| 437 | (make-dns-packet :txid txid |
| 438 | :recurse recurse |
| 439 | :queries qlist))) |
| 440 | |
| 441 | ;;; RR caching |
| 442 | |
| 443 | (defstruct domain-cache-entry |
| 444 | (expire nil :type (or number null)) |
| 445 | (records '() :type list)) |
| 446 | |
| 447 | (defun domain-cache-key (name type) |
| 448 | (list name (etypecase type |
| 449 | (symbol type) |
| 450 | (resource-record (class-name (class-of type)))))) |
| 451 | |
| 452 | (defun domain-cache-key-rr (record) |
| 453 | (declare (type resource-record record)) |
| 454 | (list (slot-value record 'name) (class-name (class-of record)))) |
| 455 | |
| 456 | (defun domain-cache-get-entry (cache name type &optional create) |
| 457 | (let* ((key (domain-cache-key name type)) |
| 458 | (cur (gethash key cache))) |
| 459 | (when (and cur (or (eq create :clear) |
| 460 | (let ((expire (domain-cache-entry-expire cur))) |
| 461 | (and expire |
| 462 | (> (/ (get-internal-real-time) internal-time-units-per-second) |
| 463 | expire))))) |
| 464 | (remhash key cache) |
| 465 | (setf cur nil)) |
| 466 | (cond (cur cur) |
| 467 | (create |
| 468 | (setf (gethash key cache) (make-domain-cache-entry)))))) |
| 469 | |
| 470 | (defun domain-cache-put (cache record) |
| 471 | (with-slots (name ttl) record |
| 472 | (let ((entry (domain-cache-get-entry cache name record t))) |
| 473 | (push record (domain-cache-entry-records entry))))) |
| 474 | |
| 475 | (defun dns-cache-records (cache records) |
| 476 | (loop (unless records (return)) |
| 477 | (let* ((key (domain-cache-key-rr (car records))) |
| 478 | (matching (remove key records :test-not 'equal :key #'domain-cache-key-rr)) |
| 479 | (ttl (block no-expire |
| 480 | (+ (/ (get-internal-real-time) internal-time-units-per-second) |
| 481 | (apply 'min (mapcar #'(lambda (rr) |
| 482 | (with-slots (ttl) rr |
| 483 | (if ttl ttl (return-from no-expire nil)))) |
| 484 | matching))))) |
| 485 | (entry (make-domain-cache-entry :expire ttl :records matching))) |
| 486 | (setf (gethash key cache) entry |
| 487 | records (set-difference records matching))))) |
| 488 | |
| 489 | (defun dns-cache-response (cache packet) |
| 490 | (let ((records (append (dns-packet-answers packet) |
| 491 | (dns-packet-authority packet) |
| 492 | (dns-packet-additional packet)))) |
| 493 | (flet ((on-root (rr) |
| 494 | (equal (slot-value rr 'name) '()))) |
| 495 | (when (some #'on-root records) |
| 496 | (warn "DNS packet purports to contain RRs on the root zone.") |
| 497 | (setf records (delete-if #'on-root records)))) |
| 498 | (when (dns-packet-authoritative packet) |
| 499 | (dolist (rq (dns-packet-queries packet)) |
| 500 | (with-slots (name type) rq |
| 501 | (unless (equal name '()) |
| 502 | (let ((key (domain-cache-key name type))) |
| 503 | (unless (find key records :test 'equal :key #'domain-cache-key-rr) |
| 504 | (let ((entry (domain-cache-get-entry cache name type :clear))) |
| 505 | (setf (domain-cache-entry-expire entry) |
| 506 | (+ (/ (get-internal-real-time) internal-time-units-per-second) |
| 507 | 60))))))))) ; XXX: Or something. It needs |
| 508 | ; to last for the query in |
| 509 | ; progress, at least. One |
| 510 | ; should probably look at an |
| 511 | ; SOA RR, if there is one. |
| 512 | (dns-cache-records cache records))) |
| 513 | |
| 514 | (defun make-domain-cache () |
| 515 | (let ((table (make-hash-table :test 'equal))) |
| 516 | (dolist (server (labels ((ipv4 (address) |
| 517 | (make-instance 'ipv4-host-address :host-string address))) |
| 518 | `(("a.root-servers.net" ,(ipv4 "198.41.0.4")) |
| 519 | ("b.root-servers.net" ,(ipv4 "192.228.79.201")) |
| 520 | ("c.root-servers.net" ,(ipv4 "192.33.4.12")) |
| 521 | ("d.root-servers.net" ,(ipv4 "128.8.10.90")) |
| 522 | ("e.root-servers.net" ,(ipv4 "192.203.230.10")) |
| 523 | ("f.root-servers.net" ,(ipv4 "192.5.5.241")) |
| 524 | ("g.root-servers.net" ,(ipv4 "192.112.36.4")) |
| 525 | ("h.root-servers.net" ,(ipv4 "128.63.2.53")) |
| 526 | ("i.root-servers.net" ,(ipv4 "192.36.148.17")) |
| 527 | ("j.root-servers.net" ,(ipv4 "192.58.128.30")) |
| 528 | ("k.root-servers.net" ,(ipv4 "193.0.14.129")) |
| 529 | ("l.root-servers.net" ,(ipv4 "199.7.83.42")) |
| 530 | ("m.root-servers.net" ,(ipv4 "202.12.27.33"))))) |
| 531 | (let ((parsed (parse-domain-name (first server)))) |
| 532 | (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed)) |
| 533 | ;; Ensure that the cache is initialized at least with empty |
| 534 | ;; lists, so that the resolver doesn't try to resolve the root |
| 535 | ;; servers. |
| 536 | (domain-cache-get-entry table parsed 'a-record t) |
| 537 | (domain-cache-get-entry table parsed 'aaaa-record t) |
| 538 | |
| 539 | (dolist (address (cdr server)) |
| 540 | (domain-cache-put table (etypecase address |
| 541 | (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address))))))) |
| 542 | table)) |
| 543 | |
| 544 | ;;; Resolver |
| 545 | |
| 546 | (defstruct resolver-config |
| 547 | (cache (make-domain-cache)) |
| 548 | (default-domains '() :type list) |
| 549 | (help-servers '() :type list)) |
| 550 | |
| 551 | (defun initialize-default-resolver () |
| 552 | #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil) |
| 553 | (when s |
| 554 | (let ((cfg (make-resolver-config))) |
| 555 | (labels ((whitespace-p (char) |
| 556 | (declare (type character char)) |
| 557 | (or (char= char #\space) |
| 558 | (char= char #\tab))) |
| 559 | (split-line (line) |
| 560 | (let ((l '()) |
| 561 | (p 0)) |
| 562 | (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p) |
| 563 | (return l))) |
| 564 | (p2 (position-if #'whitespace-p line :start p1))) |
| 565 | (if p2 |
| 566 | (setf l (append l (list (subseq line p1 p2))) |
| 567 | p p2) |
| 568 | (progn (setf l (append l (list (subseq line p1 p2)))) |
| 569 | (return l)))))))) |
| 570 | (let ((domain nil) |
| 571 | (search '())) |
| 572 | (loop (let ((line (read-line s nil nil))) |
| 573 | (unless line (return)) |
| 574 | (let ((line (split-line line))) |
| 575 | (when line |
| 576 | (cond ((equal (car line) "nameserver") |
| 577 | (push (make-instance 'ipv4-address :host-string (second line)) |
| 578 | (resolver-config-help-servers cfg))) |
| 579 | ((equal (car line) "search") |
| 580 | (setf search (append search (cdr line)))) |
| 581 | ((equal (car line) "domain") |
| 582 | (setf domain (second line)))))))) |
| 583 | (setf (resolver-config-default-domains cfg) |
| 584 | (or search (and domain (list domain))))) |
| 585 | cfg)))) |
| 586 | #-unix nil) |
| 587 | |
| 588 | (defvar *dns-resolver-config* (initialize-default-resolver)) |
| 589 | |
| 590 | (defgeneric dns-server-address-for-record (record)) |
| 591 | (defmethod dns-server-address-for-record ((record a-record)) |
| 592 | (make-instance 'udp4-address |
| 593 | :host-address (slot-value record 'address) |
| 594 | :port 53)) |
| 595 | (defmethod dns-server-address-for-record ((record aaaa-record)) |
| 596 | (make-instance 'udp6-address |
| 597 | :host-address (slot-value record 'address) |
| 598 | :port 53)) |
| 599 | |
| 600 | (define-condition dns-resolver-condition (condition) |
| 601 | ((query-name :initarg :query-name) |
| 602 | (query-type :initarg :query-type) |
| 603 | (config :initarg :config))) |
| 604 | |
| 605 | (define-condition dns-resolver-error (dns-error dns-resolver-condition) ()) |
| 606 | (define-condition domain-not-found-error (dns-resolver-error) () |
| 607 | (:report (lambda (c s) |
| 608 | (with-slots (query-name) c |
| 609 | (format s "No name servers found for domain name ~A." query-name))))) |
| 610 | (define-condition dns-name-error (dns-error dns-resolver-condition) () |
| 611 | (:report (lambda (c s) |
| 612 | (with-slots (query-name) c |
| 613 | (format s "The domain name ~A does not exist." query-name))))) |
| 614 | |
| 615 | (define-condition dns-resolver-querying (dns-resolver-condition) |
| 616 | ((server :initarg :server))) |
| 617 | |
| 618 | (define-condition dns-resolver-got-resp (dns-resolver-condition) |
| 619 | ((server :initarg :server) |
| 620 | (response :initarg :response))) |
| 621 | |
| 622 | (define-condition dns-resolver-help (dns-resolver-condition) ()) |
| 623 | (define-condition dns-resolver-recursing (dns-resolver-condition) ()) |
| 624 | |
| 625 | (define-condition dns-resolver-following-cname (dns-resolver-condition) |
| 626 | ((cname-rr :initarg :cname-rr))) |
| 627 | |
| 628 | (defun dns-resolve-name (name types &key (require-all t) (config *dns-resolver-config*)) |
| 629 | (let ((name (etypecase name |
| 630 | (list name) |
| 631 | (string (parse-domain-name name)))) |
| 632 | (types (etypecase types |
| 633 | (list types) |
| 634 | (symbol (list types)))) |
| 635 | (cache (resolver-config-cache config))) |
| 636 | (flet ((check-cache () |
| 637 | (let ((cn-entry (domain-cache-get-entry cache name 'cname-record))) |
| 638 | (when (and cn-entry (domain-cache-entry-records cn-entry)) |
| 639 | (let ((record (car (domain-cache-entry-records cn-entry)))) |
| 640 | (signal 'dns-resolver-following-cname :cname-rr record |
| 641 | :query-name (unparse-domain-name name) :query-type types |
| 642 | :config config) |
| 643 | (return-from dns-resolve-name |
| 644 | (dns-resolve-name (slot-value record 'cname) types :config config))))) |
| 645 | (block skip |
| 646 | (let ((records '()) |
| 647 | (got-some nil)) |
| 648 | (dolist (type types) |
| 649 | (let ((entry (domain-cache-get-entry cache name type))) |
| 650 | (cond (entry |
| 651 | (setf records (append records (domain-cache-entry-records entry)) |
| 652 | got-some t)) |
| 653 | (require-all |
| 654 | (return-from skip))))) |
| 655 | (when got-some |
| 656 | (return-from dns-resolve-name (values records name)))))) |
| 657 | (nearest-known-servers (name) |
| 658 | (labels ((check1 (name) |
| 659 | (let ((entry (domain-cache-get-entry cache name 'ns-record))) |
| 660 | (cond ((and entry (domain-cache-entry-records entry)) |
| 661 | (values (domain-cache-entry-records entry) name)) |
| 662 | (name (check1 (cdr name))) |
| 663 | (t (values '() name)))))) |
| 664 | (check1 name))) |
| 665 | (do-request (server) |
| 666 | (signal 'dns-resolver-querying :server server |
| 667 | :query-name (unparse-domain-name name) :query-type types |
| 668 | :config config) |
| 669 | (handler-case |
| 670 | (let ((resp (dns-do-request (udp-address-for server 53) |
| 671 | (dns-std-request (mapcar #'(lambda (type) |
| 672 | `(,name ,type)) |
| 673 | types))))) |
| 674 | (signal 'dns-resolver-got-resp :server server :response resp |
| 675 | :query-name (unparse-domain-name name) :query-type types |
| 676 | :config config) |
| 677 | (dns-cache-response cache resp) |
| 678 | (with-slots (resp-code) resp |
| 679 | (when (eq (dns-packet-resp-code resp) :name-error) |
| 680 | (error 'dns-name-error :query-name (unparse-domain-name name) :query-type types |
| 681 | :config config)) |
| 682 | (eq resp-code :success))) |
| 683 | (network-error () nil)))) |
| 684 | (check-cache) |
| 685 | (signal 'dns-resolver-help :query-name (unparse-domain-name name) :query-type types |
| 686 | :config config) |
| 687 | (dolist (help-server (resolver-config-help-servers config)) |
| 688 | (do-request help-server) |
| 689 | (check-cache)) |
| 690 | (signal 'dns-resolver-recursing :query-name (unparse-domain-name name) :query-type types |
| 691 | :config config) |
| 692 | (let ((checked-domains '())) |
| 693 | (loop (multiple-value-bind (servers domain) |
| 694 | (nearest-known-servers name) |
| 695 | (unless servers |
| 696 | (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types |
| 697 | :config config)) |
| 698 | (if (find domain checked-domains :test 'equal) |
| 699 | (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types |
| 700 | :config config) |
| 701 | (push domain checked-domains)) |
| 702 | (macrolet ((dolist-random ((var list) &body body) |
| 703 | (let ((copy (gensym "COPY"))) |
| 704 | `(let ((,copy ,list)) |
| 705 | (loop (unless ,copy (return)) |
| 706 | (let ((,var (elt ,list (random (length ,list))))) |
| 707 | (setf ,copy (remove ,var ,copy)) |
| 708 | ,@body)))))) |
| 709 | (block found-server |
| 710 | (dolist-random (record servers) |
| 711 | (let* ((server (slot-value record 'ns-name))) |
| 712 | (dolist-random (record (handler-case |
| 713 | (dns-resolve-name server '(a-record aaaa-record) :require-all nil :config config) |
| 714 | (dns-resolver-error () '()))) |
| 715 | (when (do-request (dns-server-address-for-record record)) |
| 716 | (return-from found-server)))))) |
| 717 | (check-cache)))))))) |
| 718 | |
| 719 | (export '(*dns-resolver-config*)) |
| 720 | |
| 721 | ;;; Misc. |
| 722 | |
| 723 | (defmethod print-object ((q resource-query) stream) |
| 724 | (with-slots (name type) q |
| 725 | (if *print-readably* |
| 726 | (format stream "~A: ~A" type (unparse-domain-name name)) |
| 727 | (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name))))) |
| 728 | |