;;; -*- 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 conn stream final-ok qfile (reject-p t))
  (let ((user-id "Mail-Server"))
    (catch-error
      (unwind-protect
	  (prog top ()
		(SETQ CONN (CHAOS:LISTEN "MAIL"))
		(WHEN *SERVER-ENABLED*
		  (SETQ REJECT-P NIL)
		  (CHAOS:ACCEPT CONN)
		  (SEND TV:WHO-LINE-FILE-STATE-SHEET :ADD-SERVER CONN "MAIL")
		  (setq stream (chaos:MAKE-stream conn))
		  (catch-error			; catch network lossage
		    (with-text-buffer (text stream)
				      (LET ((RECIPIENTS (EXPAND-ADDRESSES (GET-MAIL-RECIPIENTS STREAM))))
					(with-output-to-string (s text)
					  (send s :line-out (reception-line stream)))
					(if (null recipients) (return-from top)
					  (GET-MAIL-TEXT STREAM text)
					  (SEND STREAM :FINISH)
					  (LET
					    ((RESULT
					       (WRITE-QUEUE-FILE (SETQ QFILE (QFILE-NAME))
								 RECIPIENTS `(:failures 0
											:source-network-type :chaos
											:source-protocol :chaos-mail
											:source-host ,(send stream :host))
								 TEXT STREAM)))
					    (IF (NOT (ERRORP RESULT)) (SETQ FINAL-OK :QUEUED-OK)
					      (SETQ FINAL-OK ())
					      (IF (PROBEF QFILE) (DELETEF QFILE))
					      (return-from top))))))
		    ())))			; don't print error message
	;; Now for the clean-up-forms...
	(when stream
	  (if final-ok (format stream "+Message sent successfully.~%"))
	  (SEND STREAM :FORCE-OUTPUT)
	  (CHAOS:FINISH-CONN CONN)
	  (CHAOS:CLOSE-CONN CONN))
	(WHEN CONN
	  (SEND TV:WHO-LINE-FILE-STATE-SHEET :DELETE-SERVER CONN)
	  (IF REJECT-P
	      (CHAOS:REJECT CONN *SERVER-DISABLE-REASON*)
	    (CHAOS:REMOVE-CONN CONN)))
	(IF (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)))
    (send stream :force-output)))

(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)
	      (send s :line-out (foreign-mailer-address a)) (send s :force-output)
	      (if (char= #\+ (send s :tyi))
		  (format report-stream "~&OK: ~A~%" (send s :line-in))
	       (format report-stream "~&Failure for ~S: ~A" a (send s :line-in))
	       (push a failed)))
	    (send s :tyo #\Newline)
	    (send s :string-out text)
	    (send s :eof)
	    (let ((first (send s :tyi)))
	      (if (char= #\+ first)
		  (format report-stream "~&Message queued~%")
	       (format report-stream "~&~:[Permanent~;Temporary~] failure: ~A~%"
		       (char= first #\-) (send s :line-in))
	       (setq failed addresses))))
	(when s (send s :close :abort)))
    (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= #\+ (send c :tyi)) (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
	 (send s :tyo #/-)
	 (send error :report s))
	(:no-error (format s :string-out "+~A" error)))
      (send s :force-output))
    ()))

(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) (send s :line-in)
	  (let ((initial (address-existent-p line)))
	    (flet ((address-out (user host)
		     (send s :string-out user)
		     (send s :string-out "@")
		     (send s :line-out (or host (send si:local-host :name)))))
	      (typecase initial
		(null (send s :string-out "-No such address"))
		(string
		 (send s :line-out "+Local address")
		 (address-out initial nil))
		(list
		 (send s :line-out "+Mailing list")
		 (dolist (address (expand-addresses initial))
		   (send s :line-out (address-as-string address))))
		(error
		 (send s :string-out "-Error in parsing address"))
		(t
		 (send s :string-out "-Internal error"))))
	    (send s :tyo #\Return)
	    (send s :force-output)
	    (if eofp (return))))))
    nil))

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