| 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 | |
| 44 | (define-rr-type a-record #x1 #x1 |
| 45 | ((address ipv4-address))) |
| 46 | (define-rr-type ns-record #x1 #x2 |
| 47 | ((ns-name domain-name))) |
| 48 | (define-rr-type cname-record #x1 #x5 |
| 49 | ((cname domain-name))) |
| 50 | (define-rr-type soa-record #x1 #x6 |
| 51 | ((mname domain-name) |
| 52 | (rname domain-name) |
| 53 | (serial uint-32) |
| 54 | (refresh uint-32) |
| 55 | (retry uint-32) |
| 56 | (expire uint-32))) |
| 57 | (define-rr-type ptr-record #x1 #xc |
| 58 | ((pointed domain-name))) |
| 59 | (define-rr-type mx-record #x1 #xf |
| 60 | ((prio uint-16) |
| 61 | (mail-host domain-name))) |
| 62 | (define-rr-type txt-record #x1 #x10 |
| 63 | ((text text))) |
| 64 | (define-rr-type aaaa-record #x1 #x1c |
| 65 | ((address ipv6-address))) |
| 66 | (define-rr-type srv-record #x1 #x21 |
| 67 | ((prio uint-16) |
| 68 | (weigth uint-16) |
| 69 | (port uint-16) |
| 70 | (host-name domain-name))) |
| 71 | |
| 72 | ;;; Packet decoding logic |
| 73 | |
| 74 | (defstruct dns-decode-state |
| 75 | (packet nil :type (array (unsigned-byte 8))) |
| 76 | (pos 0 :type (mod 65536)) |
| 77 | (prev-names '() :type list)) |
| 78 | |
| 79 | (define-condition dns-error (error) ()) |
| 80 | (define-condition dns-decode-error (dns-error) |
| 81 | ((packet :initarg :packet))) |
| 82 | (define-condition simple-dns-decode-error (dns-decode-error simple-error) ()) |
| 83 | |
| 84 | (defun simple-dns-decode-error (packet format &rest args) |
| 85 | (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args)) |
| 86 | |
| 87 | (defun decode-uint-8 (buf) |
| 88 | (declare (type dns-decode-state buf)) |
| 89 | (with-slots (packet pos) buf |
| 90 | (when (< (- (length packet) pos) 1) |
| 91 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number).")) |
| 92 | (prog1 (aref packet pos) |
| 93 | (incf pos)))) |
| 94 | |
| 95 | (defun decode-uint-16 (buf) |
| 96 | (declare (type dns-decode-state buf)) |
| 97 | (with-slots (packet pos) buf |
| 98 | (when (< (- (length packet) pos) 2) |
| 99 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number).")) |
| 100 | (prog1 |
| 101 | (+ (* (aref packet pos) 256) |
| 102 | (aref packet (1+ pos))) |
| 103 | (incf pos 2)))) |
| 104 | |
| 105 | (defun decode-uint-32 (buf) |
| 106 | (declare (type dns-decode-state buf)) |
| 107 | (with-slots (packet pos) buf |
| 108 | (when (< (- (length packet) pos) 4) |
| 109 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number).")) |
| 110 | (prog1 |
| 111 | (+ (* (aref packet pos) #x1000000) |
| 112 | (* (aref packet (+ pos 1)) #x10000) |
| 113 | (* (aref packet (+ pos 2)) #x100) |
| 114 | (aref packet (+ pos 3))) |
| 115 | (incf pos 4)))) |
| 116 | |
| 117 | (defun decode-domain-name (buf) |
| 118 | (declare (type dns-decode-state buf)) |
| 119 | (labels ((decode-label () |
| 120 | (let* ((orig-off (dns-decode-state-pos buf)) |
| 121 | (len (decode-uint-8 buf))) |
| 122 | (case (ldb (byte 2 6) len) |
| 123 | ((0) |
| 124 | (if (zerop len) |
| 125 | '() |
| 126 | (with-slots (packet pos) buf |
| 127 | (let* ((label (prog1 |
| 128 | (handler-bind |
| 129 | ((charcode:coding-error |
| 130 | (lambda (c) |
| 131 | (declare (ignore c)) |
| 132 | (simple-dns-decode-error buf "DNS label was not ASCII.")))) |
| 133 | (charcode:decode-string (subseq packet |
| 134 | pos (+ pos len)) |
| 135 | :ascii)) |
| 136 | (incf pos len))) |
| 137 | (decoded (append (list label) (decode-label)))) |
| 138 | (push (cons orig-off decoded) (slot-value buf 'prev-names)) |
| 139 | decoded)))) |
| 140 | ((3) (let* ((offset (+ (* 256 (ldb (byte 6 0) len)) |
| 141 | (decode-uint-8 buf))) |
| 142 | (prev (assoc offset (dns-decode-state-prev-names buf)))) |
| 143 | (unless prev |
| 144 | (simple-dns-decode-error buf "Domain name label pointed to non-label position.")) |
| 145 | (cdr prev))) |
| 146 | (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))) |
| 147 | (decode-label))) |
| 148 | |
| 149 | (defun decode-dns-query (buf) |
| 150 | (declare (type dns-decode-state buf)) |
| 151 | (let* ((name (decode-domain-name buf)) |
| 152 | (type (decode-uint-16 buf)) |
| 153 | (class (decode-uint-16 buf)) |
| 154 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 155 | (if desc |
| 156 | (make-instance 'resource-query :name name :type (first desc)) |
| 157 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 158 | nil)))) |
| 159 | |
| 160 | (defun decode-dns-record (buf) |
| 161 | (declare (type dns-decode-state buf)) |
| 162 | (let* ((name (decode-domain-name buf)) |
| 163 | (type (decode-uint-16 buf)) |
| 164 | (class (decode-uint-16 buf)) |
| 165 | (ttl (decode-uint-32 buf)) |
| 166 | (dlen (decode-uint-16 buf)) |
| 167 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 168 | (when (< (length (dns-decode-state-packet buf)) |
| 169 | (+ (dns-decode-state-pos buf) dlen)) |
| 170 | (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length.")) |
| 171 | (if desc |
| 172 | (let ((orig-off (dns-decode-state-pos buf)) |
| 173 | (rr (make-instance (first desc) |
| 174 | :name name |
| 175 | :ttl ttl))) |
| 176 | (dolist (slot-desc (third desc)) |
| 177 | (destructuring-bind (slot-name type) slot-desc |
| 178 | (setf (slot-value rr slot-name) |
| 179 | (with-slots (packet pos) buf |
| 180 | (ecase type |
| 181 | ((uint-16) (decode-uint-16 buf)) |
| 182 | ((uint-32) (decode-uint-32 buf)) |
| 183 | ((domain-name) (decode-domain-name buf)) |
| 184 | ((text) |
| 185 | (let ((len (decode-uint-8 buf))) |
| 186 | (prog1 (subseq packet pos (+ pos len)) |
| 187 | (incf pos len)))) |
| 188 | ((ipv4-address) |
| 189 | (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4))) |
| 190 | (incf pos 4))) |
| 191 | ((ipv6-address) |
| 192 | (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16))) |
| 193 | (incf pos 16)))))))) |
| 194 | (unless (= (dns-decode-state-pos buf) (+ orig-off dlen)) |
| 195 | (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data.")) |
| 196 | rr) |
| 197 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 198 | (incf (dns-decode-state-pos buf) dlen) |
| 199 | nil)))) |
| 200 | |
| 201 | (defun decode-dns-packet (buf) |
| 202 | (declare (type dns-decode-state buf)) |
| 203 | (let* ((txid (decode-uint-16 buf)) |
| 204 | (flags (decode-uint-16 buf)) |
| 205 | (qnum (decode-uint-16 buf)) |
| 206 | (ansnum (decode-uint-16 buf)) |
| 207 | (autnum (decode-uint-16 buf)) |
| 208 | (auxnum (decode-uint-16 buf)) |
| 209 | (packet (make-dns-packet :txid txid |
| 210 | :is-response (ldb-test (byte 1 15) flags) |
| 211 | :opcode (case (ldb (byte 4 11) flags) |
| 212 | ((0) :query) |
| 213 | ((1) :iquery) |
| 214 | ((2) :status) |
| 215 | (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags)))) |
| 216 | :authoritative (ldb-test (byte 1 10) flags) |
| 217 | :truncated (ldb-test (byte 1 9) flags) |
| 218 | :recurse (ldb-test (byte 1 8) flags) |
| 219 | :will-recurse (ldb-test (byte 1 7) flags) |
| 220 | :resp-code (case (ldb (byte 4 0) flags) |
| 221 | ((0) :success) |
| 222 | ((1) :format-error) |
| 223 | ((2) :server-failure) |
| 224 | ((3) :name-error) |
| 225 | ((4) :not-implemented) |
| 226 | ((5) :refused) |
| 227 | (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags))))))) |
| 228 | (with-slots (queries answers authority additional) packet |
| 229 | (dotimes (i qnum) |
| 230 | (setf queries (append queries (list (decode-dns-query buf))))) |
| 231 | (dotimes (i ansnum) |
| 232 | (setf answers (append answers (list (decode-dns-record buf))))) |
| 233 | (dotimes (i autnum) |
| 234 | (setf authority (append authority (list (decode-dns-record buf))))) |
| 235 | (dotimes (i auxnum) |
| 236 | (setf additional (append additional (list (decode-dns-record buf)))))) |
| 237 | packet)) |
| 238 | |
| 239 | (defun dns-decode (packet) |
| 240 | (decode-dns-packet (make-dns-decode-state :packet packet))) |
| 241 | |
| 242 | ;;; Packet encoding logic |
| 243 | |
| 244 | (defstruct dns-encode-state |
| 245 | (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8))) |
| 246 | (prev-names '() :type list)) |
| 247 | |
| 248 | (defun encode-uint-8 (buf num) |
| 249 | (declare (type dns-encode-state buf) |
| 250 | (type (unsigned-byte 8) num)) |
| 251 | (with-slots (packet-buf) buf |
| 252 | (vector-push-extend num packet-buf))) |
| 253 | |
| 254 | (defun encode-uint-16 (buf num) |
| 255 | (declare (type dns-encode-state buf) |
| 256 | (type (unsigned-byte 16) num)) |
| 257 | (with-slots (packet-buf) buf |
| 258 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 259 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 260 | |
| 261 | (defun encode-uint-32 (buf num) |
| 262 | (declare (type dns-encode-state buf) |
| 263 | (type (unsigned-byte 32) num)) |
| 264 | (with-slots (packet-buf) buf |
| 265 | (vector-push-extend (ldb (byte 8 24) num) packet-buf) |
| 266 | (vector-push-extend (ldb (byte 8 16) num) packet-buf) |
| 267 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 268 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 269 | |
| 270 | (defun encode-bytes (buf bytes) |
| 271 | (declare (type dns-encode-state buf) |
| 272 | (type (array (unsigned-byte 8)) bytes)) |
| 273 | (with-slots (packet-buf) buf |
| 274 | (dotimes (i (length bytes) (values)) |
| 275 | (vector-push-extend (elt bytes i) packet-buf)))) |
| 276 | |
| 277 | (defun encode-domain-name (buf name) |
| 278 | (declare (type dns-encode-state buf) |
| 279 | (type list name)) |
| 280 | (with-slots (packet-buf prev-names) buf |
| 281 | (labels ((encode-label (name) |
| 282 | (let ((prev (find name prev-names :key 'first :test 'equal))) |
| 283 | (cond ((null name) |
| 284 | (encode-uint-8 buf 0)) |
| 285 | (prev |
| 286 | (encode-uint-16 buf (+ #xc000 (cdr prev)))) |
| 287 | (t |
| 288 | (when (< (length packet-buf) 16384) |
| 289 | (push (cons name (length packet-buf)) prev-names)) |
| 290 | (let ((encoded (charcode:encode-string (car name) :ascii))) |
| 291 | (unless (< (length encoded) 64) |
| 292 | (error "DNS labels cannot exceed 63 octets in length: ~S" (car name))) |
| 293 | (encode-uint-8 buf (length encoded)) |
| 294 | (encode-bytes buf encoded)) |
| 295 | (encode-label (cdr name))))))) |
| 296 | (encode-label name)))) |
| 297 | |
| 298 | (defun encode-dns-query (buf query) |
| 299 | (declare (type dns-encode-state buf) |
| 300 | (type resource-query query)) |
| 301 | (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first))) |
| 302 | (encode-domain-name buf (slot-value query 'name)) |
| 303 | (encode-uint-16 buf (second (second desc))) |
| 304 | (encode-uint-16 buf (first (second desc))))) |
| 305 | |
| 306 | (defun encode-dns-record (buf record) |
| 307 | (declare (type dns-encode-state buf) |
| 308 | (type resource-record record)) |
| 309 | (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first))) |
| 310 | (encode-domain-name buf (slot-value record 'name)) |
| 311 | (encode-uint-16 buf (second (second desc))) |
| 312 | (encode-uint-16 buf (first (second desc))) |
| 313 | (encode-uint-32 buf (slot-value record 'ttl)) |
| 314 | (with-slots (packet-buf) buf |
| 315 | (let ((orig-off (length packet-buf))) |
| 316 | (encode-uint-16 buf 0) |
| 317 | (dolist (slot-desc (third desc)) |
| 318 | (destructuring-bind (slot-name type) slot-desc |
| 319 | (let ((val (slot-value record slot-name))) |
| 320 | (ecase type |
| 321 | ((uint-16) (encode-uint-16 buf val)) |
| 322 | ((uint-32) (encode-uint-32 buf val)) |
| 323 | ((domain-name) (encode-domain-name buf val)) |
| 324 | ((text) (let ((data (etypecase val |
| 325 | (string (charcode:encode-string val :ascii)) |
| 326 | ((array (unsigned-byte 8)) val)))) |
| 327 | (unless (< (length data) 256) |
| 328 | (error "DNS text data length cannot exceed 255 octets.")) |
| 329 | (encode-uint-8 buf (length data)) |
| 330 | (encode-bytes buf data))) |
| 331 | ((ipv4-address) |
| 332 | (check-type val ipv4-host-address) |
| 333 | (encode-bytes buf (slot-value val 'host-bytes))) |
| 334 | ((ipv6-address) |
| 335 | (check-type val ipv6-host-address) |
| 336 | (encode-bytes buf (slot-value val 'host-bytes))))))) |
| 337 | (let ((dlen (- (length packet-buf) orig-off))) |
| 338 | (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen) |
| 339 | (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen))))))) |
| 340 | |
| 341 | (defun encode-dns-packet (buf packet) |
| 342 | (declare (type dns-encode-state buf) |
| 343 | (type dns-packet packet)) |
| 344 | (with-slots (txid is-response opcode authoritative truncated |
| 345 | recurse will-recurse resp-code |
| 346 | queries answers authority additional) packet |
| 347 | (encode-uint-16 buf txid) |
| 348 | (let ((flags 0)) |
| 349 | (setf (ldb (byte 1 15) flags) (if is-response 1 0) |
| 350 | (ldb (byte 4 11) flags) (ecase opcode |
| 351 | ((:query) 0) |
| 352 | ((:iquery) 1) |
| 353 | ((:status) 2)) |
| 354 | (ldb (byte 1 10) flags) (if authoritative 1 0) |
| 355 | (ldb (byte 1 9) flags) (if truncated 1 0) |
| 356 | (ldb (byte 1 8) flags) (if recurse 1 0) |
| 357 | (ldb (byte 1 7) flags) (if will-recurse 1 0) |
| 358 | (ldb (byte 4 0) flags) (ecase resp-code |
| 359 | ((:success) 0) |
| 360 | ((:format-error) 1) |
| 361 | ((:server-failure) 2) |
| 362 | ((:name-error) 3) |
| 363 | ((:not-implemented) 4) |
| 364 | ((:refused) 5))) |
| 365 | (encode-uint-16 buf flags)) |
| 366 | (encode-uint-16 buf (length queries)) |
| 367 | (encode-uint-16 buf (length answers)) |
| 368 | (encode-uint-16 buf (length authority)) |
| 369 | (encode-uint-16 buf (length additional)) |
| 370 | (dolist (query queries) |
| 371 | (encode-dns-query buf query)) |
| 372 | (dolist (rr answers) |
| 373 | (encode-dns-record buf rr)) |
| 374 | (dolist (rr authority) |
| 375 | (encode-dns-record buf rr)) |
| 376 | (dolist (rr additional) |
| 377 | (encode-dns-record buf rr))) |
| 378 | (values)) |
| 379 | |
| 380 | (defun dns-encode (packet) |
| 381 | (check-type packet dns-packet) |
| 382 | (let ((buf (make-dns-encode-state))) |
| 383 | (encode-dns-packet buf packet) |
| 384 | (slot-value buf 'packet-buf))) |
| 385 | |
| 386 | ;;; DN format |
| 387 | |
| 388 | (defun parse-domain-name (name) |
| 389 | (declare (type string name)) |
| 390 | (let ((l '()) |
| 391 | (p 0)) |
| 392 | (loop (let ((p2 (position #\. name :start p))) |
| 393 | (if p2 |
| 394 | (if (= p2 (1- (length name))) |
| 395 | (return (values l t)) |
| 396 | (setf l (append l (list (subseq name p p2))) |
| 397 | p (1+ p2))) |
| 398 | (return (values (append l (list (subseq name p))) nil))))))) |
| 399 | |
| 400 | (defun unparse-domain-name (name) |
| 401 | (declare (type list name)) |
| 402 | (let ((buf nil)) |
| 403 | (dolist (label name buf) |
| 404 | (setf buf (if buf |
| 405 | (concatenate 'string buf "." label) |
| 406 | label))))) |
| 407 | |
| 408 | ;;; Basic communication |
| 409 | |
| 410 | (defun dns-do-request (server packet) |
| 411 | (declare (type address server) |
| 412 | (type dns-packet packet)) |
| 413 | (with-connection (sk server) |
| 414 | (socket-send sk (dns-encode packet)) |
| 415 | (loop |
| 416 | (let ((resp (dns-decode (socket-recv sk)))) |
| 417 | (when (= (dns-packet-txid resp) |
| 418 | (dns-packet-txid packet)) |
| 419 | (return resp)))))) |
| 420 | |
| 421 | (defun dns-std-request (queries &key (txid (random 65536)) (recurse t)) |
| 422 | (let ((qlist (map 'list #'(lambda (o) |
| 423 | (let ((name (first o)) |
| 424 | (type (second o))) |
| 425 | (make-instance 'resource-query |
| 426 | :name (etypecase name |
| 427 | (string (parse-domain-name name)) |
| 428 | (list name)) |
| 429 | :type type))) |
| 430 | queries))) |
| 431 | (make-dns-packet :txid txid |
| 432 | :recurse recurse |
| 433 | :queries qlist))) |
| 434 | |
| 435 | ;;; RR caching |
| 436 | |
| 437 | (defstruct domain-cache-entry |
| 438 | (time (get-internal-real-time) :type unsigned-byte) |
| 439 | (records '() :type list)) |
| 440 | |
| 441 | (defun domain-cache-get-entry (cache name type &optional create) |
| 442 | (let* ((key (list name (etypecase type |
| 443 | (symbol type) |
| 444 | (resource-record (class-name (class-of type)))))) |
| 445 | (cur (gethash key cache))) |
| 446 | (block no-expire |
| 447 | (when (and cur (domain-cache-entry-records cur) |
| 448 | (> (get-internal-real-time) |
| 449 | (+ (domain-cache-entry-time cur) |
| 450 | (apply 'min (mapcar #'(lambda (o) |
| 451 | (declare (type resource-record o)) |
| 452 | (with-slots (ttl) o |
| 453 | (unless ttl (return-from no-expire)) |
| 454 | ttl)) |
| 455 | (domain-cache-entry-records cur)))))) |
| 456 | (remhash key cache) |
| 457 | (setf cur nil))) |
| 458 | (cond (cur cur) |
| 459 | (create |
| 460 | (setf (gethash key cache) (make-domain-cache-entry)))))) |
| 461 | |
| 462 | (defun domain-cache-put (cache record) |
| 463 | (with-slots (name ttl) record |
| 464 | (let ((entry (domain-cache-get-entry cache name record t))) |
| 465 | (push record (domain-cache-entry-records entry))))) |
| 466 | |
| 467 | (defun make-domain-cache () |
| 468 | (let ((table (make-hash-table :test 'equal))) |
| 469 | (dolist (server (labels ((ipv4 (address) |
| 470 | (make-instance 'ipv4-host-address :host-string address))) |
| 471 | `(("a.root-servers.net" ,(ipv4 "198.41.0.4")) |
| 472 | ("b.root-servers.net" ,(ipv4 "192.228.79.201")) |
| 473 | ("c.root-servers.net" ,(ipv4 "192.33.4.12")) |
| 474 | ("d.root-servers.net" ,(ipv4 "128.8.10.90")) |
| 475 | ("e.root-servers.net" ,(ipv4 "192.203.230.10")) |
| 476 | ("f.root-servers.net" ,(ipv4 "192.5.5.241")) |
| 477 | ("g.root-servers.net" ,(ipv4 "192.112.36.4")) |
| 478 | ("h.root-servers.net" ,(ipv4 "128.63.2.53")) |
| 479 | ("i.root-servers.net" ,(ipv4 "192.36.148.17")) |
| 480 | ("j.root-servers.net" ,(ipv4 "192.58.128.30")) |
| 481 | ("k.root-servers.net" ,(ipv4 "193.0.14.129")) |
| 482 | ("l.root-servers.net" ,(ipv4 "199.7.83.42")) |
| 483 | ("m.root-servers.net" ,(ipv4 "202.12.27.33"))))) |
| 484 | (let ((parsed (parse-domain-name (first server)))) |
| 485 | (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed)) |
| 486 | (dolist (address (cdr server)) |
| 487 | (domain-cache-put table (etypecase address |
| 488 | (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address))))))) |
| 489 | table)) |
| 490 | |
| 491 | ;;; Resolver |
| 492 | |
| 493 | (defstruct resolver-config |
| 494 | (cache (make-domain-cache)) |
| 495 | (default-domains '() :type list) |
| 496 | (help-servers '() :type list)) |
| 497 | |
| 498 | (defun initialize-default-resolver () |
| 499 | #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil) |
| 500 | (when s |
| 501 | (let ((cfg (make-resolver-config))) |
| 502 | (labels ((whitespace-p (char) |
| 503 | (declare (type character char)) |
| 504 | (or (char= char #\space) |
| 505 | (char= char #\tab))) |
| 506 | (split-line (line) |
| 507 | (let ((l '()) |
| 508 | (p 0)) |
| 509 | (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p) |
| 510 | (return l))) |
| 511 | (p2 (position-if #'whitespace-p line :start p1))) |
| 512 | (if p2 |
| 513 | (setf l (append l (list (subseq line p1 p2))) |
| 514 | p p2) |
| 515 | (progn (setf l (append l (list (subseq line p1 p2)))) |
| 516 | (return l)))))))) |
| 517 | (let ((domain nil) |
| 518 | (search '())) |
| 519 | (loop (let ((line (read-line s nil nil))) |
| 520 | (unless line (return)) |
| 521 | (let ((line (split-line line))) |
| 522 | (when line |
| 523 | (cond ((equal (car line) "nameserver") |
| 524 | (push (make-instance 'ipv4-address :host-string (second line)) |
| 525 | (resolver-config-help-servers cfg))) |
| 526 | ((equal (car line) "search") |
| 527 | (setf search (append search (cdr line)))) |
| 528 | ((equal (car line) "domain") |
| 529 | (setf domain (second line)))))))) |
| 530 | (setf (resolver-config-default-domains cfg) |
| 531 | (or search (and domain (list domain))))) |
| 532 | cfg)))) |
| 533 | #-unix nil) |
| 534 | |
| 535 | (defvar *resolver-config* (initialize-default-resolver)) |
| 536 | |
| 537 | |
| 538 | |
| 539 | ;;; Misc. |
| 540 | |
| 541 | (defmethod print-object ((q resource-query) stream) |
| 542 | (with-slots (name type) q |
| 543 | (if *print-readably* |
| 544 | (format stream "~A: ~A" type (unparse-domain-name name)) |
| 545 | (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name))))) |
| 546 | |