;;; -*- Mode:LISP; Package:MAIL; Base:10; Readtable:T; Lowercase:T -*-
;;;
;;; Chaosnet Interface to the Mailer
;;;
;;; (c) 1985 Lisp Machine Incorporated
;;;

;;; The Store and Forward server
(defun mail-server-chaos (&aux final-ok qfile)
  (let ((user-id "Mail-Server"))
    (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
						     :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)))))

(defun get-mail-recipients (stream)
  (do ((line) (address-error-p) (result)
       (recipients nil))
      (nil)
    (setq line (funcall stream :line-in))
    (and (equal line "") (return (nreverse recipients)))
    (multiple-value (address-error-p result) (mailer-parse-address line))
    (cond (address-error-p
	   (format stream "-Bad address [~A]: ~A~%" line result))
	  ((and (stringp result)
		(not (address-existent-p result)))
	   (FORMAT STREAM "-Unknown user ~A.~%" result))
	  (t
	   (FORMAT STREAM "+Recipient address ~A ok.~%" result)
	   (PUSH result RECIPIENTS)))
    (force-output stream)))

(add-initialization "MAIL"
                    '(process-run-function "MAIL Server" 'mail-server-chaos)
                    nil
                    'chaos:server-alist)

;;; The delivery method

(defun chaos-delivery-single-host (host addresses text report-stream &aux s failed)
  (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 text report-stream &aux failed)
  (format report-stream "Attempting chaosnet delivery (~D addresses):"
	  (length addresses))
  (do ((addrs addresses (cdr addrs)) address host (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
			       (chaos-delivery-single-host host to-deliver text report-stream)))))))
    
(define-delivery-method chaos-mail (address)
			(and (eq (address-type address) :foreign)
			     (stringp (foreign-class address)))
			(addresses text report-stream)
  (chaos-delivery-method addresses text report-stream))


;;; Other non-standard features
;;; Update the mailing list remotely
	
(defun update-mailing-list-file (&optional (host (main-lm-mail-server-host)))
  (if (eq host si:local-host) (read-mailing-list-file)
    (with-open-stream (c (chaos:open-stream host "UPDATE-MAILING-LIST" :direction :input))
      (if (char= #\+ (read-char c)) (format t "~&Everything OK.~%")
	(format t "~&Error: ")
	(stream-copy-until-eof c standard-output)))))

(defun mailing-list-update-server-chaos ()
  (catch-error
    (as-mail-server (s (chaos:open-stream () "UPDATE-MAILING-LIST" :direction :output))
      (condition-case (error) (read-mailing-list-file)
	(error
	 (write-char #/- s)
	 (send error :report s))
	(:no-error (format s "+~A~%" error)))
      (force-output s))
    ()))

(add-initialization "UPDATE-MAILING-LIST"
                    '(process-run-function "Mailing List Updater"
					   'mailing-list-update-server-chaos)
                    nil
                    'chaos:server-alist)

;;; Standard CHAOSnet protocol EXPAND-MAILING-LIST
(defun expand-mailing-list-server ()
  (catch-error
    (as-mail-server (s (chaos:open-stream () "EXPAND-MAILING-LIST"))
      (loop
	(multiple-value-bind (line eofp) (read-line s)
	  (let ((initial (address-existent-p line)))
	    (flet ((address-out (user host)
		     (write-string user s)
		     (write-string "@" s)
		     (write-string (or host (send si:local-host :name)) s)))
	      (typecase initial
		(null (write-string "-No such address" s))
		(string
		 (write-line "+Local address" s)
		 (address-out initial nil))
		(list
		 (write-line "+Mailing list" s)
		 (dolist (address (expand-addresses initial))
		   (write-line (address-as-string address) s)))
		(error
		 (write-string "-Error in parsing address" s))
		(t
		 (write-string "-Internal error" s))))
	    (terpri s)
	    (force-output s)
	    (if eofp (return nil))))))
    nil))

(add-initialization "EXPAND-MAILING-LIST"
		    '(process-run-function "Expand Mailing List Server"
					   'expand-mailing-list-server)
		    nil
		    'chaos:server-alist)