;;; -*- Mode: Common-Lisp; Package: DOMAIN-NAME-SYSTEM; Base: 10.; Patch-File: T -*-
;;; Written 27-Apr-89 14:13:56 by Victor,
;;; Reason: Added support for CHAOS addresses and well-known-services.
;;; 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.123,
;;;  Experimental ICU-DOCS 12.2, Experimental SYSTEM-ENHANCEMENTS 19.5, Experimental TCP-IMAGEN 10.0,
;;;  Experimental NAME-DRAGON 4.1, Experimental TEXINFO 5.5, Experimental ICU-LIBRARY 14.2,
;;;  Experimental DOMAIN 5.0, Experimental STUB-RESOLVER 2.6,  microcode 534, Band Name: 4.61 w DNS & Prolog,
;;;  890104/Vic

#!C
; From file ACCESSORS.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; ACCESSORS.#"



(defstruct chaos-address
  (domain "" :type list)
  (address 0 :type (unsigned-byte 16)))

;; Host info

))

#!C
; From file ACCESSORS.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; ACCESSORS.#"



(defstruct (well-known-services-chaos-resource-data (:conc-name wks-chaos-))
  (contacts nil))


;;;; Debug

))

#!C
; From file ACCESSORS.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; ACCESSORS.#"



(defun decode-data-for-describe (pkt start len type class)
  (cond ((= type *type-canonical-name*)
	 (get-domain-name pkt start))
	((= type *type-host-info*)
	 (cons (get-character-string pkt start)
	       (get-character-string pkt (+ start (8b-ref pkt start) 1))))
	((= type *type-mailbox*)
	 (get-domain-name pkt start))
	((= type *type-mail-destination*)
	 (get-domain-name pkt start))
	((= type *type-mail-forwarder*)
	 (get-domain-name pkt start))
	((= type *type-mail-group*)
	 (get-domain-name pkt start))
	((= type *type-mail-info*)
	 (let ((resp-dom-len (domain-name-field-length pkt start)))
	   (cons (get-domain-name pkt start)
		 (get-domain-name pkt (+ start resp-dom-len)))))
	((= type *type-mail-rename*)
	 (get-domain-name pkt start))
	((= type *type-mail-exchange*)
	 (cons (16b-ref pkt start)
	       (get-domain-name pkt (+ start 2))))
	((= type *type-null*)
	 (subseq pkt start (+ start len)))
	((= type *type-name-server*)
	 (get-domain-name pkt start))
	((= type *type-pointer*)
	 (get-domain-name pkt start))
	((= type *type-start-of-authority*)
	 (let* ((mname-len (domain-name-field-length pkt start))
		(rname-len (domain-name-field-length pkt (+ start mname-len))))
	   (list (get-domain-name pkt start)	;MNAME
		 (get-domain-name pkt (+ start mname-len))	;RNAME
		 (32b-ref pkt (+ start mname-len rname-len))	;SERIAL
		 (32b-ref pkt (+ start mname-len rname-len 4))	;REFRESH
		 (32b-ref pkt (+ start mname-len rname-len 4 4))	;RETRY
		 (32b-ref pkt (+ start mname-len rname-len 4 4 4))	;EXPIRE
		 (32b-ref pkt (+ start mname-len rname-len 4 4 4 4))	;MINIMUM
		 )))
	((= type *type-text*)
	 (do ((data nil)
	      (s start (+ s 1 (8b-ref pkt s)))
	      (e (+ start len)))
	     ((>= s e) (nreverse data))
	   (push (get-character-string pkt s) data)))
	((and (= type *type-address*) (or (= class *class-internet*) (= class *class-chaos*)))
	 (cond ((= class *class-internet*)
		(format nil "~d.~d.~d.~d"
			(8b-ref pkt start) (8b-ref pkt (+ start 1)) (8b-ref pkt (+ start 2)) (8b-ref pkt (+ start 3))))
	       ((= class *class-chaos*)
		(let ((dname-len (domain-name-field-length pkt start)))
		  (format nil "~a|~o"
			  (get-domain-name pkt start)
			  (16b-ref pkt (+ start dname-len)))))))
	((and (= type *type-well-known-service*)
	      (or (= class *class-internet*) (= class *class-chaos*)))
	 (cond ((= class *class-internet*)
		(list (format nil "~d.~d.~d.~d"
			      (8b-ref pkt start) (8b-ref pkt (+ start 1)) (8b-ref pkt (+ start 2)) (8b-ref pkt (+ start 3)))
		      (8b-ref pkt (+ start 4))
		      (let ((bytes nil))
			(dotimes (i (- len 4) (nreverse bytes))
			  (push (format nil "~8,48b" (8b-ref pkt (+ start 4 i 1))) bytes)))))
	       ((= class *class-chaos*)
		(let ((n-contacts (16b-ref pkt start))
		      (contacts nil)
		      (idx 2))
		  (dotimes (i n-contacts)
		    (push (get-domain-name pkt (+ start idx)) contacts)
		    (incf idx (domain-name-field-length pkt (+ start idx))))
		  (format nil "~{~a~^, ~}" (nreverse contacts))))))
	(t (warn "~&>>Warning:  Unknown type/class combination in ~s: ~d/~d" 'decode-data-for-describe type class)
	   (subseq pkt start (+ start len)))))
))

#!C
; From file HIGH.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; HIGH.#"



(defun get-resource-data (raw-pkt start length type class)
  (ecase type					;Compiles to a SELECT, all (get-domain-name raw-pkt start) the same code.
    (#.*type-address*
     (cond ((= class *class-internet*)
	    (32b-ref raw-pkt start))
	   ((= class *class-chaos*)
	    (let ((dname-len (domain-name-field-length raw-pkt start)))
	      (make-chaos-address :domain (get-domain-name raw-pkt start)
				  :address (16b-ref raw-pkt (+ start dname-len)))))
	   (t
	    (n-byte-ref raw-pkt start length))))
    (#.*type-name-server*
     (get-domain-name raw-pkt start))
    (#.*type-mail-destination*
     (get-domain-name raw-pkt start))
    (#.*type-mail-forwarder*
     (get-domain-name raw-pkt start))
    (#.*type-canonical-name*
     (get-domain-name raw-pkt start))
    (#.*type-start-of-authority*
     (let* ((mname-len (domain-name-field-length raw-pkt start))
	    (rname-len (domain-name-field-length raw-pkt (+ start mname-len)))
	    (idx start))
       (make-start-of-authority-resource-data
	 :master (get-domain-name raw-pkt idx)
	 :responsible (get-domain-name raw-pkt (incf idx mname-len))
	 :serial-number (32b-ref raw-pkt (incf idx rname-len))
	 :refresh-interval (32b-ref raw-pkt (incf idx 4))
	 :retry-interval (32b-ref raw-pkt (incf idx 4))
	 :expire-interval (32b-ref raw-pkt (incf idx 4))
	 :minimum-ttl (32b-ref raw-pkt (incf idx 4))
	 )))
    (#.*type-mailbox*
     (get-domain-name raw-pkt start))
    (#.*type-mail-group*
     (get-domain-name raw-pkt start))
    (#.*type-mail-rename*
     (get-domain-name raw-pkt start))
    (#.*type-null*
     (subseq raw-pkt start (+ start length)))
    (#.*type-well-known-service*
     (cond ((= class *class-internet*)
	    (make-well-known-services-ip-resource-data
	      :address (32b-ref raw-pkt start)
	      :protocol (8b-ref raw-pkt (+ start 4))
	      :ports (let ((ports nil))
		       (dotimes (i (- length 5) (nreverse ports))
			 (let ((byte (8b-ref raw-pkt (+ start 5 i))))
			   (unless (zerop byte)
			     (dotimes (n 8)
			       (when (logbitp (- 7 n) byte)
				 ;; This should be changed to just push X later.  Names are nice for debugging.
				 (let* ((x (+ (* i 8) n))
					(y (cdr (assoc x *assigned-ip-ports-alist* :test #'=))))
				   (push (or y x) ports))))))))
	      ))
	   ((= class *class-chaos*)
	    (let ((n-services (16b-ref raw-pkt start))
		  (contacts nil)
		  (idx 2))
	      (dotimes (i n-services)
		(push (get-domain-name raw-pkt (+ start idx))
		      contacts)
		(incf idx (domain-name-field-length raw-pkt (+ start idx))))
	      (make-well-known-services-chaos-resource-data :contacts contacts)))
	   (t
	    (subseq raw-pkt start (+ start length)))))
    (#.*type-pointer*
     (get-domain-name raw-pkt start))
    (#.*type-host-info*
     (make-host-info-resource-data
       :cpu (get-character-string raw-pkt start)
       :os (get-character-string raw-pkt (+ start (8b-ref raw-pkt start) 1))))
    (#.*type-mail-info*
     (make-mail-info-resource-data
       :responsible (get-domain-name raw-pkt start)
       :errors-to (get-domain-name raw-pkt (+ start (domain-name-field-length raw-pkt start)))))
    (#.*type-mail-exchange*
     (make-mail-exchange-resource-data
       :preference (16b-ref raw-pkt start)
       :exchange (get-domain-name raw-pkt (+ start 2))))
    (#.*type-text*
     (do ((data nil)
	  (s start (+ s 1 (8b-ref raw-pkt s)))
	  (e (+ start length)))
	 ((>= s e) (nreverse data))
       (push (get-character-string raw-pkt s) data)))
    ))


;;; Parse structures, make packet

;;; This function conses all too many vectors, I think.

))

#!C
; From file HIGH.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; HIGH.#"


(defun parse-resource-record-data (data type class)
  (multiple-value-bind (value length)
      (ecase type				;Doesn't compile to a SELECT, because of multiple-value-bind above.
	(#.*type-address*
	 (cond ((= class *class-internet*)
		(etypecase data
		  #+Explorer
		  (string (net:parse-network-address data :ip))
		  (integer (make-32b data))))
	       ((= class *class-chaos*)
		(concatenate '(vector (unsigned-byte 8))
			     (parse-domain-name (chaos-address-domain data))
			     (make-16b (chaos-address-address data))))
	       (t
		data)))
	(#.*type-name-server*
	 (parse-domain-name data))
	(#.*type-mail-destination*
	 (parse-domain-name data))
	(#.*type-mail-forwarder*
	 (parse-domain-name data))
	(#.*type-canonical-name*
	 (parse-domain-name data))
	(#.*type-start-of-authority*
	 (concatenate '(vector (unsigned-byte 8))
		      (parse-domain-name (soa-master data))
		      (parse-domain-name (soa-responsible data))
		      (make-32b (soa-serial-number data))
		      (make-32b (soa-refresh-interval data))
		      (make-32b (soa-retry-interval data))
		      (make-32b (soa-expire-interval data))
		      (make-32b (soa-minimum-ttl data))))
	(#.*type-mailbox*
	 (parse-domain-name data))
	(#.*type-mail-group*
	 (parse-domain-name data))
	(#.*type-mail-rename*
	 (parse-domain-name data))
	(#.*type-null*
	 data)
	(#.*type-well-known-service*
	 (cond ((= class *class-internet*)
		(concatenate '(vector (unsigned-byte 8))
			     (make-32b (wks-ip-address data))
			     (make-8b (wks-ip-protocol data))
			     (parse-wks-ip-ports (wks-ip-ports data))))
	       ((= class *class-chaos*)
		(let ((contact-domains (mapcar #'parse-domain-name data)))
		  (apply #'concatenate '(vector (unsigned-byte 8))
			 (make-16b (length data))
			 contact-domains)))
	       (t
		data)))
	(#.*type-pointer*
	 (parse-domain-name data))
	(#.*type-host-info*
	 (concatenate '(vector (unsigned-byte 8))
		      (parse-character-string (host-info-cpu data))
		      (parse-character-string (host-info-os data))))
	(#.*type-mail-info*
	 (concatenate '(vector (unsigned-byte 8))
		      (parse-domain-name (mail-info-responsible data))
		      (parse-domain-name (mail-info-errors-to data))))
	(#.*type-mail-exchange*
	 (concatenate '(vector (unsigned-byte 8))
		      (make-16b (mail-exchange-preference data))
		      (parse-domain-name (mail-exchange-exchange data))))
	(#.*type-text*
	 (map '(vector (unsigned-byte 8))
	      #'parse-character-string data))
	)
    (values value (or length (length value)))))

))