;;; -*- Mode:LISP; Package:user; Readtable:CL; Base:10 -*-
;;;
;;; utility for determining mail-routing for unix machines
;;;
;;; -dg 3/3/86
;;;


(defconst *local-mail-machines*
	  `(,(si:parse-host "angel")
	    ,(si:parse-host "cap")
	    ,(si:parse-host "fred")
	    ,(si:parse-host "lad")))

(defconst *valid-uucp-hosts* '(:|mitccc| :|ayesha|))

(defconst *outside-addresses-always-valid* t)

(defconst *default-aliases-file-path* "/usr/lib/aliases")

(defconst *default-passwd-file-path* "/etc/passwd")

(defconst *host-mail-routing-alist* nil)

(defconst *parse-address-check* t)

(defun parse-random-address (string)
  (let ((current-start 0)
	uucp-addresses
	uucp-address-encountered
	outside-addresses
	outside-address-encountered
	local-address
	local-address-encountered
	name)
    (do ((loc (string-search-char #\! string current-start)
	      (string-search-char #\! string current-start)))
	((null loc))
      (setq uucp-address-encountered t)
      (push (intern (nsubstring string current-start loc) pkg-keyword-package) uucp-addresses)
      (setq current-start (add1 loc)))
    (do ((loc (string-search-char #\% string current-start)
	      (string-search-char #\% string current-start))
	 (first-time t nil))
	((null loc))
      (setq outside-address-encountered t)
      (if first-time
	  (setq name (intern (nsubstring string current-start loc) pkg-keyword-package))
	(push (intern (nsubstring string current-start loc) pkg-keyword-package) outside-addresses))
      (setq current-start (add1 loc)))
    (do ((loc (string-search-char #\@ string current-start)
	      (string-search-char #\@ string current-start))
	 (first-time t nil))
	((null loc))
      (setq local-address-encountered t)
      (if first-time
	  (if outside-address-encountered
	      (push (intern (nsubstring string current-start loc) pkg-keyword-package) outside-addresses)
	    (setq name (intern (nsubstring string current-start loc) pkg-keyword-package)))
	(push (intern (nsubstring string current-start loc) pkg-keyword-package) outside-addresses))
      (setq current-start (add1 loc)))
    (when local-address-encountered
      (setq local-address (nsubstring string current-start)))
    (when (null name)
      (setq name (nsubstring string current-start)))
    (let ((return-value (list :address :name (intern name pkg-keyword-package))))
      (when local-address
	(rplacd (last return-value) (list :local (si:parse-host local-address))))
      (when uucp-addresses
	(rplacd (last return-value) (list :uucp uucp-addresses)))
      (when outside-addresses
	(rplacd (last return-value) (list :outside (reverse outside-addresses))))
      (when *parse-address-check*
	(let ((regenerated-address (generate-random-address return-value local-address)))
	  (unless (string-equal string regenerated-address)
	    (ferror nil "Regenerated address string does not match original..."))))
      return-value)))

(defun generate-random-address (plist local-host-specified)
  (let ((string ""))
    (dolist (host (get plist :uucp))
      (setq string (string-append host "!" string)))
    (setq string (string-append string (get plist :name)))
    (dolist (outside (get plist :outside))
      (setq string (string-append string "%" outside)))
    (when local-host-specified
      (setq string (string-append string "@" local-host-specified)))
    string))

(defun parse-passwd-entry (line output-to)
  (let* ((name-end
	   (string-search ":" line))
	 (name
	   (nsubstring line 0 name-end))
	 (password-end
	   (string-search ":" line (add1 name-end)))
	 (password
	   (nsubstring line (add1 name-end) password-end))
	 (account-end
	   (string-search ":" line (add1 password-end)))
	 (account
	   (read-from-string line t nil :start (add1 password-end) :end account-end))
	 (group-end
	   (string-search ":" line (add1 account-end)))
	 (group
	   (read-from-string line t nil :start (add1 account-end) :end group-end))
	 (full-name-end
	   (string-search ":" line (add1 group-end)))
	 (full-name
	   (nsubstring line (add1 group-end) full-name-end))
	 (homedir-end
	   (string-search ":" line (add1 full-name-end)))
	 (homedir
	   (nsubstring line (add1 full-name-end) homedir-end))
	 ;; for grunts
	 (default-shell-path
	   (nsubstring line (add1 homedir-end))))
    password
    account
    group
    default-shell-path
    (when output-to
      (format output-to "~&~A {~A - [~d,~d]} ==> ~A"
	      full-name
	      name
	      group
	      account
	      homedir))
    (list (intern name pkg-keyword-package)
	  :full-name full-name
	  :homedir homedir
	  )))

(defun parse-passwd-file (host &key
			  (file-path *default-passwd-file-path*)
			  output-to
			  &aux return-list)
  (with-open-file (stream (fs:parse-pathname file-path host)
			  :direction :input)
    (do-forever
      (multiple-value-bind (line eof?)
	  (send stream :line-in)
	(when eof?
	  (return-from parse-passwd-file (reverse return-list)))
	(if (char-equal (aref line 0) #\#)
	    ;;; just in case there's a comment
	    (when output-to
	      (format output-to
		      line))
	  (push (parse-passwd-entry line output-to) return-list))))))


(defun parse-alias-entry (string)
  (case (aref string 0)
    ((#\| #\") `(:program ,string))
    (#\/ `(:path ,string))
    (t (parse-random-address string))))
	    
(defun parse-alias-from-stream (stream output-to)
  (do (line eof? finished?)
      (finished? finished?)
    (multiple-value-setq (line eof?) (send stream :line-in))
    (cond
      (eof? (setq finished? :eof))
      ((zerop (string-length line)))
      ((char-equal #\# (aref line 0))
       (when output-to
	 (format output-to "~&~A" line)))
      ((not (string-search-char #\: line))
       (ferror nil "Alias first line invalid: \"~A\"" line))
      (t
       (do* ((alias-name-end (string-search-char #\: line))
	     (alias-name (nsubstring line 0 alias-name-end))
	     (rest-of-line (string-trim '(#\ #\tab) (nsubstring line (add1 alias-name-end))))
	     (this-entry-begin 0)
	     (this-entry-end-normal (string-search-char #\, rest-of-line this-entry-begin)
				    (string-search-char #\, rest-of-line this-entry-begin))
	     this-entry
	     collected-entries
	     done?)
	    (done? (setq finished?
			 (cons (intern alias-name pkg-keyword-package)
			       (reverse collected-entries))))
	 (if (not this-entry-end-normal)
	     (let ((string (string-trim '(#\ #\tab) (nsubstring rest-of-line this-entry-begin))))
	       (if (zerop (string-length string))
		   (multiple-value-bind (next-line next-line-eof?)
		       (send stream :line-in)
		     (cond (next-line-eof?
			    (ferror nil "End of file in the middle of alias ~S" alias-name))
			   ((string-search-char #\# next-line)
			    (ferror nil "Comment between lines of alias ~S" alias-name))
			   ((zerop (length next-line))
			    (ferror nil "Empty line between line of alias ~s" alias-name))
			   ((not (memq (aref next-line 0) '(#\ #\tab)))
			    (ferror nil
				    "Continuation of alias ~S does not begin with whitespace."
				    alias-name)))
		     (setq rest-of-line (string-trim '(#\ #\tab) next-line)
			   this-entry-begin 0))
		 (push (parse-alias-entry
			 (nsubstring string
				     0
				     (or (string-search-char #\# string)
					 (length string))))
		       collected-entries)
		 (setq done? t)))
	   (setq this-entry
		 (string-trim '(#\ #\tab)
			      (nsubstring rest-of-line this-entry-begin this-entry-end-normal)))
	   (push (parse-alias-entry this-entry) collected-entries)
	   (setq this-entry-begin (add1 this-entry-end-normal))))))))

(defun parse-aliases-file (host &key
			   (file-path *default-aliases-file-path*)
			   output-to
			   &aux return-list)
  (with-open-file (stream (fs:parse-pathname file-path host)
			  :direction :input)
    (do ((entry (parse-alias-from-stream stream output-to)
		(parse-alias-from-stream stream output-to)))
	((eq entry :eof) (reverse return-list))
      (push entry return-list))))

(defun get-user-forwarding-list (passwd-list host &rest return-list)
  (dolist (user passwd-list (reverse return-list))
    (let ((pathname (fs:parse-pathname
		      (string-append (get user :homedir) "/.forward")
		      host)))
      (when (condition-case ()
		(probef pathname)
	      (fs:file-request-failure)		;probably access denied
	      )
	(with-open-file (forward-file pathname :direction :input)
	  (do (line eof? result)
	      (result (push result return-list))
	    (multiple-value-setq (line eof?) (send forward-file :line-in))
	    (setq line (string-trim '(#\ #\tab) line))
	    (cond (eof?
		   (ferror nil "End of file processing .forward file for \"~A@~A\"."
			   (car user)
			   host))
		  ((zerop (length line)))
		  ((eq (aref line 0) #\#))
		  (t (setq result (parse-random-address line))))))))))

(defun get-host-mail-routing-list (host)
  (let* ((true-host (si:parse-host host))
	 (passwd-plist (parse-passwd-file true-host))
	 (aliases-list (parse-aliases-file true-host))
	 (user-forwarding-list (get-user-forwarding-list passwd-plist true-host)))
    (dolist (user-forward user-forwarding-list)
      (let ((place (assq (get user-forward :name) passwd-plist)))
	(if (null place)
	    (ferror nil "Found .forward file but no entry in passwd list for user ~A on host ~A."
		    (car user-forward) host)
	  (putprop place (cdr user-forward) :user-forwarding-entry))))
    (dolist (alias aliases-list)
      (let ((place (assq (car alias) passwd-plist)))
	(if place
	    (cond ((get place :user-forward-entry)
		   (tv:beep)
		   (format t "~&There is a .forward file and an alias entry for ~
                               user ~A on host ~A."
			   (car alias) host))
		  ((get place :alias)
		   (tv:beep)
		   (format t "~&There are two alias entries for user ~A on host ~A"
			   (car alias) host))
		  (t (putprop place (cdr alias) :alias)))
	  (push (list (car alias) :alias (cdr alias)) passwd-plist))))
    (sortcar passwd-plist 'string-lessp)))

(defun setup-host-mail-routing-alist (&aux return-list)
  (dolist (host *local-mail-machines*
		(setq *host-mail-routing-alist* (reverse return-list)))
    (format t "~&Processing mail routing information for host: ~A"
	    (si:parse-host host))
    (push (cons (si:parse-host host)
		(get-host-mail-routing-list host))
	  return-list)))

(defun uucp-addresses-valid (address)
  (or (null (get address :uucp))
      (dolist (host (get address :uucp) t)
	(unless (memq host *valid-uucp-hosts*)
	  (return-from uucp-addresses-valid nil)))))

(defun local-address-valid (address)
  (or (null (get address :local))
      (memq (get address :local) *local-mail-machines*)))

(defun outside-address-valid (ignore)
  (or *outside-addresses-always-valid*
      (ferror nil "Can't check the validity of outside addresses yet.")))

(defun check-address-validity (address name host)
  (ecase (car address)
    (:address
     (let ((valid? t))
       (unless (local-address-valid address)
	 (setq valid? nil)
	 (format t "~&Host ~A (in \"~A\" definition on ~A) is not a local unix mail machine."
		 (get address :local) name host))
       (unless (uucp-addresses-valid address)
	 (setq valid? nil)
	 (format t "~&UUCP host ~A (in \"~A\" definition on ~A) is not a known uucp host."
		 (get address :uucp) name host))
       valid?))
    (:path
     (condition-case (condition)
	 (let ((found (probef (fs:parse-pathname (cadr address) host))))
	   (if found
	       t
	     (format t "~&File \"~A\" does not exist for alias \"~A\" on ~A"
		     (cadr address) name host)
	     nil))
       (fs:file-request-failure
	(format t "~&File request failure checking path \"~A\" for alias \"~A\" on ~A"
		(cadr address) name host)
	nil)))
    (:program t)))

(defun find-invalid-addresses (routing-alist &aux bad-list)
  (dolist (host-list routing-alist (reverse bad-list))
    (dolist (dest (cdr host-list))
      (dolist (address (get dest :alias))
	(unless (check-address-validity address (car dest) (car host-list))
	  (push (cons (car dest) address) bad-list))))))

(defun get-alias-distribution (alias host)
  (assq (intern alias pkg-keyword-package)
	(cdr (assq (si:parse-host host) *host-mail-routing-alist*))))