;;; -*- 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) (write-line (reception-line stream) s)) (if (null recipients) (return-from top (values)) (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 :host)) TEXT STREAM))) (IF (NOT (ERRORP RESULT)) (SETQ FINAL-OK :QUEUED-OK) (SETQ FINAL-OK ()) (IF (PROBEF QFILE) (DELETEF QFILE)) (return-from top (values))))))) ()))) ; don't print error message ;; Now for the clean-up-forms... (when stream (if final-ok (format stream "+Message sent successfully.~%")) (force-output stream) (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))) (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)