;;;; sendmail.lisp
;;;;
;;;; This code was written by Christophe Rhodes <csr21@cam.ac.uk>, and
;;;; is in the public domain.

;;; Class mail-output-stream.
;;;
;;; FIXME: This information belongs in documentation strings
;;; somewhere. But where? Possibly distributed in various
;;; :documentation slots.
;;;
;;; The mail-output-stream is a class of stream (therefore depending
;;; on the Gray Stream extension) that, on close, sends its
;;; accumulated content by mail.
;;;
;;; Slots:
;;;
;;; * real-stream: contains the stream that the print- functions
;;; actually print to;
;;;
;;; * string-stream: contains the string-stream that is used on
;;; close. This is the same as the real-stream if no stream is
;;; initially supplied; if one is supplied, real-stream is a
;;; broadcast-stream to both the supplied stream and the
;;; string-stream;
;;;
;;; * to, cc, bcc: lists of strings, one per e-mail address;
;;;
;;; * other-headers: A list of strings, one per header.
(defclass mail-output-stream (fundamental-character-output-stream)
  ((real-stream :initarg :stream :initform nil :accessor mail-output-stream-stream)
   (string-stream :accessor string-stream :initform (make-string-output-stream))
   (subject :accessor subject :initform "")
   (to :accessor to :initform nil)
   (cc :accessor cc :initform nil)
   (bcc :accessor bcc :initform nil)
   (other-headers :accessor other-headers :initform nil)))

(defmethod initialize-instance :after ((object mail-output-stream) &key)
  (if (null (mail-output-stream-stream object))
      (setf (mail-output-stream-stream object) (string-stream object))
    (setf (mail-output-stream-stream object)
	  (make-broadcast-stream (mail-output-stream-stream object)
				 (string-stream object)))))



(defmethod print-object ((object mail-output-stream) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "to ~a regarding ~a" (to object) (subject object))))

(defmethod stream-write-string ((stream mail-output-stream) string
				&optional (start 0) (end (length string)))
  (princ (subseq string start end) (mail-output-stream-stream stream)))

(defmethod stream-write-char ((stream mail-output-stream) character)
  (princ character (mail-output-stream-stream stream)))

(defmethod stream-line-column ((stream mail-output-stream))
  (stream-line-column (mail-output-stream-stream stream)))

(defmethod stream-finish-output ((stream mail-output-stream))
  (finish-output (mail-output-stream-stream stream)))

(defmethod stream-force-output ((stream mail-output-stream))
  (force-output (mail-output-stream-stream stream)))

(defmethod stream-clear-output ((stream mail-output-stream))
  (clear-output (mail-output-stream-stream stream)))

(defmethod stream-line-column ((stream mail-output-stream))
  nil)

(defmethod close ((stream mail-output-stream) &key abort)
  (close (mail-output-stream-stream stream) :abort abort)
  (close (string-stream stream) :abort abort))

(define-condition mailer-program-error (error)
  ((error-code :initarg :error-code :accessor error-code))
  (:report (lambda (condition stream)
	     (format stream "Mailer program returned non-zero exit code: ~d."
		     (error-code condition)))))

(defun portable-run-program (&rest args)
  #+cmu (apply 'ext:run-program args)
  #+sbcl (apply 'sb-ext:run-program args)
  #-(or cmu sbcl) (error "Functionality is missing in this implementation."))

(defmethod close :before ((stream mail-output-stream) &key &allow-other-keys)
  (let* ((body-string (get-output-stream-string (mail-output-stream-stream stream)))
	 (body-stream (make-string-input-stream body-string))
	 (args (append (list "-s" (subject stream))
		       (loop for x in (cc stream)
			     append (list "-c" x))
		       (loop for x in (bcc stream)
			     append (list "-b" x))
		       (loop for x in (other-headers stream)
			     append (list "-a" x))
		       (list "-a" "X-Lisp-Programme: yes")
		       (to stream))))
    (restart-case
        (let ((mail-process (portable-run-program
			     "mail" args
			     :input body-stream
			     :wait t)))
	  (unless (= 0 (process-exit-code mail-process))
	    (error 'mailer-program-error
		   :error-code (process-exit-code mail-process))))
      (retry ()
	     :report "Retry sending mail."
	(close stream))
      (save (pathname)
	    :report "Save mail body to file."
	    :interactive (lambda ()
			   (format *query-io* "~&Please enter a pathname: ")
			   (list (pathname (read-line *query-io*))))
	(with-open-file (s pathname :direction :output :if-exists :error)
	  (write body-string :stream s))))))