;;; -*- Mode:Common-Lisp; Package:DOMAIN-NAME-SYSTEM; Base:10 -*- ;;; 22-Sep-88 11:06:18, Björn Victor ;;; Copyright (c) 1988, Björn Victor, Department of Computer Systems, Uppsala University ;;; Very simple stub resolver. ;;; Use this to debug the resolver. At ICU, use the mode lock key. #-ICU-DoCS (defvar dns:*debug-dns* nil "Whether to debug the DNS Stub Resolver software or not.") (defvar *stub-resolver-n-retries* 5) (defvar *stub-resolver-individual-timeout* 2) (defvar *stub-resolver-server-port* 53. "The server port to connect to") (defvar *case-of-hosts-matter* t "Whether or not to try to canonicalize character case of objects (hosts). I like setting it since the UNIX BIND implementation returns answers with the case of the question instead of the case of the database entry. You save one query (for another domain (IN-ADDR.ARPA.)), though.") (defun stub-send-dns-query (ques server &key (n-retries *stub-resolver-n-retries*) (recursion-desired t) (medium :datagram) (switch-mediums-on-truncation t) (return-raw-message-p nil)) (check-type ques message-question "a DNS question") (let* ((hdr (make-message-header)) (msg (make-message :header hdr :questions (if (listp ques) ques (list ques)))) (id (random #.(expt 2 16)))) (setf (message-header-response-p hdr) nil (message-header-opcode hdr) dns:*opcode-query* (message-header-recursion-desired hdr) recursion-desired (message-header-question-count hdr) 1 (message-header-id hdr) id ) (multiple-value-bind (message msg-len) (parse-message msg) (let ((pkt (stub-send-dns-packet server message msg-len medium n-retries))) (when pkt (let ((msg (get-message-packet pkt))) (cond ((not (eql id (message-header-id (message-header msg)))) (stub-send-dns-query ques server :n-retries (1- n-retries) :recursion-desired recursion-desired :medium medium :switch-mediums-on-truncation switch-mediums-on-truncation)) ((/= *response-no-error* (message-header-response-code (message-header msg))) #+Explorer (case (message-header-response-code (message-header msg)) (#.*response-format-error* (ticl:signal 'dns-format-error "Format error for query ~s" ques)) (#.*response-server-failure* (ticl:signal 'dns-server-failure "Server ~*~s was unable to process query ~:2*~s" ques server)) (#.*response-name-error* (if (message-header-authoritative-p (message-header msg)) (ticl:signal 'dns-name-error "No such domain as ~*~s" ques (message-question-name ques)) (ticl:signal 'dns-no-data-available "Server can't find domain ~*s" ques (message-question-name ques)))) (#.*response-not-implemented* (ticl:signal 'dns-nyi-error "Server ~*s has not implemented ~s for ~s" ques server (opcode-string (message-header-opcode (message-header message))) (type-string (message-question-type ques)))) (#.*response-refused* (ticl:signal 'dns-refused-error "Server ~*s refuses to answer this question: ~:2*~s" ques server)) (t (error "Unknown response code ~d from DNS server ~a" (message-header-response-code (message-header msg)) server))) #-Explorer (error "Error from Domain server ~a: ~s" server (response-code-string (message-header-response-code (message-header msg))))) ((and (not (null (message-header-truncated-p (message-header msg)))) (not (null switch-mediums-on-truncation)) (eq medium :datagram)) ;; Change to virtual circuit (stub-send-dns-query ques server :n-retries (1- n-retries) :recursion-desired recursion-desired :medium :virtual-circuit :switch-mediums-on-truncation nil)) ((zerop (message-header-answer-count (message-header msg))) #+Explorer (if (message-header-authoritative-p (message-header msg)) (ticl:signal 'dns-no-data-available "There are no data for ~s (~s)" ques (type-string (message-question-type ques))) (ticl:signal 'dns-no-data-available "Can't find data for ~s (~s)" ques (type-string (message-question-type ques)))) nil) ((and (= *type-canonical-name* (message-resource-record-type (first (message-answers msg)))) (/= *type-canonical-name* (message-question-type ques)) ;;; Maybe not compatible with use. ; (/= *type-wild-request* (message-question-type ques)) ) (stub-send-dns-query (make-message-question :name (message-resource-record-data (first (message-answers msg))) :type (message-question-type ques) :class (message-question-class ques)) server :n-retries n-retries :recursion-desired recursion-desired)) (t (if return-raw-message-p msg (message-answers msg)))))))))) (defun stub-send-dns-packet (server message msg-len medium n-retries) (ecase medium (:datagram (let* ((port (ticl:send ip:*udp-handler* :get-port)) (pkt (unwind-protect (let ((reply-block (make-array 512 :element-type '(unsigned-byte 8))) (server-address (if (numberp server) server (net:parse-network-address server :ip)))) (dotimes (i n-retries nil) (ticl:send port :transmit-data :data message :length msg-len :destination-host server-address :destination-port *stub-resolver-server-port*) (multiple-value-bind (nbytes port rhost not-timed-out) (ticl:send port :receive-data reply-block *stub-resolver-individual-timeout*) (declare (ignore port)) (if (and not-timed-out (and #+Explorer (not (ip:local-broadcast-address-p server-address)) (/= rhost server-address))) (incf i) (when not-timed-out (return (values reply-block nbytes))))))) (ticl:send ip:*udp-handler* :return-port port)))) pkt)) (:virtual-circuit (with-open-stream (s (ip:open-stream server :remote-port *stub-resolver-server-port*)) (write-byte (ldb (byte 8 8) msg-len) s) (write-byte (ldb (byte 8 0) msg-len) s) (write-string message s :end msg-len) (force-output s) ;;**** This does not hack zone transfers (see pp 28,29 in RFC1034), it only hacks single messages. (let ((in-length (dpb (read-byte s) (byte 8 8) (read-byte s)))) (let ((reply (make-array (* 64 20) :element-type '(unsigned-byte 8) :fill-pointer 0))) (dotimes (n in-length reply) (vector-push-extend (read-byte s) reply)))))))) ;;; Doesn't work like you expect (see file STUB-GET-ZONE instead) #|| ;(defun stub-get-whole-zone (name servers) ; (let ((question (make-message-question :name name :type *type-zone-transfer* :class *class-internet*))) ; (dolist (server servers) ; (let ((answers (multiple-value-bind (val err-p) ; (progn (values (stub-send-dns-query question server ; :medium :virtual-circuit))) ; (if err-p ; :error ; val)))) ; (cond ((ticl:errorp answers) ; (return nil)) ; (answers ; (return (values answers ; (message-resource-record-name (first answers)))))))))) ||# (defun stub-get-resource-record (name servers qtype &key (raw-message-p nil) (catch-errors (not #+ICU-DoCS (dbg:debug-p) #-ICU-DoCS dns:*debug-dns*)) (class *class-internet*)) (unless (listp servers) (setq servers (list servers))) (let ((question (make-message-question :name name :type qtype :class class))) (dolist (server servers) (let ((answers (ticl:condition-case-if catch-errors (condition) (stub-send-dns-query question server :return-raw-message-p raw-message-p) (dns-error condition)))) (cond ((ticl:errorp answers) (return nil)) (answers (if raw-message-p (return answers) (return (if (eql qtype *type-wild-request*) ;; **** KLUDGE **** for stub-namespace optimization (values (let ((result nil)) (dolist (rr answers result) (let* ((kwd (type-keyword (message-resource-record-type rr))) (e (assoc kwd result :test #'eq)) (data (message-resource-record-data rr))) (when (eq kwd :hinfo) ;**** YAK (yet another kludge) (setq data (parse-hinfo-to-keywords data))) (if e (setf (cdr e) (cons data (cdr e))) (setq result (acons kwd (cons data nil) result)))))) (message-resource-record-name (first answers))) (let ((rrs (mapcan #'(lambda (rr) (when (eql (message-resource-record-type rr) qtype) (cons rr nil))) answers))) (values (mapcar #'message-resource-record-data rrs) (and rrs (message-resource-record-name (first rrs)))))))))))))) (defun stub-get-any-info-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-wild-request* more-args)) (defun stub-get-mail-exchange-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-mail-exchange* more-args)) (defun stub-get-mail-info-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-mail-info* more-args)) (defun stub-get-mail-rename-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-mail-rename* more-args)) (defun stub-get-canonical-name-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-canonical-name* more-args)) (defun stub-get-addresses-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-address* more-args)) (defun stub-get-name-of-address (address servers &rest more-args) (let ((addr (if (numberp address) address (net:parse-network-address address :ip)))) (let ((dom-string (format nil "~d.~d.~d.~d.IN-ADDR.ARPA." (ldb (byte 8 0) addr) (ldb (byte 8 8) addr) (ldb (byte 8 16) addr) (ldb (byte 8 24) addr)))) (apply #'stub-get-resource-record dom-string servers *type-pointer* more-args)))) (defun stub-get-host-info-of-name (name servers &rest more-args) (multiple-value-bind (answers rrname) (apply #'stub-get-resource-record name servers *type-host-info* more-args) (values (and answers (parse-hinfo-to-keywords (first answers))) rrname))) (defun parse-hinfo-to-keywords (hinfo) (list (intern (string-upcase (host-info-cpu hinfo)) "") (intern (string-upcase (host-info-os hinfo)) ""))) (defun stub-get-wks-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-well-known-service* more-args)) (defun stub-canonicalize-case (name servers) (multiple-value-bind (addresses original-name) (stub-get-addresses-of-name name servers) (unless addresses (error "No addresses for ~s" name)) (if (not *case-of-hosts-matter*) (values original-name addresses) (let ((names (stub-get-name-of-address (first addresses) servers))) (values (or (first names) original-name) addresses)))))