;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for Mailer version 2.2
;;; Reason:
;;;  Make the mailer more general, in preparation for SMTP support.
;;; Written 3-Sep-86 18:08:09 by RpK (Robert P. Krajewski) at site LMI Cambridge
;;; while running on Hastur the Unspeakable from band 2
;;; with System 110.232, Lambda-Diag 7.17, Experimental Local-File 68.7, FILE-Server 18.4, Unix-Interface 9.1, ZMail 65.14, Object Lisp 3.4, Tape 6.39, Site Data Editor 3.3, Tiger 24.0, KERMIT 31.3, Window-Maker 1.1, Gateway 4.8, TCP-Kernel 39.7, TCP-User 62.7, TCP-Server 45.5, MEDIUM-RESOLUTION-COLOR 3.4, MICRO-COMPILATION-TOOLS 3.2, System Revision Level 3.167, Experimental Mailer 2.1, microcode 1563, SDU Boot Tape 3.12, SDU ROM 102.



; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:08:10
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "


(defun terminal-warn-function (severity stream &rest format-args)
  (fresh-line stream)
  (write-string (symbol-name severity) stream)
  (write-string ": " stream)
  (apply #'format stream format-args)
  (fresh-line stream))

(defvar *warn-function* 'terminal-warn-function
  "Should take arguments of SEVERITY STREAM &REST FORMAT-ARGS")

(defun warn-stream (type stream &rest format-args)
  "Print a warning onto STREAM, which may be a server stream.
The FORMAT output should not output a newline.  TYPE is a keyword,
in the set {:DISK-FULL, :RANDOM-ERROR, :APPEND-ERROR}."
  (apply *warn-function* type stream format-args))

;;; This always appends new mail.
;;; Retuns either T (for success) or an error instance.  In the latter case, the
;;; negative or temporary negative message has already been sent.
;;; Does not rename the mail file at the present.  Too bad LMFS can't append.
;;; Locks out all other MAIL SERVER  FILE System activity.
(DEFUN FILE-DELIVER-MAIL (ADDRESS PATHNAME TEXT STREAM &OPTIONAL (INCLUDE-TAIL T))
  (WITH-LOCK (*MAIL-SERVER-LOCK*)
    (PROG ()
	  (WITH-OPEN-FILE-CASE (INFILE PATHNAME :DIRECTION :INPUT)
	    (FS:FILE-NOT-FOUND
	     (RETURN (FILE-DELIVER-MAIL-INTERNAL ADDRESS () PATHNAME TEXT STREAM INCLUDE-TAIL)))
	    (ERROR (warn-stream :append-error STREAM
				"Error opening for append: ~A" (SEND INFILE :REPORT-STRING))
		   (RETURN INFILE))
	    (:NO-ERROR
	     (RETURN (FILE-DELIVER-MAIL-INTERNAL ADDRESS INFILE PATHNAME TEXT STREAM
                                                 INCLUDE-TAIL)))))))

(DEFUNP FILE-DELIVER-MAIL-INTERNAL (ADDRESS INFILE PATHNAME TEXT STREAM INCLUDE-TAIL)
  (WITH-OPEN-FILE-CASE (OUTFILE PATHNAME :DIRECTION :OUTPUT)
    (FS:NO-MORE-ROOM
     (warn-stream :disk-full stream "Disk full, please try later.")
     (RETURN OUTFILE))
    (ERROR
     (warn-stream :random-error STREAM "Unexpected error for ~A: ~A"
		  ADDRESS (SEND OUTFILE :REPORT-STRING))
     (FORCE-OUTPUT STREAM)
     (RETURN OUTFILE))
    (:NO-ERROR
     (IF INFILE (STREAM-COPY-UNTIL-EOF INFILE OUTFILE))
     (write-STRING TEXT OUTFILE)
     (IF INCLUDE-TAIL (write-LINE "" OUTFILE))
     (IF INFILE (SEND INFILE :DELETE))
     (FORCE-OUTPUT STREAM))
     (RETURN T)))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:08:34
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "


(defmacro define-delivery-method (type (address) filter (addresses plist text report-stream) &body delivery)
  `(progn
     (defun (:property ,type deliver-filter) (,address)
       ,filter)
     (defun (:property ,type deliver-driver) (,addresses ,plist ,text ,report-stream)
       ,@delivery)
     (pushnew ',type *delivery-methods*)))

(defun deliver-mail (addresses plist text report-stream &aux failed filter to-deliver)
  (dolist (method *delivery-methods*)
    (setq to-deliver nil)
    (setq filter (get method 'deliver-filter))
    (dolist (address addresses)
      (when (funcall filter address)
	(push address to-deliver)
	(setq addresses (delq address addresses))))
    (when to-deliver
      (setq failed (nconc failed
			  (funcall (get method 'deliver-driver) to-deliver plist text report-stream)))))
  (if addresses
      (format report-stream "Warning: These addresses appear unreachable:~%~S~%" addresses))
  (setq failed (nconc addresses failed)))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:09:31
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(define-delivery-method append-to-file (address)
			(memq (address-type address) '(:name :file))
			(addresses plist text report-stream)
  (declare (ignore plist))
  (let ((failed ()))
    (dolist (address addresses)
      (if (errorp (file-deliver-mail address (mail-file-for-address address)
				     text report-stream))
	  (push address failed)
       (format report-stream "~&OK: ~S (local)" address)))
    failed))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:09:58
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(defun mail-deliver-qfile (qfile &optional (report-stream #'si:null-stream)
                           &aux recipients failed-recipients properties)
  (format report-stream "~&Attempting delivery of ~A:~%" qfile)
  (with-open-file-case (msg qfile)
    (error ()) ; don't have to try anything
    (:no-error
     (with-text-buffer (text msg)
       (setq properties
	     (let ((*read-base* 10.)
		   (*package* si:pkg-user-package)
		   (*readtable* si:standard-readtable))
	       (read msg)))
       (setq recipients (first properties))
       (get-mail-text msg text)
       (setq failed-recipients (deliver-mail recipients (cdr properties) text report-stream))
       (send msg :delete)
       (when failed-recipients
	 (when (= (incf (get properties :failures)) 1)
	   (setf (get properties :first-failure-date) (get-universal-time)))
	 (write-queue-file
	   (send qfile :new-pathname
		 :name (let ((name (send qfile :NAME)))
			 (if (string-equal "FAILED_" name :end2 7)
			     name
			  (string-append "FAILED_" name)))
		 :type "-Q-"
		 :version :newest)
	   failed-recipients (cdr properties) text report-stream)
	 (format report-stream "~&  Requeueing file.~%"))))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:10:11
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "


(defun reception-line (server-stream &optional (protocol "CHAOS-MAIL"))
  (explicit-reception-line (send (send server-stream :foreign-host) :name) protocol))

(defun explicit-reception-line (fromstring protocol)
  (multiple-value-bind (seconds minutes hours date month year dow dst-p) (time:get-time)
    (format () "Received: from ~A by ~A with ~A; ~A ~D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D-~A"
	    fromstring
	    (send si:local-host :name)
	    protocol
	    (time:day-of-the-week-string dow :short)
	    date
	    (time:month-string month :short)
	    year
	    hours
	    minutes
	    seconds
	    (time:timezone-string time:*timezone* dst-p))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:10:15
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(defun deliver-to-sorted-hosts (delivery-name function addresses plist text report-stream)
  "Returned a list of failed addresses.
FUNCTION should take the arguments (HOST ADDRESSES PLIST TEXT REPORT-STREAM) and
return a list of failed addresses."
  (format report-stream "~&Attempting ~A delivery (~D addresses):"
	  delivery-name (length addresses))
  (do ((addrs addresses (cdr addrs)) address host failed (to-deliver nil nil))
      ((null addrs) failed)
    (setq address (car addrs) host (foreign-class address))
    (cond ((null (setq host (si:parse-host host t)))
	   (format report-stream "~&Unknown host ~A" (foreign-class address))
	   (push address failed))
	  (t
	   (setq to-deliver (ncons address))
	   (dolist (a (cdr addrs))
	     (when (eq (si:parse-host (foreign-class a) t) host)
	       (push a to-deliver)
	       (setq addrs (delq a addrs))))
	   (setq failed (nconc failed
			       (funcall function host to-deliver plist text report-stream)))))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:10:48
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(DEFUN FROM-UNAME-FOR-DELIVERY (TEXT &AUX (UNAME "???") HTEXT EOF-P)
  (WITH-INPUT-FROM-STRING (S (MESSAGE-HEADERS-AND-TEXT TEXT))
    (DO () (EOF-P UNAME)
      (MULTIPLE-VALUE (HTEXT EOF-P) (read-line S))
      (WHEN
	(STRING-EQUAL "From:" (SUBSTRING HTEXT 0 5))
	(LET ((Z-UNAME (ZWEI:PARSE-ADDRESSES
			 (STRING-TRIM '(#\SP #\TAB)
				      (SUBSTRING HTEXT 5
						 (OR (STRING-SEARCH-CHAR #\CR HTEXT)
						     (STRING-LENGTH HTEXT)))))))
	  (typecase Z-UNAME
	    (null (setq uname "unknown"))
	    (string ; error
	     (setq uname "Unknown"))
	    (t
	     (let ((z-address (first z-uname)))
	       (SETQ UNAME (getf z-address :NAME))
	       (LET ((HOST (getf z-address :host)))
		 (when HOST
		   (IF (LISTP HOST)
		       (DOLIST (H HOST)
			 (IF (NON-LOCAL-MAIL-HOST-P H)
			     (SETQ UNAME (STRING-APPEND UNAME #/@ H))))
		     (IF (NON-LOCAL-MAIL-HOST-P HOST)
			 (SETQ UNAME (STRING-APPEND UNAME #/@ HOST))))))))))))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:11:14
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(defvar *simple-forwarding-alist* '()
  "An alist of hosts to which to forward, and what hosts are reachable through forwarding")

(defun set-simple-forwarding (host host-strings)
  (setq host (si:parse-host host))
  (assert (reachable-host-p host) (host) "Mail can't be forwarded to ~A" host)
  (let ((entry (lisp:assoc host *simple-forwarding-alist*)))
    (if entry
	(setf (cdr entry) host-strings)
      (push (cons host host-strings) *simple-forwarding-alist*)))
  host)

(defun load-simple-forwarding-data (host file)
  "Sets up the mailer so that the mail destined for hosts listed in FILE are sent to HOST.
FILE is simply names, one to a line."
  (set-simple-forwarding host (read-host-names file)))

(defun read-host-names (file)
  (with-open-file (in file)
    (do (line eofp names)
	(eofp (remove-duplicates names :test #'string-equal))
      (multiple-value-setq (line eofp) (read-line in nil))
      (when line
	(setq line (string-trim '(#\Space #\Tab) line))
	(unless (zerop (string-length line))
	  (push line names))))))


(defun find-forwarding-host (hostname)
  (let ((entry (lisp:rassoc hostname *simple-forwarding-alist*
			    :test #'(lambda (name list)
				      (lisp:member name list :test #'string-equal)))))
    (and entry (car entry))))

(defvar *direct-mail-connected-networks* '())

(defun add-direct-mail-connected-network (network)
  (pushnew network *direct-mail-connected-networks*))

(defun reachable-host-p (host)
  (dolist (network *direct-mail-connected-networks*)
    (when (send host :network-typep network)
      (return t))))

(defun host-name-on-network-p (name network-type)
  "Returns non-NIL if NAME names a host on NETWORK-TYPE."
  (let ((host (si:parse-host name t nil)))
    (when host
      (send host :network-typep network-type))))

(defun foreign-network-address-p (address network)
  (and (eq (address-type address) :foreign)
       (stringp (foreign-class address))
       (host-name-on-network-p (foreign-class address) network)))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:11:33
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(defun mailer-parse-address (string)
  ;; Speed up the most common case
  (if (not (string-search-set "%@()[]<>" string))
      (values nil string)
   (condition-case (a) (zwei:parse-addresses string)
     (error (values t (format () "Parse error for ~A" string)))
     (:no-error
      (if (stringp a)
	  (values t a) ; Error message
	(massage-parsed-address (car a) string))))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; MAIN.LISP#5 at 3-Sep-86 18:11:38
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; MAIN  "

(defun massage-parsed-address (a original)
  (let ((hs (getf a :host)))
    (if (null hs)
	(values nil (getf a :name))
     (let* ((last-host-string (car (last hs)))
	    (last-host (si:parse-host last-host-string t)))
       (cond ((null last-host)
	      (let ((fwd-host (find-forwarding-host last-host-string)))
		(if fwd-host
		    (values nil
			    (make-foreign-address :mailer-address original
						  :original-address original
						  :class (send fwd-host :name)))
		  (values t (format nil "Unknown host ~A" last-host-string)))))
	     ((eq last-host si:local-host)
	      (setf (getf a :host) (nbutlast hs))
	      (massage-parsed-address a original))
	     ((reachable-host-p last-host)
	      (values nil
		      (make-address :type :foreign
				    :options (make-foreign-address
					       :mailer-address
					       (mailer-address-for-other-host 
						 (butlast hs) (getf a :name))
					       :original-address original
					       :class (send last-host :name)))))
	     (t
	      (values t (format () "Unreachable host ~A" last-host-string))))))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; CHAOS.LISP#6 at 3-Sep-86 18:12:40
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; CHAOS  "


(defun chaos-mail-warn-function (type stream &rest format-args)
  (flet ((gwan (string)
	   (write-string string stream)
	   (apply #'format stream format-args)
	   (terpri stream)
	   (force-output stream)))
    (case type
      (:disk-full (gwan "%"))
      (:random-error (gwan "-"))
      (:append-error (gwan "-"))
      (otherwise (gwan (format nil "-[~A]" type))))))

;;; The Store and Forward server
(defun mail-server-chaos (&aux final-ok qfile)
  (let ((user-id "Mail-Server")
	(*warn-function* 'chaos-mail-warn-function))
    (ignoring-errors
      (as-mail-server (stream (chaos:open-stream nil "MAIL"))
	(send stream :add-as-server "MAIL")
	(ignoring-errors ; catch network lossage
	  (with-text-buffer (text stream)
	    (let ((recipients (expand-addresses (get-mail-recipients stream))))
	      (with-output-to-string (s text)
		(write-line (reception-line stream) s))
	      (get-mail-text stream text)
	      (finish-output stream)
	      (let ((result
		      (write-queue-file (setq qfile (qfile-name))
					recipients `(:failures 0
						     :source-network-type :chaos
						     :source-protocol :chaos-mail
						     :from ,(from-uname-for-delivery text)
						     :source-host ,(send stream :foreign-host))
					      TEXT STREAM)))
		(cond ((errorp result)
		       (setq final-ok ())
		       (if (probef qfile) (deletef qfile)))
		      (t
		       (setq final-ok :queued-ok))))))
	  (if final-ok (format stream "+Message sent successfully.~%"))
	  (force-output stream)))
	(when (and (eq final-ok :queued-ok)
		   (not *delay-delivery*))
	  (mail-deliver-qfile qfile)))))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; CHAOS.LISP#6 at 3-Sep-86 18:13:01
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; CHAOS  "


(defun chaos-delivery-single-host (host plist addresses text report-stream &aux s failed)
  (declare (ignore plist))
  (format report-stream "~&  Attempting delivery to ~A (~D addresses):~%"
	  host (length addresses))
  (condition-case (error)
      (unwind-protect
	  (progn
	    (setq s (chaos:open-stream host "MAIL"))
	    (dolist (a addresses)
	      (write-line (foreign-mailer-address a) s)
	      (force-output s)
	      (if (char= #\+ (read-char s))
		  (format report-stream "~&OK: ~A~%" (read-line s))
	       (format report-stream "~&Failure for ~S: ~A" a (read-line s))
	       (push a failed)))
	    (terpri s)
	    (write-string text s)
	    ;; >> No Common Lisp way of doing this.
	    (send s :eof)
	    (let ((first (read-char s)))
	      (if (char= #\+ first)
		  (format report-stream "~&Message queued~%")
	       (format report-stream "~&~:[Permanent~;Temporary~] failure: ~A~%"
		       (char= first #\-) (read-line s))
	       (setq failed addresses))))
	(when s (lisp:close s :abort t)))
    (error
     (format report-stream "Error while delivering: ~A" error)
     addresses) ; all addresses considered failed
    (:no-error failed)))

(defun chaos-delivery-method (addresses plist text report-stream)
  (deliver-to-sorted-hosts "Chaosnet" #'chaos-delivery-single-host
			   addresses plist text report-stream))

(define-delivery-method chaos-mail (address)
			(foreign-network-address-p address :chaos)
			(addresses plist text report-stream)
  (chaos-delivery-method addresses plist text report-stream))

))

; From modified file LAD: RELEASE-3.NETWORK.MAILER; CHAOS.LISP#6 at 3-Sep-86 18:13:06
#10R MAILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "MAILER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; MAILER; CHAOS  "

(add-direct-mail-connected-network :chaos)

))