;;; -*- Mode:Common-Lisp; Package:DOMAIN-NAME-SYSTEM; Base:10 -*-
;;; 11-Apr-88 19:11:52, Björn Victor
;;; Copyright (c) 1988, Björn Victor, Department of Computer Systems, Uppsala University

;;;; Parsing and unparsing of DNS messages.

(defvar *assigned-ip-ports-alist* nil
  "Alist from port number to port name (as a keyword).  See RFC1010 for details.")
(defvar *assigned-ip-ports-file* "DNS:CONFIG;ASSIGNED-PORTS.TEXT"
  "File to read assigned port numbers/names from.")

(defun initialize-ip-port-names-and-numbers ()
  (setq *assigned-ip-ports-alist* (read-ip-port-names-and-numbers *assigned-ip-ports-file*)))
    
(defun read-ip-port-names-and-numbers (from-file)
  (with-open-file (s from-file)
    (let ((port-alist nil)
	  (kwd-pkg (find-package "KEYWORD")))
      (loop
	(let ((port (read s nil nil))
	      (kwd (let ((*package* kwd-pkg))
		     (read s nil nil))))
	  (if (or (null port) (null kwd))
	      (return (nreverse port-alist))
	      (push (cons port kwd) port-alist)))))))

#+LISPM
(defun initialize-ip-port-names-and-numbers-lispm ()
  #+TI
  (let ((pathname (pathname *assigned-ip-ports-file*)))
    (net:with-host-accessible (pathname-host pathname)
      (initialize-ip-port-names-and-numbers)))
  #-TI
  (sys:with-sys-host-accessible
    (initialize-ip-port-names-and-numbers)))

#+LISPM
(sys:add-initialization "Initialize IP port names and numbers" '(initialize-ip-port-names-and-numbers-lispm) '(:first))


(defun get-message-packet (pkt)
  (let ((msg (make-message :header (make-message-header) :questions nil :answers nil :authorities nil :additionals nil))
	(auth-p (raw-header-authoritative-p pkt)))
    ;; Parse header
    (setf (message-header-id (message-header msg)) (raw-header-id pkt)
	  (message-header-response-p (message-header msg)) (raw-header-response-p pkt)
	  (message-header-opcode (message-header msg)) (raw-header-opcode pkt)
	  (message-header-authoritative-p (message-header msg)) (raw-header-authoritative-p pkt)
	  (message-header-truncated-p (message-header msg)) (raw-header-truncated-p pkt)
	  (message-header-recursion-desired (message-header msg)) (raw-header-recursion-desired pkt)
	  (message-header-recursion-available (message-header msg)) (raw-header-recursion-available pkt)
	  (message-header-zero (message-header msg)) (raw-header-zero pkt)
	  (message-header-response-code (message-header msg)) (raw-header-response-code pkt)
	  (message-header-question-count (message-header msg)) (raw-header-question-count pkt)
	  (message-header-answer-count (message-header msg)) (raw-header-answer-count pkt)
	  (message-header-authority-count (message-header msg)) (raw-header-authority-count pkt)
	  (message-header-additional-count (message-header msg)) (raw-header-additional-count pkt)
	  )
    ;; Questions section
    (dotimes (i (raw-header-question-count pkt) (setf (message-questions msg) (nreverse (message-questions msg))))
      (push (make-message-question :name (query-name pkt i)
				:type (query-type pkt i)
				:class (query-class pkt i))
	    (message-questions msg)))
    (with-frozen-ttl
      ;; Answer section
      (dotimes (i (raw-header-answer-count pkt) (setf (message-answers msg) (nreverse (message-answers msg))))
	(let ((type (answer-type pkt i))
	      (class (answer-class pkt i)))
	  (push (make-message-resource-record
		  :name (answer-name pkt i)
		  :type type
		  :class class
		  :time-to-live (make-absolute-ttl (answer-time-to-live pkt i))
		  :data (get-resource-data pkt (answer-data-index pkt i) (answer-data-length pkt i) type class)
		  :authoritative-p auth-p)
		(message-answers msg))))
      ;; Authoritative section
      (dotimes (i (raw-header-authority-count pkt) (setf (message-authorities msg) (nreverse (message-authorities msg))))
	(let ((type (authority-type pkt i))
	      (class (authority-class pkt i)))
	  (push (make-message-resource-record
		  :name (authority-name pkt i)
		  :type type
		  :class class
		  :time-to-live (make-absolute-ttl (authority-time-to-live pkt i))
		  :data (get-resource-data pkt (authority-data-index pkt i) (authority-data-length pkt i) type class)
		  :authoritative-p auth-p)
		(message-authorities msg))))
      ;; Additional section
      (dotimes (i (raw-header-additional-count pkt) (setf (message-additionals msg) (nreverse (message-additionals msg))))
	(let ((type (additional-type pkt i))
	      (class (additional-class pkt i)))
	  (push (make-message-resource-record
		  :name (additional-name pkt i)
		  :type type
		  :class class
		  :time-to-live (make-absolute-ttl (additional-time-to-live pkt i))
		  :data (get-resource-data pkt (additional-data-index pkt i) (additional-data-length pkt i) type class)
		  :authoritative-p auth-p)
		(message-additionals msg))))
      )
    msg))

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

(defun parse-wks-ip-ports (ports)
  (when ports
    (let ((portns nil))
      (dolist (p ports (setq portns (nreverse portns)))
	(let ((pn (or (car (rassoc p *assigned-ip-ports-alist* :test #'eq)) (and (numberp p) p))))
	  (if pn
	      (pushnew pn portns :test #'=)
	      (cerror "Ignore ~s and proceed" "Unknown port in WKS for IP: ~s" p))))
      (let ((max (apply #'max portns)))
	(let ((bitmap (make-array (ceiling max 8) :element-type '(unsigned-byte 8) :initial-element 0)))
	  (dolist (p portns)
	    (multiple-value-bind (nth-byte nth-bit)
		(floor p 8)
	      (setf (logbitp (- 7 nth-bit) (aref bitmap nth-byte)) 1)))
	  bitmap)))))

(defun parse-message (msg)
  (declare (values pkt length))
  (check-type msg message "a DNS message")
  (check-type (message-header msg) message-header "a DNS message header")
  (let ((pkt (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0))
	(hdr (message-header msg))
	(packet-total-length 12))		;Header length
    (setf (raw-header-id pkt) (message-header-id hdr)
	  (raw-header-response-p pkt) (message-header-response-p hdr)
	  (raw-header-opcode pkt) (message-header-opcode hdr)
	  (raw-header-authoritative-p pkt) (message-header-authoritative-p hdr)
	  (raw-header-truncated-p pkt) (message-header-truncated-p hdr)
	  (raw-header-recursion-desired pkt) (message-header-recursion-desired hdr)
	  (raw-header-recursion-available pkt) (message-header-recursion-available hdr)
	  (raw-header-zero pkt) 0 ;(message-header-zero hdr)
	  (raw-header-response-code pkt) (message-header-response-code hdr)
	  (raw-header-question-count pkt) (message-header-question-count hdr)
	  (raw-header-answer-count pkt) (message-header-answer-count hdr)
	  (raw-header-authority-count pkt) (message-header-authority-count hdr)
	  (raw-header-additional-count pkt) (message-header-additional-count hdr)
	  )
    ;; Questions
    (let ((qs (message-questions msg)))
      (dotimes (i (message-header-question-count hdr))
	(let ((q (nth i qs)))
	  (multiple-value-bind (dname dname-length)
	      (parse-domain-name (message-question-name q))
	    (setf (query-name pkt i) dname
		  (query-type pkt i) (message-question-type q)
		  (query-class pkt i) (message-question-class q))
	    ;; Account for length of question
	    (incf packet-total-length (+ dname-length 4))))))
    (with-frozen-ttl
      ;; Answer section
      (let ((as (message-answers msg)))
	(dotimes (i (message-header-answer-count hdr))
	  (let ((a (nth i as)))
	    (let ((type (message-resource-record-type a))
		  (class (message-resource-record-class a)))
	      (multiple-value-bind (dname dname-length)
		  (parse-domain-name (message-resource-record-name a))
		(multiple-value-bind (data data-length)
		    (parse-resource-record-data (message-resource-record-data a) type class)
		  (setf (answer-name pkt i) dname
			(answer-type pkt i) type
			(answer-class pkt i) class
			(answer-time-to-live pkt i) (make-relative-ttl (message-resource-record-time-to-live a))
			(answer-data-length pkt i) data-length)
		  (let ((idx (answer-data-index pkt i)))
		    (setf (subseq pkt idx (+ idx data-length)) data))
		  ;; Account for length of answer
		  (incf packet-total-length (+ dname-length 10 data-length))))))))
      ;; Authority section
      (let ((as (message-authorities msg)))
	(dotimes (i (message-header-authority-count hdr))
	  (let ((a (nth i as)))
	    (let ((type (message-resource-record-type a))
		  (class (message-resource-record-class a)))
	      (multiple-value-bind (dname dname-length)
		  (parse-domain-name (message-resource-record-name a))
		(multiple-value-bind (data data-length)
		    (parse-resource-record-data (message-resource-record-data a) type class)
		  (setf (authority-name pkt i) dname
			(authority-type pkt i) type
			(authority-class pkt i) class
			(authority-time-to-live pkt i) (make-relative-ttl (message-resource-record-time-to-live a))
			(authority-data-length pkt i) data-length)
		  (let ((idx (authority-data-index pkt i)))
		    (setf (subseq pkt idx (+ idx data-length)) data))
		  ;; Account for length
		  (incf packet-total-length (+ dname-length 10 data-length))))))))
      ;; Additional section
      (let ((as (message-additionals msg)))
	(dotimes (i (message-header-additional-count hdr))
	  (let ((a (nth i as)))
	    (let ((type (message-resource-record-type a))
		  (class (message-resource-record-class a)))
	      (multiple-value-bind (dname dname-length)
		  (parse-domain-name (message-resource-record-name a))
		(multiple-value-bind (data data-length)
		    (parse-resource-record-data (message-resource-record-data a) type class)
		  (setf (additional-name pkt i) dname
			(additional-type pkt i) type
			(additional-class pkt i) class
			(additional-time-to-live pkt i) (make-relative-ttl (message-resource-record-time-to-live a))
			(additional-data-length pkt i) data-length)
		  (let ((idx (additional-data-index pkt i)))
		    (setf (subseq pkt idx (+ idx data-length)) data))
		  ;; Account for length
		  (incf packet-total-length (+ dname-length 10 data-length))))))))
      )
    (values pkt packet-total-length)))