;;; -*- Mode: Common-Lisp; Package: NAME; Base: 10.; Patch-File: T -*- ;;; Written 13-Mar-89 18:22:15 by Victor, ;;; Reason: Set up (:GATEWAY :IP :IP-GATEWAY) service and (:IP-ADDR-SUBNET-BITS :GROUP) attribute ;;; for gateways (hosts with more than one address). ;;; Doesn't mung the routing table yet (is that necessary?). ;;; while running on John Jameson 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.121, ;;; Experimental ICU-DOCS 12.1, Experimental SYSTEM-ENHANCEMENTS 19.1, 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.3, microcode 534, Band Name: 4.61 w DNS & Prolog, ;;; 890104/Vic #!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))) (address-strings (mapcar #'ethernet:dotted-format-ip-address addresses)) (hinfo nil) (wks nil) (mx nil) (subnet-bits 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)))) (when (> (length addresses) 1) (push '(:gateway :ip :ip-gateway) wks) ;Add gateway service (flet ((get-subnet-bits (addr) ; and try to get subnet bits (let* ((route (condition-case (cond) ; (it's silly to have #bits instead of a real mask!) (ip:get-routing-entry addr) (ip:incomplete-routing-table nil))) (sub (if route (logxor (ip:ip-routing-mask route) (ip:get-default-mask addr)) 0))) (if (zerop sub) 0 (- (integer-length sub) (integer-length (logxor sub (1- (expt 2 (ceiling (log sub 2))))))))))) (mapc #'(lambda (addr addr-string) (push (list addr-string (get-subnet-bits addr)) subnet-bits)) addresses address-strings)) ) ;; 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 address-strings collect (list :ip addr)) ;; This should be plural and a group! ,@(if mx `(:mail-gateway-host ,mx)) ,@(if subnet-bits `((:ip-addr-subnet-bits :group) ,subnet-bits))))) (build-object name :host attrs)))))) ))