;;; -*- Mode: Common-Lisp; Package: DOMAIN-NAME-SYSTEM; Base: 10.; Patch-File: T -*- ;;; Patch file for STUB-RESOLVER version 2.2 ;;; Reason: Made the stub resolver set up the best MX record as :MAIL-GATEWAY-HOST of the host object. ;;; Also made the stub resolver handle local-only operations (e.g. lookups), by ;;; not looking the DNS object up on the network. ;;; Written 21-Feb-89 19:24:04 by Victor, ;;; while running on Jim Beam from band LOD3 ;;; With SYSTEM 4.61, VIRTUAL-MEMORY 4.4, EH 4.5, MAKE-SYSTEM 4.5, MICRONET 4.5, LOCAL-FILE 4.1, ;;; BASIC-PATHNAME 4.12, NETWORK-SUPPORT-COLD 4.1, NAMESPACE 4.22, NETWORK-NAMESPACE 4.2, ;;; DISK-IO 4.13, DISK-LABEL 4.0, BASIC-FILE 4.7, MAC-PATHNAME 4.5, NETWORK-PATHNAME 4.1, ;;; COMPILER 4.13, TV 4.85, DATALINK 4.14, CHAOSNET 4.18, GC 4.3, MEMORY-AUX 4.0, ;;; NVRAM 4.6, SYSLOG 4.0, STREAMER-TAPE 4.4, UCL 4.1, INPUT-EDITOR 4.0, METER 4.3, ;;; ZWEI 4.18, DEBUG-TOOLS 4.2, NETWORK-SUPPORT 4.5, NETWORK-SERVICE 4.0, DATALINK-DISPLAYS 4.0, ;;; FONT-EDITOR 4.0, SERIAL 4.0, PRINTER 4.8, PRINTER-TYPES 4.2, IMAGEN 4.0, SUGGESTIONS 4.0, ;;; MAIL-DAEMON 4.7, MAIL-READER 4.6, TELNET 4.1, VT100 4.6, NAMESPACE-EDITOR 4.5, ;;; PROFILE 4.4, VISIDOC 4.5, IP 3.19, RPC 4.14, NFS 3.2, Experimental NFS-PATCHES 2.8, ;;; TI-PROLOG 2.11, GRAPHICS-WINDOW 4.1, GED 4.1, TREE 4.0, VISIDOC-SERVER 4.0, Experimental SYSTEM-PATCHES 3.120, ;;; Experimental ICU-DOCS 12.0, Experimental SYSTEM-ENHANCEMENTS 19.0, Experimental TCP-IMAGEN 10.0, ;;; Experimental NAME-DRAGON 4.1, Experimental TEXINFO 5.5, Experimental ICU-LIBRARY 14.0, ;;; Experimental DOMAIN 5.0, Experimental STUB-RESOLVER 2.1, microcode 534, Band Name: 4.61 w DNS & Prolog, ;;; 890104/Vic #!C ; From file STUB-RESOLVER.LISP#> ICU.NETWORK.DNS; JJ: #10R DOMAIN-NAME-SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "DOMAIN-NAME-SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-RESOLVER.#" (defun stub-get-mail-exchange-of-name (name servers &rest more-args) (apply #'stub-get-resource-record name servers *type-mail-exchange* more-args)) )) ;;; Remove old DNS namespace, since the following DEFFLAVOR changes it incompatibly, they say. (eval-when (load) (name:delete-namespace name:*dns-stub-namespace-name* nil) (setq name:*dns-stub-namespace* nil) (name:dns-stub-namespace-initialization-form) ) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defflavor dns-stub-namespace ((safety-belt-servers nil) (local-only-operation nil)) (basic-namespace) (:special-instance-variables local-only-operation) ;**** this doesn't work as I thought it would. :gettable-instance-variables (:inittable-instance-variables safety-belt-servers) (:settable-instance-variables safety-belt-servers) ) )) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defmethod (dns-stub-namespace :find-object) (name class) "Finds the actual object named NAME,CLASS in the namespace. Returns the actual database object or nil if the object does not exist. FOR INTERNAL USE BY THE NAMESPACE ONLY. Ignores delete status. In the DNS-STUB-NAMESPACE case, do a DNS lookup if the object isn't found, and save the result." (declare (special local-only-operation)) (when *dns-stub-resolver-enabled* (let* ((name (string name)) (obj (if (find #\. (the string name) :test #'char=) (with-stack-list* (key-space name class) (gethash key-space namespace)) ;; Apply search-list when looking in hash table (dolist (search *dns-stub-domain-search-list*) (with-stack-list* (key-space (string-append name "." search) class) (let ((x (gethash key-space namespace))) (when x (return x)))))))) (cond (local-only-operation ;If it's local-only, don't bother with network. nil) ((null obj) ;Never heard of it, try to find it (setq obj (send self :very-internal-find-object name class)) (when (null obj) ;Not found, cache a miss (setq obj (send self :put-object (build-object name class nil))) (send self :mark-object-updated obj) (object-put-property obj :cache-miss t) (setf (object-deleted obj) t))) ((and (object-deleted obj) ;Cached a miss for this before? (object-get-property obj :cache-miss)) (if (< (- (get-universal-time) (object-get-property obj :last-update)) *dns-stub-negative-cache-timeout*) obj ;Hasn't timed out yet. ;;Cache miss timed out, try again to find it. (when (null (setq obj (send self :very-internal-find-object name class))) ;;Cache a miss again. (setq obj (send self :put-object (build-object name class nil))) (send self :mark-object-updated obj) (object-put-property obj :cache-miss t) (setf (object-deleted obj) t))))) (when (and obj (null (object-get-property obj :last-update))) (object-put-property obj :last-update 0)) obj))) )) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defmethod (dns-stub-namespace :around :extract-objects-from-properties) (continuation mapping-table op-arglist &optional name-pattern class first-only property-list test format) "Return a subset of the objects in the namespace. NAME-PATTERN can be the actual name of an object or a string containing wildcard characters. CLASS restricts to objects of that class. FIRST-ONLY says return only the first object matching the criteria. PROPERTY-LIST is a list of attributes and values required. FORMAT is :BRIEF :LIST :READ-ONLY or :COPY. TEST can be a function which takes a candiate object, NAME-PATTERN, CLASS, and PROPERTY-LIST and returns T or NIL. " (declare (ignore format first-only) (special local-only-operation)) ;;If this is a typical call from NET:GET-HOST-FROM-ADDRESS (if (and (eq test 'net:ns-get-host-from-address) (eq class :host) (null name-pattern) (= 4 (length property-list)) (and (eq (getf property-list :network) :ip) (not (null (getf property-list :address))))) (or ;; first try the basic method (lexpr-funcall-with-mapping-table continuation mapping-table op-arglist) ;; else look up the host from the address, and add it (unless local-only-operation ;...unless it's a local operation (let ((object (dns-stub-lookup-host-object-from-address (getf property-list :address) safety-belt-servers))) (when object (send self :mark-object-updated object) (send self :put-object object) ;; Make alias objects (let ((aliases (get-attribute-value object :aliases))) (when aliases (dolist (alias aliases) (let ((obj (build-object alias :host (list *alias-of* (object-name object))))) (send self :mark-object-updated obj) (send self :put-object obj))))) ;; and use the basic method to find it again... (lexpr-funcall-with-mapping-table continuation mapping-table op-arglist))))) ;; not our special case, call basic method. (lexpr-funcall-with-mapping-table continuation mapping-table op-arglist))) ;;; This is kind of a strange way of getting the local argument to these methods ;;; since the base methods have additional optional arguments used internally, ;;; it is hard to just add a local argument usable by a client who doesn't know ;;; what kind of namespace this is. The default version of this method just passes ;;; on the message. ;;; ;;; In the DNS case, bind a special instance variable to make :FIND-OBJECT note ;;; that it shouldn't look up the object on the network. )) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defmethod (dns-stub-namespace :local) (msg &rest args) (let ((local-only-operation t)) (declare (special local-only-operation)) (lexpr-send self msg args))) )) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defmethod (dns-stub-namespace :around :find-or-synthesize) (continuation mapping-table op-arglist NAME CLASS &OPTIONAL (SYNTHESIZE-OK T) A-NAME A-TYPE MEMBER-NAME KEY UNDELETE CHECK-TIME LOOKUP-ATTR LOOKUP-MEMBER) (declare (ignore A-NAME A-TYPE MEMBER-NAME KEY UNDELETE CHECK-TIME LOOKUP-ATTR LOOKUP-MEMBER)) (if synthesize-ok ;; Then call basic method, which calls our :find-object, which creates the object if necessary (lexpr-funcall-with-mapping-table continuation mapping-table op-arglist) (let ((obj (if (find #\. (the string name) :test #'char=) (with-stack-list* (key-space name class) (gethash key-space namespace)) ;; Apply search-list when looking in hash table (dolist (search *dns-stub-domain-search-list*) (with-stack-list* (key-space (string-append name "." search) class) (let ((x (gethash key-space namespace))) (when x (return x)))))))) (if obj ;; Then call basic method, which does the job, really. (lexpr-funcall-with-mapping-table continuation mapping-table op-arglist) ;; Else don't "synthesize" (lookup) the object. nil)))) )) #!C ; From file STUB-NAMESPACE.LISP#> ICU.NETWORK.DNS; JJ: #10R NAME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "DNS: DNS; STUB-NAMESPACE.#" (defun dns-stub-make-host-object (host servers) (flet ((find-cname-and-addresses (spec) (dbg:when-debug (format *trace-output* "~&Trying ~s..." spec)) (condition-case-if (not (dbg:debug-p)) (cond) (values-list (append (multiple-value-list (dns:stub-canonicalize-case spec servers)) (list spec))) (error nil)))) (multiple-value-bind (cname addresses spec) (cond ((char= #\. (char host (1- (length host)))) (find-cname-and-addresses host)) ((find #\. host :test #'char=) (find-cname-and-addresses (string-append host "."))) (t (loop with cname and addresses for search in *dns-stub-domain-search-list* as spec = (string-append host "." search ".") do (multiple-value-setq (cname addresses) (find-cname-and-addresses spec)) when (and (not (null cname)) (not (null addresses))) do (return (values cname addresses)) ;;Don't try top level - there are no top level hosts. ; finally ; (return ; (find-cname-and-addresses (string-append host "."))) ))) (when (or (null cname) (null addresses)) (return-from dns-stub-make-host-object nil)) (let* ((name (format nil "~{~a~^.~}" cname)) (short-name (first cname)) ;**** Might want this only on local domain(s)? (in search-list?) (any (dns:stub-get-any-info-of-name cname servers)) (alias (and spec (nth-value 1 (dns:stub-get-canonical-name-of-name spec servers)))) (alias-name (and alias (format nil "~{~a~^.~}" alias))) (hinfo nil) (wks nil) (mx nil)) (if (assoc :hinfo any) (setq hinfo (canonicalize-hinfo (first (cdr (assoc :hinfo any))))) (setq hinfo (canonicalize-hinfo (dns:stub-get-host-info-of-name cname servers)))) (if (assoc :wks any) (setq wks (make-services-from-ip-wks-records (cdr (assoc :wks any)))) (setq wks (make-services-from-ip-wks-records (dns:stub-get-wks-of-name cname servers)))) ;; This doesn't implement what MXs are ment to implement, but it's something... and the Explorer uses it. ;; Choose the best MX record which doesn't point at the host itself, since that is tried anyway. (flet ((mx-sorter (a b) (and (< (dns:mail-exchange-preference a) (dns:mail-exchange-preference b)) ;; don't sort the host itself as a good one. (not (equalp (dns:mail-exchange-exchange a) cname)))) (dname-to-string (dn) (format nil "~{~a~^.~}" dn))) (if (assoc :mx any) (let ((best-mx (first (sort (cdr (assoc :mx any)) #'mx-sorter)))) (unless (equalp (dns:mail-exchange-exchange best-mx) cname) (setq mx (dname-to-string (dns:mail-exchange-exchange best-mx))))) (let ((mx-list (dns:stub-get-mail-exchange-of-name cname servers))) (when mx-list (let ((best-mx (first (sort mx-list #'mx-sorter)))) (unless (equalp (dns:mail-exchange-exchange best-mx) cname) (setq mx (dname-to-string (dns:mail-exchange-exchange best-mx))))))))) (let ((attrs `(:short-name ,short-name :aliases ,(when alias (list alias-name)) :system-type ,(second hinfo) :machine-type ,(first hinfo) (:services :group) ((:status :tcp :ip-status) ,@(or wks (get :ip :default-network-services))) (:addresses :group) ,(loop for addr in addresses collect (list :ip (ethernet:dotted-format-ip-address addr))) ;; This should be plural and a group! :mail-gateway-host ,mx))) (build-object name :host attrs)))))) (compile-flavor-methods dns-stub-namespace) ))