;;; -*- Mode:LISP; Package:NETWORK; Readtable:CL; Base:10 -*-
;;;
;;; Stuff for parsing HOSTS2, network addresses.  NIC later
;;;

;;; Copyright LISP Machine, Inc. 1986
;;;   See filename "Copyright.Text" for
;;; licensing and release information.


(defun generate-from-hosts2-table (&optional input-file)
  (let ((default-input-file "SYS: CHAOS; HOSTS TEXT >")
	(si:*force-package* "CHAOS")
	(*read-base* 8) (*print-base* 8))
    (cond ((and (not input-file)		;if not specified 
		(not (probe-file default-input-file)))	;and reasonable file doesn't exist
	   (format *query-io* "~&Default host table input file not found.")
	   (setq input-file (global:prompt-and-read `(:pathname :defaults ,default-input-file)
					     "Please specify file to use instead: ")))
	  (t
	   (if (not input-file) (setq input-file default-input-file))))
    (generate-from-hosts2-table-1 input-file "SYS: SITE; HSTTBL LISP >")))

;;; System system transformation
(defun generate-from-hosts2-table-1 (input-file output-file)
  (let ((*package* (find-package "CHAOS"))
	(*read-base* 8) (*print-base* 8) (*print-radix* t)
	(*readtable* si:standard-readtable))
    (with-open-file (output-stream output-file :direction :output :characters t)
      (format output-stream "~
;;; -*- Mode: LISP;~@[ Package: ~A;~] Base: 8; Readtable:T -*-
;;; *** THIS FILE WAS AUTOMATICALLY GENERATED BY A PROGRAM, DO NOT EDIT IT ***
;;; Host table made from ~A~%"
	      si:*force-package* (send (fs:parse-pathname input-file) :truename))
      (si::write-responsibility-comment output-stream)
      (generate-from-hosts2-table-2 input-file output-stream)
      (when (global:get-site-option :non-chaos-host-table-file)
	(generate-from-hosts2-table-2 (global:get-site-option :non-chaos-host-table-file)
			       output-stream)))))

(defun read-hosts2-table (input-file)
  (let ((*package* (find-package "CHAOS"))
	(*read-base* 8) (*print-base* 8) (*print-radix* t)
	(*readtable* si:standard-readtable))
    (generate-from-hosts2-table-2 input-file nil)))

(defun generate-from-hosts2-table-2 (input-file output-stream)
  (with-open-file (input-stream input-file :direction :input :characters t)
    (do ((line) (eof)
	 (i) (j)
	 (ni) (nj)
	 (hostl) (delim)
	 (result))
	(nil)
      (multiple-value-setq (line eof)
	(send input-stream :line-in nil))
      (and eof (zerop (string-length line)) (return result))
      (multiple-value-setq (i j)
	(parse-hosts2-table-token line 0))
      (cond ((and i (string-equal line "HOST" :start1 i :end1 j))
	     ;; Host name
	     (multiple-value-setq (ni nj)
	       (parse-hosts2-table-token line (1+ j)))
	     (multiple-value-setq (i j delim)
	       (parse-hosts2-table-token line (1+ nj)))
	     (setq hostl (ncons (substring line ni nj)))
	     (if (char= delim #\[)
		 (do ((l nil)
		      (i1) (j1))
		     ((char= delim #\])
		      (incf j)
		      (nreverse l))
		   (multiple-value-setq (i1 j1 delim)
		     (parse-hosts2-table-token line (1+ j)))
		   (if (char= delim #\Sp)
		       (multiple-value-setq (i j delim)
			 (parse-hosts2-table-token line (1+ j1)))
		       (setq i i1 j j1 j1 i1))
		   (add-hosts2-table-address line i1 j1 i j hostl))
		 (let ((i1 i) (j1 j))
		   (if (char= delim #\Sp)
		       (multiple-value-setq (i j)
			 (parse-hosts2-table-token line (1+ j)))
		       (setq i i1 j j1 j1 i1))
		   (add-hosts2-table-address line i1 j1 i j hostl)))
;	     (COND ((OR (GET HOSTL :CHAOS)	;If there were any chaosnet addresses
;			;; Include some popular ARPA sites for speed in SUPDUP/TELNET, etc.
;			(SYS:MEMBER-EQUAL (CAR HOSTL) INCLUDED-NON-CHAOS-HOSTS))
	     (dotimes (k 2)
	       (multiple-value-setq (i j delim)
		 (parse-hosts2-table-token line (1+ j))))
	     (when i
	       (setf (get hostl :system-type) (intern (substring line i j) "")))
	     (multiple-value-setq (i j delim)
	       (parse-hosts2-table-token line (1+ j)))
	     (when i
	       (setf (get hostl :machine-type) (intern (substring line i j) "")))
	     (multiple-value-setq (i j delim)
	       (parse-hosts2-table-token line (1+ j)))
	     (or i (setq delim -1))
	     (let* ((first-name (car hostl))
		    (namel (ncons first-name)))
	       (and (char= delim #\[)
		    (do () ((char= delim #\])
			    (setq namel (stable-sort namel
						     #'(lambda (x y)
							 ;; EQ is OK here...
							 (and (not (eq x first-name))
							      (< (string-length x)
								 (string-length y)))))))
		      (multiple-value-setq (i j delim)
			(parse-hosts2-table-token line (1+ j)))
		      (unless (equal i j) ;kmc-dle's suggestion for avoiding null hostnames
			(push (substring line i j) namel))))
	       (setf (get hostl :host-names) namel))
	     (if output-stream
		 (let ((*package* (or (find-package si:*force-package*) *package*)))
		      (format output-stream "(~S ~S~{~%  '~S '~S~})~2%"
			      'si::define-host (car hostl) (cdr hostl)))
	       (push hostl result)))))))

(defun parse-hosts2-table-token (string &optional (start 0) end)
  (or end (setq end (length string)))
  (do ((idx start (1+ idx))
       (sidx) (ch))
      ((>= idx end)
       (values sidx idx -1))
    (setq ch (char string idx))
    (or sidx
	(member ch '(#\Sp #\Tab) :test #'eq)
	(setq sidx idx))
    (and sidx
	 (member ch '(#\, #\Sp #\Tab #\[ #\]) :test #'eq)
	 (return (values sidx idx ch)))))

(defun add-hosts2-table-address (line net-start net-end address-start address-end hostl
				 &aux symbol parser)
  (setq symbol (if (= net-start net-end) :arpa
		   (intern (substring line net-start net-end) "")))
  (when (setq parser (get symbol 'address-parser))
    (setf (get hostl symbol)		;Keep addresses in original order
	  (nconc (get hostl symbol)
		 (ncons (funcall parser symbol line address-start address-end))))))

(defun parse-address (address network-type &optional (start 0) (end (string-length address)))
  "Given a string, return the parsed address for NETWORK-TYPE, a keyword"
  (let ((parser (get network-type 'address-parser)))
    (if parser
	(funcall parser network-type address start end)
      (error "Unknown network address type ~S" network-type))))

;;; Initially supported network types.  This should be sufficient
(defun (:property :chaos address-parser) (ignore line start end)
  (parse-integer line :start start :end end :radix 8.))

(defun (:property :ru address-parser) (ignore line start end)
  (parse-integer line :start start :end end :radix 8.))

(defun parse-arpa-address (ignore line start end)
  (let ((slash (string-search-char #\/ line start end)))
    (dpb (parse-integer line :start start :end slash)
	 (byte 8. 9.)
	 (parse-integer line :start (1+ slash) :end end))))

(setf (get :arpa 'address-parser) 'parse-arpa-address)
(setf (get :rcc 'address-parser) 'parse-arpa-address)

(defun (:property :dial address-parser) (ignore line start end)
  (substring line start end))			;A phone number is just characters.

(defun parse-2part-octal-address (character line start end)
  (let ((sep (string-search-char character line start end)))
    (dpb (parse-integer line :start start :end sep :radix 8.)
	 (byte 8 8)
	 (parse-integer line :start (1+ sep) :end end :radix 8.))))

(defun (:property :lcs address-parser) (ignore line start end)
  (parse-2part-octal-address #\/ line start end))

(defun (:property :su address-parser) (ignore line start end)
  (parse-2part-octal-address #\# line start end))

(defun parse-internet-address-component (string from to)
  (let ((number (parse-integer string :start from :end to :radix 10. :junk-allowed nil)))
    (cond ((null number)
	   (error "Non-number field (~A) in \"~A\"" (substring string from to) string))
	  ((or (> number 255.) (minusp number))
	   (error "Number (~D) out of range in Internet address" number))
	  (t number))))

(defun (:property :internet address-parser) (ignore line start end)  
  (do ((local-to 0) (idx 3) (address 0))
      ((= idx -1) address)
    (setq local-to (string-search-char #\. line start end))
    (if (null local-to)
	(if (zerop idx) (setq local-to end)
	  (error "Not enough fields for an Internet address")))
    (setq address
	  (dpb (parse-internet-address-component line start local-to)
	       (byte 8. (* 8. idx))
	       address))
    (decf idx)
    (setq start (+ local-to 1))))

;;; Generation of standard format host table files from the current state of the machine.
;;; Someday, there will be other keyword args for namespaces, filtering, date last changed,
;;; domain suffices, etc.
(defun dump-host-table-file (file format &rest keys)
  (let ((char (get format 'comment-character #\;))
	(handler (get format 'output-handler))
	(preamble-handler (get format 'preamble-handler))
	(postamble-handler (get format 'postamble-handler)))
    (if handler
	(with-open-file (out file :direction :output)
	  (si:write-responsibility-comment out char)
	  (when preamble-handler
	    (funcall preamble-handler out))
	  (apply #'dump-host-table-to-stream out handler keys)
	  (when postamble-handler
	    (funcall postamble-handler out)))
      (error "~S is not a known host table file format." format))))

(defun dump-host-table-to-stream (stream handler &rest keys)
  (si:do-all-hosts (h)
    (apply handler h stream keys)))

;;; Writes out all but the primary name, with name as file computer last.
(defun write-other-host-names (host stream separator  element-format)
  (let* ((names (send host :host-names))
	 (first-name (send host :name)))
    (loop for i from (- (length names) 1) downto 0
	  do (let ((name (elt names i)))
	       (unless (string= name first-name)
		 (format stream element-format name)
		 (unless (zerop i) (write-string separator stream)))))))

(defun unparse-address (address network-type)
  (funcall (or (get network-type 'si::address-unparser) 'si::default-address-unparser) address))

(defconstant default-hosts2-network-numbers '((:chaos . 7)))

(global:define-site-variable *hosts2-network-numbers* :hosts2-network-numbers
  "An alist of network types and numbers for HOSTS2 format tables.")

(defun write-hosts2-preamble (stream)
  (dolist (e (or *hosts2-network-numbers* default-hosts2-network-numbers))
    (format stream "NET ~A, ~O~%" (car e) (cdr e)))
  (terpri stream))

(setf (get :hosts2 'preamble-handler) 'write-hosts2-preamble)

(defun (:property :hosts2 output-handler) (host stream &rest ignore)
  (let ((as (send host :chaos-addresses)))
    (when as
      (format stream "HOST ~A,~C" (send host :name) #\Tab)
      (cond ((null (cdr as)) ; only one address
	     (format stream "CHAOS ~O," (first as)))
	    (t
	     (write-char #\[ stream)
	     (format:print-list stream "CHAOS ~O" as ",")
	     (write-string "]," stream)))
      ;; Don't sweat the USER/SERVER detritus for now...
      (format stream "USER,~A,~A,[" (send host :system-type) (send host :machine-type))
      (write-other-host-names host stream "," "~A")
      (write-line "]" stream))))

;;; We really can't do the NIC format yet because we don't save information about protocols.

;;; Then there is the extended NIC format which includes Chaosnet.

;;; Stupid Unix Internet table format (but it's stupid enough for us !).
;;; Seems to allow only one Internet address per host.
(setf (get :unix-internet 'comment-character) #\#)

(defun (:property :unix-internet output-handler) (host stream &rest ignore)
  (when (send host :network-typep :internet)
    (format stream "~A ~C~(~A~) "
	    (send host :unparsed-network-address :internet) #\Tab (send host :name))
    (write-other-host-names host stream " " "~(~A~)")
    (terpri stream)))