;;; -*- Mode: Common-Lisp; Package: NAME; Base: 10.; Patch-File: T -*-
;;; Patch file for STUB-RESOLVER version 1.9
;;; Reason: Made all functions in STUB-RESOLVER take required arg SERVERS (instead of defaulting to *STUB-SERVERS*.
;;; Made STUB-GET-NAME-OF-ADDRESS handle numeric address.
;;; Written 19-Dec-88 12:53:50 by Victor,
;;; while running on Jim Beam from band LOD2
;;; 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.6,
;;;  TI-PROLOG 2.11, GRAPHICS-WINDOW 4.1, GED 4.1, TREE 4.0, VISIDOC-SERVER 4.0, Experimental SYSTEM-PATCHES 3.118,
;;;  Experimental ICU-DOCS 11.4, Experimental SYSTEM-ENHANCEMENTS 18.27, Experimental TCP-IMAGEN 9.5,
;;;  Experimental NAME-DRAGON 3.2, Experimental TEXINFO 5.5, Experimental ICU-LIBRARY 13.10,
;;;  Experimental DOMAIN 5.0, Experimental STUB-RESOLVER 1.7,  microcode 534, Band Name: 4.61 w DNS&Prolog,
;;;  881122/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-lookup-host-object-from-address (address servers)
  (let ((names (dns:stub-get-name-of-address address servers)))
    (when (and names (not (null (first names))))
      (let ((namestring (format nil "~{~a.~}" (first names))))
	(dns-stub-make-host-object namestring 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 :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))

  ;;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
	(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)))

))

#!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-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 (zstub-send-dns-query question server
									 :medium :virtual-circuit)))
		       (if err-p
			   :error
			   val))))
	(cond ((keywordp answers)
	       (return nil))
	      (answers
	       (return (values answers
			       (message-resource-record-name (first answers))))))))))

))

#!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-info-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-mail-info* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (multiple-value-bind (val err-p)
			 (ticl:catch-error (values (stub-send-dns-query question server)))
		       (if err-p
			   :error
			   val))))
	(cond ((keywordp answers)
	       (return nil))
	      (answers
	       (return (values answers
			       (message-resource-record-name (first answers))))))))))

))

#!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-rename-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-mail-rename* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (multiple-value-bind (val err-p)
			 (ticl:catch-error (values (stub-send-dns-query question server)))
		       (if err-p
			   :error
			   val))))
	(cond ((keywordp answers)
	       (return nil))
	      (answers
	       (return
		 (values (mapcar #'message-resource-record-data answers)
			 (message-resource-record-name (first answers))))))))))

))

#!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-canonical-name-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-canonical-name* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (stub-send-dns-query question server)))
	(when (and answers (not (keywordp answers)))
	  (return
	    (values (mapcar #'message-resource-record-data
			    answers)
		    (message-resource-record-name (first answers)))))))))

))

#!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-addresses-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-address* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (stub-send-dns-query question server)))
	(when (and answers (not (keywordp answers)))
	  (return
	    (values (mapcar #'message-resource-record-data
			    answers)
		    (message-resource-record-name (first answers)))))))))

))

#!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-name-of-address (address servers)
  (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))))
      (let ((question (make-message-question :name dom-string :type *type-pointer* :class *class-internet*)))	
	(dolist (server servers)
	  (let ((answers (stub-send-dns-query question server)))
	    (when (and answers (not (keywordp answers)))
	      (return
		(values (mapcar #'message-resource-record-data
				answers)
			(message-resource-record-name (first answers)))))))))))

))

#!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-host-info-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-host-info* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (stub-send-dns-query question server)))
	(when (and answers (not (keywordp answers)))
	  (return
	    (let ((hinfo (message-resource-record-data (first answers))))
	      (values (parse-hinfo-to-keywords hinfo)
		      (message-resource-record-name (first answers))))))))))

))

#!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-wks-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-well-known-service* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (stub-send-dns-query question server)))
	(when (and answers (not (keywordp answers)))
	  (return
	    (values (mapcar #'message-resource-record-data answers)
		    (message-resource-record-name (first answers)))))))))

;;; **** KLUDGE **** for stub-namespace optimization

))

#!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-any-info-of-name (name servers)
  (let ((question (make-message-question :name name :type *type-wild-request* :class *class-internet*)))
    (dolist (server servers)
      (let ((answers (stub-send-dns-query question server)))
	(when (and answers (not (keywordp answers)))
	  (return
	    (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)))))))))

))

#!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-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))
    (let ((names (stub-get-name-of-address (first addresses) servers)))
      (values (or (first names) original-name)
	      addresses))))


))