;;; -*- Mode:LISP; Package:MAIL; Base:10; Readtable:T; Lowercase:T -*-
;;;
;;; Lisp Machine Mailer
;;;
;;; (c) 1985 Lisp Machine Incorporated
;;;
;;; Changes:
;;;   Sometime, someone: written
;;;   RpK, 7 July 1983: Made to use NES, WITH-OPEN-FILE-CASE
;;;   Rpk, 8 July 1983: Works.  Delayed delivery implemented for more than
;;;      *DELAY-DELIVERY-THRESHOLD* (3 is the default).
;;;   RpK, 20 December 1984: Clean up for the modern world, customers.
;;;      Now it always queues...
;;;   RpK, 4 January 1985: Support Chaosnet. *delay-delivery* helps debugging
;;;   RpK, 8 January 1985: Be a real system.

(defvar *debug-server* ())
(defvar *delay-delivery* () "If T, do not actually deliver")
(defvar *mailing-lists* nil)
(define-site-variable *mail-server-p* :mail-server "Am I a mail server ?")

(defmacro find-in-mailing-lists (string)
  #+explorer `(ass #'string-equal ,string *mailing-lists*)
  #-explorer `(cli:assoc ,string *mailing-lists* :test #'string-equal))

(defvar *mailing-list-file* "LM:MAIL;LIST.LISP")
(defvar *mailing-list-version-number* nil)

(defvar *unknown-addresses* ())
(defvar *mailer-initialized* ())
;;; For now only allow one file for all servers.
(defvar *mail-server-lock* nil)

(defvar *server-enabled* nil)
(defvar *server-disable-reason* "Mailer not initialized")

(defvar *history* nil)

(add-initialization "Reset Mailer History" '(setq *history* nil) '(:before-cold))

(defvar *notify-mode* nil "Can be NIL, meaning not to record anything, or:
 :NOTIFY   Do a window notification
 :OUTPUT   Print the notification on *TERMINAL-IO*
 :HISTORY  Push the note on the history.  Use PRINT-HISTORY")

(defun notify (format-string &rest format-args)
  (case *notify-mode*
    (:notify (tv:notify () format-string format-args))
    (:output
     (fresh-line *terminal-io*)
     (write-string "[Mailer: " *terminal-io*)
     (apply #'format *terminal-io* format-string format-args)
     (write-line "]" *terminal-io*))
    (:history
     (push (cons (get-universal-time) (apply #'format nil format-string format-args))
	   *history*))))

(defun print-history () "Print out the activity of the Mailer"
  (dolist (h *history*)
    (fresh-line)
    (time:print-universal-time (car h))
    (write-string "   ")
    (write-string (cdr h))))

;;; The queue file format is depressingly simple.  The first part is a cons, whose CDR is
;;; unused and whose CAR is a list of recipients of the form (type . options).  Later on the
;;; CDR will have more interesting information in it (for use with GET).
;;; Standard mailer per-message properties:
;;;  :FAILURES, a number
;;;  :FIRST-FAILURE-DATE also a number, a universal time
(defvar *qfile-template* () "Set by initialising the mailer")

(defvar *qfile-name-counter* 0)
(defun qfile-name (&optional (name (format () "~16R-~D"
                                           (time:get-universal-time)
                                           (without-interrupts (incf *qfile-name-counter*)))))
  (send *qfile-template* :new-name (string name)))

;;; Currently we have just (:NAME . uname), (:FILE . filename) and
;;; (:FOREIGN address-for-host original-address host-or-class) (see below)
(defstruct (address (:type :list*) :conc-name)
  type options)

;;; A class symbol describes what kind of delivery to use.  No classes are currently implemented,
;;; but there will be some provided so that the Lisp Machine can act as a mail gateway.
(defstruct (foreign-address (:type :list) (:conc-name foreign-)
			    (:but-first address-options))
  (mailer-address () :documentation "what to use when contacting a mail server")
  (original-address ()
   :read-only t
   :documentation "what was received by the mailer, usually containing @")
  (class () :documentation "either a delivery class or a host to contact"))
  
(defvar *failed-address* (make-address :type :file :options "MAIL;FAILED-MAIL.TEXT"))

;;; Buffer resource
(defresource text-buffer (size)
  :constructor (make-array (or size 1000.) :fill-pointer 0 :element-type 'string-char)
  :initializer (setf (fill-pointer object) 0)
  :matcher (or (null size)
	       (<= size (array-total-size object))))

(defmacro with-text-buffer ((buffer stream) &body body)
  "This is very useful with GET-MAIL-TEXT"
  `(using-resource (,buffer text-buffer (send ,stream :send-if-handles :length))
     ,@body))

(DEFUN GET-MAIL-TEXT (STREAM buffer)
  (WITH-OUTPUT-TO-STRING (SSTREAM buffer)
    (STREAM-COPY-UNTIL-EOF STREAM SSTREAM)
    (FUNCALL SSTREAM :FRESH-LINE)))

;;; This ought to be globalized (net-ized ?), really
(defmacro with-open-network-stream ((stream form) &body body)
  "Like WITH-OPEN-STREAM, but ALWAYS uses abort mode."
  `(let ((,stream))
     (unwind-protect
	 (progn
	   (setq ,stream ,form)
	   ,@body)
       (when ,stream (send ,stream :close :abort)))))

(defmacro as-mail-server ((stream form) &body body)
  `(with-open-network-stream (,stream ,form)
     (cond (*server-enabled*
	    (send ,stream :accept)
	    ,@body)
	   (t
	    ;; Any :close after :reject should be harmless
	    (send ,stream :reject *server-disable-reason*)))))

;;; 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 (FORMAT STREAM "-Error opening for append: ~A"
			   (SEND INFILE :REPORT-STRING))
		   (SEND STREAM :FORCE-OUTPUT)
		   (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
     (FORMAT STREAM "%Disk full, please try later.~%")
     (SEND STREAM :FORCE-OUTPUT)
     (RETURN OUTFILE))
    (ERROR
     (FORMAT STREAM "-Unexpected error for ~A: ~A~%"
	     ADDRESS (SEND OUTFILE :REPORT-STRING))
     (FUNCALL STREAM :FORCE-OUTPUT)
     (RETURN OUTFILE))
    (:NO-ERROR
     (IF INFILE (STREAM-COPY-UNTIL-EOF INFILE OUTFILE))
     (FUNCALL OUTFILE :STRING-OUT TEXT)
     (IF INCLUDE-TAIL (FUNCALL OUTFILE :LINE-OUT ""))
     (IF INFILE (SEND INFILE :DELETE))
     (FUNCALL STREAM :FORCE-OUTPUT))
     (RETURN T)))

(defun write-queue-file (qfile recipients properties text stream)
  (let ((*print-level* ()) (*print-length* ()) (*print-base* 10.)
	(*package* si:pkg-user-package) (*print-array* t)
	(*READTABLE* SI:STANDARD-READTABLE))
    (file-deliver-mail "LIST" qfile
                       (format () "~S~A" (cons recipients properties) text)
                       stream
                       ())))

(defvar *file-defaults*
	(make-pathname :host si:local-host :directory '("MAIL")
		       :name "MAIL" :type "TEXT" :version :newest))

(defun mail-file-for-address (address)
  (ecase (address-type address)
    (:name (make-pathname :host si:local-host
			  :directory (address-options address)
			  :name "MAIL"
			  :TYPE "TEXT"
			  :VERSION :NEWEST))
    (:FILE (merge-pathnames (address-options address) *file-defaults*))))

;;; Delivery
(defvar *delivery-methods* nil)

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

(defun deliver-mail (addresses 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 text report-stream)))))
  (if addresses
      (format report-stream "Warning: These addresses appear unreachable:~%~S~%" addresses))
  (setq failed (nconc addresses failed)))

(define-delivery-method append-to-file (address)
			(memq (address-type address) '(:name :file))
			(addresses text report-stream)
  (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))

(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 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.~%"))))))

(defun reception-line (server-stream &optional (protocol "CHAOS-MAIL"))
  (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"
	    (send (send server-stream :foreign-host) :name)
	    (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))))

(defun address-existent-p (string)
  "Returns NIL, a string (a directory), or a list of addresses."
  (or (let ((dir (fs:lookup-directory string t)))
	(and dir
	     (fs:directory-name dir)))
      (cdr (find-in-mailing-lists string))))

;; Deal with mailing lists.

(DEFUN EXPAND-ADDRESSES (ADDRESS-LIST &AUX RECIPIENTS LIST-ADDRESSES)
  (REMOVE-DUPLICATES
    (DOLIST (ADDRESS ADDRESS-LIST RECIPIENTS)
      (COND
	((CONSP ADDRESS) ; should only get :FILE or :FOREIGN here
	 (PUSH ADDRESS RECIPIENTS))
	((FS:LOOKUP-DIRECTORY ADDRESS T)
	 (PUSH (MAKE-ADDRESS :TYPE :NAME :OPTIONS ADDRESS) RECIPIENTS))
	((AND (STRINGP ADDRESS)
	      (SETQ LIST-ADDRESSES
		    (CDR (find-in-mailing-lists ADDRESS))))
	 (SETQ RECIPIENTS (NCONC RECIPIENTS (EXPAND-ADDRESSES LIST-ADDRESSES))))
	((STRING-SEARCH-CHAR #/; ADDRESS)
	 (PUSH (MAKE-ADDRESS :TYPE :FILE :OPTIONS ADDRESS) RECIPIENTS))
	(T (PUSH ADDRESS *UNKNOWN-ADDRESSES*)
	   (PUSH *FAILED-ADDRESS* RECIPIENTS))))
    :TEST #'EQUALP))
    
(DEFUN READ-MAILING-LIST-FILE (&optional output-p
			       &aux version NEW-LIST (count-errors 0) (count-lists 0) (count-names 0))
  (let ((mailing-list-pathname
	  (probef (fs:parse-pathname *Mailing-List-FILE* si:local-host))))
    (when (typep mailing-list-pathname 'pathname)
      (setq version (send mailing-list-pathname :version))
      (if (eql version *Mailing-List-Version-Number*)
       (format (if output-p *terminal-io* nil) "Mailing list file already updated.")
       (with-lock (*mail-server-lock*)
	 (fs:reading-from-file (list mailing-list-pathname)
	   (incf count-lists)
	   (do* ((l (cdr list) (cdr l))  ; munge it in place
		 (address (car l) (car l)))
		((null l))
	     (incf count-names)
	     (unless (consp address)
	       (setf (car l)
		     (multiple-value-bind (error-p result) (mailer-parse-address address)
		       (if (not error-p) result
			   (when output-p
			     (format *error-output* "~&Bad address ~A in ~A list: ~A~%"
				     address (car list) result))
			   (decf count-names)
			   (incf count-errors)
			   *failed-address*)))))
	   (PUSH LIST NEW-LIST))
	 (setq *Mailing-List-Version-Number* version)
	 (setq *mailing-lists* new-list))
       (format (if output-p *terminal-io* nil)
	       "~&Finished: ~[No~;one~:;~:*~D~] list~:P, ~[no~;one~:;~:*~D~] name~:P, ~[no~;one~:;~:*~D~] error~:P."
	       count-lists count-names count-errors)))))

(defun main-lm-mail-server-host ()
  (dolist (h (si:get-site-option :chaos-mail-server-hosts))
    (if (eq :lispm (send (setq h (si:parse-host h)) :system-type)) (return h))))

(defun lm-mail-server-p (host)
  (setq host (si:parse-host host))
  (dolist (h (si:get-site-option :chaos-mail-server-hosts))
    (if (eq host (si:parse-host h)) (return host))))

(DEFUN MESSAGE-HEADERS-AND-TEXT (TEXT)
  "Returns two values: a string with the headers, and a string with the message.
If no header was found, () is returned as the second value.
The header string will not end with a CR, or will the message string begin
with one (unless there are 2 blank lines at the start of the message text)."
  (LET ((IDX (STRING-SEARCH #.(FORMAT () "~C~C" #\CR #\CR) TEXT)))
    (IF (NULL IDX) TEXT
      (VALUES (SUBSTRING TEXT 0 IDX) (SUBSTRING TEXT (+ 2 IDX))))))

(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) (SEND S :LINE-IN))
      (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)))))))
	  (COND ((NOT Z-UNAME) (SETQ UNAME "Unknown"))
		((STRINGP Z-UNAME) (SETQ UNAME "Unknown"))
		(T
		 (SETQ UNAME (SECOND (MEMQ :NAME (FIRST Z-UNAME))))
		 (LET ((HOST (SECOND (MEMQ :HOST (FIRST Z-UNAME)))))
		   (IF 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)))))))))))))


(DEFUN NON-LOCAL-MAIL-HOST-P (HOST-STRING)
  (NOT (OR (MEM #'STRING-EQUAL HOST-STRING (SEND SI:LOCAL-HOST :HOST-NAMES))
	   (STRING-EQUAL HOST-STRING (SEND SI:LOCAL-HOST :NAME-AS-FILE-COMPUTER)))))

(DEFUN MAIL-HOST-NAME (STRING)
  (STRING (OR (SI:PARSE-HOST STRING T ())
	      (FS:GET-PATHNAME-HOST STRING T)
	      STRING)))

(DEFUN FORCE-DELIVERY (&OPTIONAL (STREAM STANDARD-OUTPUT))
  (LET ((DIR (FS:DIRECTORY-LIST (SEND *QFILE-TEMPLATE* :NEW-NAME :WILD))))
    (DOLIST (ELEM DIR)
      (if (FIRST ELEM)
        (MAIL-DELIVER-QFILE (FIRST ELEM) STREAM))))
  (FS:EXPUNGE-DIRECTORY *QFILE-TEMPLATE*))

(DEFUN INITIALIZE-MAILER ()
  (when *mail-server-p*
    (UNLESS *MAILER-INITIALIZED*
      (send *terminal-io* :fresh-line)
      (send *terminal-io* :line-out "[Mailer: First initializations]")
      (setq *qfile-template*
	    (fs:make-pathname :host (fs:get-pathname-host si:local-host)
			      :directory '("MAIL" "QUEUE")
			      :type "-Q-"	
			      :version :newest))
      (load "LM:MAIL.COM;BOOT" :if-does-not-exist nil :verbose nil
			       :package "MAIL" :set-default-pathname nil))
    (send *terminal-io* :fresh-line)
    (send *terminal-io* :string-out "[Mailer: ") (read-mailing-list-file t)
    (send *terminal-io* :tyo #\])
    (format t "~%[Mailer: Checking for mail to deliver]~%")
    (force-delivery)
    (setq *mailer-initialized* t)
    (enable-mail-server)))

(defun disable-mail-server (&optional (why "Mailer disabled"))
  (setq *server-enabled* nil)
  (setq *server-disable-reason* why))

(defun enable-mail-server () (setq *server-enabled* t))

(add-initialization "Initialize Mailer" '(initialize-mailer))

(add-initialization "Reset Mailer State"
                    '(progn
		       (disable-mail-server "Mailer not intialized")
		       (SETQ *MAILER-INITIALIZED* ()))
		    ()
		    'si:before-cold-initialization-list)

;;; Testing functions and the like
(defun _hack-it ()
  (setq *mail-server-p* t
	zwei:*mail-chaos-hosts* (delq si:local-host zwei:*mail-chaos-hosts*))
  (push si:local-host zwei:*mail-chaos-hosts*))

(defun _send-test-message (&rest addresses &aux s)
  (unwind-protect
      (progn
	(setq s (chaos:open-stream si:local-host "MAIL"))
	(dolist (a addresses)
	  (send s :line-out a) (send s :force-output)
	  (format t "~%  Response for ~A: ~A" a (send s :line-in)))
	(send s :tyo #\Newline)
	(format s "From: ~A <~A@~A>~%To: Nobody in particular~%Subject: This is a test~2%"
		fs:user-personal-name-first-name-first (fs:uname-on-host fs:user-login-machine)
		fs:user-login-machine)
	(dotimes (i 10)
	  (format s "Blah~%"))
	(format s "~%   --- F I N I S ---~%")
	(send s :eof)
	(format t "~%Response for text: ~A" (send s :line-in)))
    (when s (send s :close :abort))))

;;; Here are typical address and the corresponding structures from
;;; (car (zwei:parse-addresses address)).  (getf * :interval) returns an interval
;;; so you can use the ZWEI:INTERVAL functions/accessors
;;;
;;; foo : (:NAME "foo" :HOST NIL
;;;        :INTERVAL (("foo" 0.) ("foo" 3.)))
;;; foo@cap : (:NAME "foo" :HOST ("cap")
;;;            :INTERVAL (("foo@cap" 0.) ("foo@cap" 7.)))
;;; "rpk@ccc"@cap : (:NAME "/"rpk@ccc/"" :HOST ("cap")
;;;                  :INTERVAL (("/"rpk@ccc/"@cap" 0.) ("/"rpk@ccc/"@cap" 13.)))
;;; rpk%mc@cap : (:NAME "rpk" :HOST ("mc" "cap")
;;;               :INTERVAL (("rpk%mc@cap" 0.) ("rpk%mc@cap" 10.)))
;;; mitccc!rpk@eddie : (:NAME "mitccc!rpk" :HOST ("eddie")
;;;                     :INTERVAL (("mitccc!rpk@eddie" 0.) ("mitccc!rpk@eddie" 16.)))
;;; rpk%ccc : (:NAME "rpk" :HOST ("ccc")
;;;            :INTERVAL (("rpk%ccc" 0.) ("rpk%ccc" 7.))))

;;; Returns two values: errorp and address (or error string).  The address returned
;;; is either a string (to be expanded into a mailing list, because it is actually
;;; local) or an address structure.  Note that :FOREIGN is canonicalised for taking
;;; out the local host, but initially the class slot is either a host or list of hosts.
;;; When the mailer gets more complex, this will get processed for a real class slot.

(defun reachable-host-p (host) ; this will get hairier later on
  (send host :network-typep :chaos))

(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))))))

(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)
	      (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))))))))

(defun mailer-address-for-other-host (hosts name &aux (strings (ncons name)))
  (dolist (h hosts)
    (push "%" strings)
    (push h strings))
  (when (> (length strings) 2)
    (setf (cadr strings) "@"))
  (apply #'string-append (nreverse strings)))

(defun address-as-string (address)
  "Returns a fully-qualified address string (user@host)"
  (case (address-type address)
    (:name (format () "~A@~A" (address-options address) si:local-host))
    (:file (format () "/"~A/"@~A" (address-options address) si:local-host))
    (:foreign (foreign-original-address address))))