#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Mail Sending

(declare (usual-integrations))

(define-variable user-mail-address
  "Full mailing address of this user.
This is initialized based on `mail-host-address',
after your init file is read, in case it sets `mail-host-address'."
  #f
  string-or-false?)

(define-variable mail-host-address
  "Name of this machine, for purposes of naming users."
  #f
  string-or-false?)

(define-variable mail-full-name
  "Your full name.
Appears in the From: field of mail and news messages, following the address.
If set to the null string, From: field contains only the email address."
  #f
  string-or-false?)

(define-variable mail-from-style
  "Specifies how \"From:\" fields look.
One of the following values:
'PARENS	king@grassland.com (Elvis Parsley)
'ANGLES	Elvis Parsley <king@grassland.com>
#F	king@grassland.com"
  'ANGLES
  (lambda (object) (memq object '(PARENS ANGLES #F))))

(define-variable mail-organization
  "The name of your organization.
Appears in the Organization: field of mail and news messages.
If set to the null string, no Organization: field is generated."
  ""
  string?)

(define-variable mail-identify-reader
  "Switch controlling generation of User-Agent headers in messages."
  #t
  boolean?)

(define-variable mail-default-reply-to
  "Address to insert as default Reply-to field of outgoing messages."
  #f
  (lambda (object)
    (or (not object)
	(string? object)
	(and (procedure? object)
	     (procedure-arity-valid? object 0)))))

(define-variable mail-self-blind
  "True means insert BCC to self in messages to be sent.
This is done when the message is initialized,
so you can remove or alter the BCC field to override the default."
  #f
  boolean?)

(define-variable mail-archive-file-name
  "Name of file to write all outgoing messages in, or #f for none."
  #f
  string-or-false?)

(define-variable mail-relay-host
  "Name of host to which all outgoing mail should be sent.
Can be a host name (a string) or #F.
If #F, mail is passed to sendmail for handling.
Otherwise, mail is sent directly to the named host using SMTP."
  #f
  string-or-false?)

(define-variable mail-relay-service
  "Service to connect to on the mail relay host.
Can be a service name (a string), a service number, or #F.
If #F, service \"smtp\" is used.
This is used only if `mail-relay-host' is set."
  #f
  (lambda (service)
    (or (not service)
        (exact-positive-integer? service)
        (string? service))))

(define-variable mail-authentication
  "SMTP authentication method (SASL mechanism) as a string.
Set this to #F to disable authentication and to #T to use whatever
  method is accepted by server, or no authentication if the server
  accepts none.
Currently only \"LOGIN\" and \"PLAIN\" are supported, so use this form
  of authentication only over a secure channel."
  #f
  (lambda (method)
    (member method '(#f #t "LOGIN" "PLAIN"))))

(define-variable smtp-user-name
  "User name to use for simple SMTP authentication.
#F means prompt for the name each time."
  #f
  (lambda (object)
    (or (not object) (string? object))))

(define-variable smtp-trace
  "If true, direct SMTP transmissions are traced in a buffer."
  #f
  boolean?)

(define-variable smtp-require-valid-recipients
  "If true, all SMTP recipients must be valid before a message is sent.
Otherwise, only one valid recipient is required."
  #t
  boolean?)

(define-variable smtp-greeting-hostname
  "Hostname for HELO (or EHLO) messages when sending mail by SMTP.
This may be a string or a procedure.
Default is whatever the OS reports."
  os/hostname
  (lambda (object)
    (or (string? object)
	(procedure? object))))

(define-variable sendmail-program
  "Filename of sendmail program."
  #f
  string-or-false?)

(define-variable send-mail-procedure
  "Procedure to call to send the current buffer as mail.
The headers are delimited by a string found in mail-header-separator."
  (lambda () (sendmail-send-it))
  (lambda (object)
    (and (procedure? object)
	 (procedure-arity-valid? object 0))))
(variable-permanent-local! (ref-variable-object send-mail-procedure))

(define-variable mail-yank-ignored-headers
  "Delete these headers from old message when it's inserted in a reply."
  (regexp-group "^via:"
		"^mail-from:"
		"^origin:"
		"^status:"
		"^remailed"
		"^received:"
		"^[a-z-]*message-id:"
		"^summary-line:"
		"^to:"
		"^cc:"
		"^subject:"
		"^in-reply-to:"
		"^return-path:")
  string?)

(define-variable mail-yank-prefix
  "Prefix to insert on lines of yanked message being replied to.
#F means use indentation."
  #f
  string-or-false?)

(define-variable mail-interactive
  "True means when sending a message wait for and display errors.
#F means let mailer mail back a message to report errors."
  #f
  boolean?)

(define-variable mail-header-separator
  "Line used to separate headers from text in messages being composed."
  "--text follows this line--"
  string?)

(define-variable mail-header-function
  "A function of one argument, POINT (the current point), which inserts
additional header lines into a mail message.  The function is called
after all other headers are inserted.  If this variable is #f, it
is ignored."
  #f
  (lambda (object)
    (or (false? object)
	(and (procedure? object)
	     (procedure-arity-valid? object 1)))))

(define-variable mail-reply-buffer
  ""
  #f
  (lambda (object) (or (false? object) (buffer? object))))
(variable-permanent-local! (ref-variable-object mail-reply-buffer))

(define-variable mail-abbreviate-mime
  "If true, sent mail doesn't contain some unnecessary MIME headers.
Specifically, Content-Type and Content-Transfer-Encoding headers
  in subparts of a multipart message are omitted if they specify the default.
If false, sent mail contains full MIME headers."
  #t
  boolean?)

(define-variable-per-buffer mail-charset
  "Name of charset for sending mail, as a string."
  "us-ascii"
  string?)

(define-command mail
  "Edit a message to be sent.  Argument means resume editing (don't erase).
While editing message, type C-c C-c to send the message and exit.

Separate names of recipients with commas.

Various special commands starting with C-c are available in sendmail mode
to move to message header fields.

If mail-self-blind is true, a BCC: to yourself is inserted when the
message is initialized.

If mail-default-reply-to is a string, a Reply-to: field containing
that string is inserted.

If mail-archive-file-name is true, an FCC: field with that file name
is inserted."
  "P"
  (lambda (no-erase?) (mail-command no-erase? select-buffer)))

(define-command mail-other-window
  "Like \\[mail], but display mail buffer in another window."
  "P"
  (lambda (no-erase?) (mail-command no-erase? select-buffer-other-window)))

(define-command mail-other-frame
  "Like \\[mail], but display mail buffer in another frame."
  "P"
  (lambda (no-erase?) (mail-command no-erase? select-buffer-other-screen)))

(define (mail-command no-erase? select-buffer)
  (make-mail-buffer '(("To" "") ("Subject" "")) #f select-buffer
		    (if no-erase?
			'KEEP-PREVIOUS-MAIL
			'QUERY-DISCARD-PREVIOUS-MAIL)))

(define (make-mail-buffer headers reply-buffer #!optional
			  selector handle-previous buffer-name mode)
  (make-initialized-mail-buffer headers reply-buffer
				(lambda (buffer) buffer unspecific)
				selector handle-previous buffer-name mode))

(define (make-initialized-mail-buffer headers reply-buffer initializer
				      #!optional selector handle-previous
				      buffer-name mode)
  (let ((selector (if (default-object? selector) #f selector))
	(handle-previous
	 (if (default-object? handle-previous)
	     'QUERY-DISCARD-PREVIOUS-MAIL
	     handle-previous))
	(buffer-name
	 (if (or (default-object? buffer-name) (not buffer-name))
	     "*mail*"
	     buffer-name))
	(mode (if (default-object? mode) #f mode)))
    (let ((buffer (find-buffer buffer-name))
	  (continue
	   (lambda (select?)
	     (let ((buffer (find-or-create-buffer buffer-name)))
	       (buffer-reset! buffer)
	       (set-buffer-default-directory! buffer
					      (default-homedir-pathname))
	       (setup-buffer-auto-save! buffer)
	       (mail-setup buffer headers reply-buffer mode)
	       (initializer buffer)
	       (if (and select? selector) (selector buffer))
	       buffer))))
      (cond ((not buffer)
	     (continue #t))
	    ((eq? handle-previous 'KEEP-PREVIOUS-MAIL)
	     (if selector (selector buffer))
	     #f)
	    ((or (not (buffer-modified? buffer))
		 (eq? handle-previous 'DISCARD-PREVIOUS-MAIL))
	     (continue #t))
	    ((eq? handle-previous 'QUERY-DISCARD-PREVIOUS-MAIL)
	     (if selector (selector buffer))
	     (if (cleanup-pop-up-buffers
		  (lambda ()
		    (if (not selector) (pop-up-buffer buffer #f))
		    (prompt-for-confirmation?
		     "Unsent message being composed; erase it")))
		 (continue #f)
		 #f))
	    (else
	     (error:bad-range-argument handle-previous 'MAKE-MAIL-BUFFER))))))

(define (mail-setup buffer headers reply-buffer #!optional mode)
  (guarantee-mail-aliases)
  (set-buffer-major-mode! buffer
			  (or (and (not (default-object? mode)) mode)
			      (ref-mode-object mail)))
  (local-set-variable! mail-reply-buffer reply-buffer buffer)
  (let ((headers (add-standard-headers headers buffer))
	(point (mark-left-inserting-copy (buffer-start buffer))))
    (let ((start (mark-right-inserting-copy point)))
      (for-each
       (lambda (header)
	 (let ((key (car header))
	       (value (cadr header)))
	   (if value
	       (begin
		 (move-mark-to! start point)
		 (insert-string key point)
		 (insert-string ": " point)
		 (let ((end (string-length value)))
		   (let loop ((start 0))
		     (let ((index
			    (substring-find-next-char value start end
						      #\newline)))
		       (if index
			   (let ((index (fix:+ index 1)))
			     (insert-substring value start index point)
			     (if (and (fix:< index end)
				      (not
				       (let ((char (string-ref value index)))
					 (or (char=? char #\space)
					     (char=? char #\tab)))))
				 (insert-char #\tab point))
			     (loop index))
			   (insert-substring value start end point)))))
		 (if (and (not (string-null? value))
			  (if (null? (cddr header))
			      (or (string-ci=? key "to")
				  (string-ci=? key "cc"))
			      (caddr header)))
		     (fill-mail-addresses start point))
		 (insert-newline point)))))
       headers)
      (mark-temporary! start))
    (let ((mail-header-function (ref-variable mail-header-function buffer)))
      (if mail-header-function
	  (mail-header-function point)))
    (insert-string (ref-variable mail-header-separator buffer) point)
    (insert-newline point)
    (mark-temporary! point)
    (let ((given-header?
	   (lambda (name null-true?)
	     (let ((header
		    (find (lambda (header)
			    (string-ci=? (car header) name))
			  headers)))
	       (and header
		    (cadr header)
		    (if null-true?
			(string-null? (cadr header))
			(not (string-null? (cadr header)))))))))
      (set-buffer-point! buffer
			 (if (given-header? "To" #t)
			     (mail-position-on-field buffer "To")
			     (buffer-end buffer)))
      (if (not (or (given-header? "To" #f)
		   (given-header? "Subject" #f)
		   (given-header? "In-reply-to" #f)))
	  (buffer-not-modified! buffer))))
  (event-distributor/invoke! (ref-variable mail-setup-hook buffer) buffer))

(define (fill-mail-addresses start end)
  ;; This totally loses on quoted or commented names, which it
  ;; probably shouldn't split up.
  (let ((column (ref-variable fill-column start))
	(mark (char-search-forward #\, start end)))
    (if mark
	(let loop ((start start) (mark mark))
	  (let ((mark* (char-search-forward #\, mark end)))
	    (if mark*
		(if (< (mark-column mark*) column)
		    (loop start mark*)
		    (let ((mark
			   (mark-permanent-copy
			    ;; Skip addresses that are too long.
			    (if (mark= mark start) mark* mark))))
		      (delete-horizontal-space mark)
		      (insert-newline mark)
		      (insert-char #\tab mark)
		      (mark-temporary! mark)
		      (loop mark mark)))))))))

(define (add-standard-headers headers buffer)
  (let ((add
	 (lambda (key value)
	   (if (string? value)
	       (list (list key value #f))
	       '()))))
    (append headers
	    (add "Reply-to"
		 (let ((mail-default-reply-to
			(ref-variable mail-default-reply-to buffer)))
		   (if (procedure? mail-default-reply-to)
		       (mail-default-reply-to)
		       mail-default-reply-to)))
	    (add "BCC"
		 (and (ref-variable mail-self-blind buffer)
		      (mail-from-string buffer)))
	    (add "FCC" (ref-variable mail-archive-file-name buffer)))))

(define (mail-from-string lookup-context)
  (let ((address (user-mail-address lookup-context))
	(full-name (mail-full-name lookup-context)))
    (if (string-null? full-name)
	address
	(case (ref-variable mail-from-style lookup-context)
	  ((PARENS)
	   (string-append address " (" full-name ")"))
	  ((ANGLES)
	   (string-append (rfc822:quote-string full-name) " <" address ">"))
	  (else address)))))

(define (user-mail-address lookup-context)
  (or (ref-variable user-mail-address lookup-context)
      (string-append (current-user-name)
		     "@"
		     (or (ref-variable mail-host-address lookup-context)
			 (os/hostname)))))

(define (mail-full-name lookup-context)
  (or (ref-variable mail-full-name lookup-context)
      ""))

(define-variable mail-setup-hook
  "An event distributor invoked immediately after a mail buffer is initialized.
The mail buffer is passed as an argument; it is not necessarily selected."
  (make-event-distributor))

(define-major-mode mail text "Mail"
  "Major mode for editing mail to be sent.
Like Text Mode but with these additional commands:
\\[mail-send]  mail-send (send the message)    \\[mail-send-and-exit]  mail-send-and-exit
Here are commands that move to a header field (and create it if there isn't):
	 \\[mail-to]  move to To:	\\[mail-subject]  move to Subject:
	 \\[mail-cc]  move to CC:	\\[mail-bcc]  move to BCC:
\\[mail-signature]  mail-signature (insert ~/.signature file).
\\[mail-yank-original]  mail-yank-original (insert current message, in Rmail).
\\[mail-fill-yanked-message]  mail-fill-yanked-message (fill what was yanked).
\\[mail-browse-attachments]  view, add, or delete MIME attachments."
  (lambda (buffer)
    (add-kill-buffer-hook buffer mail-kill-buffer)
    (local-set-variable!
     paragraph-start
     (string-append "^"
		    (re-quote-string (ref-variable mail-header-separator))
		    "$\\|^[ \t]*[-_][-_][-_]+$\\|"
		    (ref-variable paragraph-start buffer))
     buffer)
    (local-set-variable!
     paragraph-separate
     (string-append "^"
		    (re-quote-string (ref-variable mail-header-separator))
		    "$\\|^[ \t]*[-_][-_][-_]+$\\|"
		    (ref-variable paragraph-separate buffer))
     buffer)
    (event-distributor/invoke! (ref-variable mail-mode-hook buffer) buffer)))

(define-variable mail-mode-hook
  "An event distributor that is invoked when entering Mail mode."
  (make-event-distributor))

(define (mail-kill-buffer buffer)
  (let ((attachments-buffer (buffer-get buffer 'MIME-ATTACHMENTS-BROWSER #f)))
    (if attachments-buffer
	(kill-buffer attachments-buffer))))

(define-key 'mail '(#\C-c #\?) 'describe-mode)
(define-key 'mail '(#\C-c #\C-f #\C-t) 'mail-to)
(define-key 'mail '(#\C-c #\C-f #\C-b) 'mail-bcc)
(define-key 'mail '(#\C-c #\C-f #\C-c) 'mail-cc)
(define-key 'mail '(#\C-c #\C-f #\C-s) 'mail-subject)
(define-key 'mail '(#\C-c #\C-a) 'mail-browse-attachments)
(define-key 'mail '(#\C-c #\C-w) 'mail-signature)
(define-key 'mail '(#\C-c #\C-y) 'mail-yank-original)
(define-key 'mail '(#\C-c #\C-q) 'mail-fill-yanked-message)
(define-key 'mail '(#\C-c #\C-c) 'mail-send-and-exit)
(define-key 'mail '(#\C-c #\C-s) 'mail-send)

(define-command mail-signature
  "Sign letter with contents of ~/.signature file."
  ()
  (lambda ()
    (insert-file (buffer-end (selected-buffer)) "~/.signature")))

(define ((field-mover field))
  (set-current-point! (mail-position-on-field (selected-buffer) field)))

(define ((cc-field-mover field))
  (set-current-point! (mail-position-on-cc-field (selected-buffer) field)))

(define-command mail-to
  "Move point to end of To field."
  ()
  (field-mover "To"))

(define-command mail-subject
  "Move point to end of Subject field."
  ()
  (field-mover "Subject"))

(define-command mail-cc
  "Move point to end of CC field."
  ()
  (cc-field-mover "CC"))

(define-command mail-bcc
  "Move point to end of BCC field."
  ()
  (cc-field-mover "BCC"))

(define (mail-position-on-field buffer field)
  (mail-field-end! (buffer-start buffer)
		   (mail-match-header-separator buffer)
		   field))

(define (mail-position-on-cc-field buffer field)
  (let ((start (buffer-start buffer))
	(end (mail-match-header-separator buffer)))
    (or (mail-field-end start end field)
	(mail-insert-field (or (mail-field-end start end "CC")
			       (mail-field-end start end "To")
			       (mail-insert-field end "To"))
			   field))))

(define (mail-match-header-separator buffer)
  (if (not (re-search-forward
	    (string-append
	     "^"
	     (re-quote-string (ref-variable mail-header-separator buffer))
	     "$")
	    (buffer-start buffer)
	    (buffer-end buffer)
	    #f))
      (editor-error "Can't find mail-header-separator."))
  (re-match-start 0))

(define (mail-header-end start #!optional end error?)
  (let ((mark
	 (search-forward "\n\n"
			 start
			 (if (or (default-object? end) (not end))
			     (group-end start)
			     end)
			 #f)))
    (if (and (not mark) (or (default-object? error?) error?))
	(error "Unable to locate mail header end:" start))
    (and mark
	 (mark-1+ mark))))

(define (mail-field-start header-start header-end field)
  (re-search-forward (string-append "^" field ":[ \t]*")
		     header-start
		     header-end
		     #t))

(define (mail-field-end header-start header-end field)
  (let ((field-start (mail-field-start header-start header-end field)))
    (and field-start
	 (%mail-field-end field-start header-end))))

(define (mail-field-region header-start header-end field)
  (let ((field-start (mail-field-start header-start header-end field)))
    (and field-start
	 (make-region field-start (%mail-field-end field-start header-end)))))

(define (%mail-field-end field-start header-end)
  (if (re-search-forward "^[^ \t]" field-start header-end #f)
      (mark-1+ (re-match-start 0))
      header-end))

(define (mail-insert-field mark field)
  (let ((mark (mark-left-inserting-copy mark)))
    (if (not (line-start? mark))
	(let ((ls (line-start mark 1 #f)))
	  (if ls
	      (move-mark-to! mark ls)
	      (begin
		(move-mark-to! mark (line-end mark 0))
		(insert-newline mark)))))
    (insert-string field mark)
    (insert-string ": " mark)
    (insert-newline mark)
    (mark-temporary! mark)
    (mark-1+ mark)))

(define (mail-field-end! header-start header-end field)
  (or (mail-field-end header-start header-end field)
      (mail-insert-field header-end field)))

(define (mail-new-field! header-start header-end field)
  (let ((region (mail-field-region header-start header-end field)))
    (if region
	(begin
	  (region-delete! region)
	  (region-start region))
	(mail-insert-field header-end field))))

(define (mail-insert-field-value header-end field value)
  (insert-string value (mail-insert-field header-end field)))

(define (mail-insert-field-value! header-start header-end field value)
  (insert-string value (mail-new-field! header-start header-end field)))

(define-command mail-yank-original
  "Insert the message being replied to, if any (in rmail or imail).
Puts point after the text and mark before.
Normally, indents each nonblank line ARG spaces (default 3).
However, if `mail-yank-prefix' is a string, insert that prefix on each line.
Just \\[universal-argument] as argument means don't indent, insert no prefix,
and don't delete any header fields."
  "P"
  (lambda (argument)
    (let ((mail-reply-buffer (ref-variable mail-reply-buffer)))
      (if mail-reply-buffer
	  (receive (prefix left-margin)
	      (cond ((command-argument-multiplier-only? argument)
		     (values #f 0))
		    ((command-argument-value argument)
		     => (lambda (v)
			  (values #f (max 0 v))))
		    ((ref-variable mail-yank-prefix)
		     => (lambda (prefix)
			  (values prefix
				  (string-columns
				   prefix
				   0
				   (ref-variable tab-width)
				   default-char-image-strings))))
		    (else
		     (values #f 3)))
	    (for-each (lambda (window)
			(if (not (window-has-no-neighbors? window))
			    (window-delete! window)))
		      (buffer-windows mail-reply-buffer))
	    (let ((end (mark-left-inserting-copy (current-point))))
	      (let ((start (mark-right-inserting-copy end)))
		(let ((method
		       (buffer-get mail-reply-buffer
				   'MAIL-YANK-ORIGINAL-METHOD
				   #f)))
		  (if method
		      (method mail-reply-buffer left-margin end)
		      (insert-region (buffer-start mail-reply-buffer)
				     (buffer-end mail-reply-buffer)
				     start)))
		(if (not (line-end? end))
		    (insert-newline end))
		(if (not (command-argument-multiplier-only? argument))
		    (begin
		      (mail-yank-clear-headers start end)
		      (if prefix
			  (for-each-line-in-region start end
			    (lambda (mark)
			      (insert-string prefix mark)))
			  (indent-rigidly start end left-margin))))
		(mark-temporary! start)
		(mark-temporary! end)
		(push-current-mark! start)
		(set-current-point! end))))))))

(define (mail-yank-clear-headers start end)
  (let ((start (mark-left-inserting-copy start))
	(end
	 (mark-left-inserting-copy
	  (if (re-search-forward "\n\n" start end #f)
	      (mark1+ (re-match-start 0))
	      end)))
	(mail-yank-ignored-headers (ref-variable mail-yank-ignored-headers)))
    (with-text-clipped start end
      (lambda ()
	(do ()
	    ((not
	      (re-search-forward mail-yank-ignored-headers start end #t)))
	  (move-mark-to! start (re-match-start 0))
	  (delete-string
	   start
	   (if (re-search-forward "^[^ \t]" (line-end start 0) end #f)
	       (re-match-start 0)
	       end)))))
    (mark-temporary! start)
    (mark-temporary! end)))

(define-command mail-fill-yanked-message
  "Fill the paragraphs of a message yanked into this one.
Numeric argument means justify as well."
  "P"
  (lambda (justify?)
    (let ((buffer (selected-buffer)))
      (mail-match-header-separator buffer)
      (fill-individual-paragraphs (re-match-end 0)
				  (buffer-end buffer)
				  (ref-variable fill-column)
				  justify?
				  #t))))

(define-command mail-send-and-exit
  "Send message like mail-send, then, if no errors, exit from mail buffer.
Prefix arg means don't delete this window."
  "P"
  (lambda (argument)
    ((ref-command mail-send))
    (bury-buffer (selected-buffer))
    (if (and (not argument)
	     (not (window-has-no-neighbors? (selected-window)))
	     (eq? (ref-mode-object rmail)
		  (buffer-major-mode (window-buffer (other-window)))))
	(window-delete! (selected-window))
	(select-buffer (previous-buffer)))))

(define-command mail-send
  "Send the message in the current buffer.
If `mail-interactive' is true, wait for success indication
or error messages, and inform user.
Otherwise any failure is reported in a message back to
the user from the mailer."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (if (if (buffer-pathname buffer)
	      (prompt-for-confirmation? "Send buffer contents as mail message")
	      (or (buffer-modified? buffer)
		  (prompt-for-confirmation? "Message already sent; resend")))
	  (begin
	    ((ref-variable send-mail-procedure))
	    (buffer-not-modified! buffer)
	    (delete-auto-save-file! buffer))))))

(define (sendmail-send-it)
  (let ((mail-buffer (selected-buffer)))
    (prepare-mail-buffer-for-sending mail-buffer
      (lambda (h-start h-end b-start b-end)
	(finish-preparing-mail-buffer h-start h-end b-start b-end mail-buffer
	  (lambda (send-mail message-pathname)
	    message-pathname
	    (send-mail)))))))

(define (prepare-mail-buffer-for-sending mail-buffer receiver)
  (guarantee-newline (buffer-end mail-buffer))
  (call-with-temporary-buffer " sendmail header"
    (lambda (h-buffer)
      (let ((m (mail-match-header-separator mail-buffer)))
	(let ((b-start
	       (mark-right-inserting-copy
		(line-start (re-match-end 0) 1 'LIMIT)))
	      (b-end (mark-left-inserting-copy (buffer-end mail-buffer)))
	      (h-start (mark-right-inserting-copy (buffer-start h-buffer)))
	      (h-end (mark-left-inserting-copy (buffer-start h-buffer))))
	  (delete-string h-start h-end)
	  (insert-region (buffer-start mail-buffer) m h-end)
	  (guarantee-newline h-end)
	  ;; Delete any blank lines in the header.
	  (do ((h-start h-start (replace-match "\n")))
	      ((not (re-search-forward "\n\n+" h-start h-end #f))))
	  ;; Delete a blank subject line.
	  (if (re-search-forward "^Subject:[ \t]*\n" h-start h-end #t)
	      (delete-match))
	  (expand-mail-aliases h-start h-end)
	  (let ((add-field
		 (lambda (name value)
		   (if (and value (not (mail-field-start h-start h-end name)))
		       (mail-insert-field-value h-end name value)))))
	    (add-field "Date" (universal-time->string (get-universal-time)))
	    ;; If there is a From and no Sender, put in a Sender.
	    (add-field (if (mail-field-start h-start h-end "From")
			   "Sender"
			   "From")
		       (mail-from-string mail-buffer))
	    (add-field "Organization" (mail-organization-string mail-buffer))
	    (add-field "User-Agent" (mailer-version-string mail-buffer)))
	  (let ((v (receiver h-start h-end b-start b-end)))
	    (mark-temporary! h-start)
	    (mark-temporary! h-end)
	    (mark-temporary! b-start)
	    (mark-temporary! b-end)
	    v))))))

(define (mail-organization-string buffer)
  (let ((organization (ref-variable mail-organization buffer)))
    (and (not (string-null? organization))
	 organization)))

(define (mailer-version-string buffer)
  (and (ref-variable mail-identify-reader buffer)
       (let ((generic
	      (string-append "Edwin/"
			     (get-subsystem-version-string "edwin")
			     "; MIT-Scheme/"
			     (get-subsystem-version-string "release")))
	     (method
	      (or (buffer-get buffer 'MAILER-VERSION-STRING #f)
		  global-mailer-version-string)))
	 (if method
	     (method generic)
	     generic))))

(define global-mailer-version-string #f)

(define (finish-preparing-mail-buffer h-start h-end b-start b-end
				      lookup-context receiver)
  (if (buffer-mime-processing-enabled? (mark-buffer b-start))
      (begin
	(guarantee-mime-compliant-headers h-start h-end)
	(delete-mime-headers! h-start h-end)))
  (let ((fcc-pathnames
	 (if (mail-field-start h-start h-end "FCC")
	     (compute-fcc-pathnames h-start h-end)
	     '())))
    (call-with-temporary-file-pathname
     (lambda (message-pathname)
       (receiver
	(if (ref-variable mail-relay-host lookup-context)
	    (let ((recipients (compute-message-recipients h-start h-end)))
	      (write-message-file h-start h-end b-start b-end message-pathname)
	      (write-fcc-messages fcc-pathnames
				  message-pathname
				  lookup-context)
	      (lambda ()
		(send-mail-using-smtp message-pathname
				      recipients
				      lookup-context)))
	    (begin
	      (write-message-file h-start h-end b-start b-end message-pathname)
	      (write-fcc-messages fcc-pathnames
				  message-pathname
				  lookup-context)
	      (lambda ()
		(send-mail-using-sendmail message-pathname lookup-context))))
	message-pathname)))))

(define (write-message-file h-start h-end b-start b-end message-pathname)
  (call-with-output-file message-pathname
    (lambda (port)
      (write-region-to-port h-start h-end port)
      (if (buffer-mime-processing-enabled? (mark-buffer b-start))
	  (write-mime-message-body b-start b-end port)
	  (begin
	    (newline port)
	    (write-region-to-port b-start b-end port)
	    (fresh-line port))))))

(define (write-region-to-port start end port)
  (group-write-to-port (mark-group start)
		       (mark-index start)
		       (mark-index end)
		       port))

(define (compute-fcc-pathnames h-start h-end)
  (let ((m (mark-right-inserting-copy h-start)))
    (let loop ((pathnames '()))
      (if (re-search-forward "^FCC:[ \t]*\\([^ \t\n]+\\)" m h-end #t)
	  (let ((filename
		 (extract-string (re-match-start 1) (re-match-end 1))))
	    (move-mark-to! m (line-start (re-match-start 0) 0))
	    (delete-string m (line-start m 1))
	    (loop
	     (cons (merge-pathnames filename (user-homedir-pathname))
		   pathnames)))
	  (begin
	    (mark-temporary! m)
	    pathnames)))))

(define (write-fcc-messages pathnames message-pathname lookup-context)
  (for-each
   (let ((append-message
	  (let ((header-line
		 (string-append
		  "From "
		  (user-mail-address lookup-context)
		  " "
		  (universal-time->local-ctime-string (get-universal-time)))))
	    (lambda (length port)
	      (if (> length 0)
		  (newline port))
	      (write-string header-line port)
	      (newline port)
	      (call-with-input-file message-pathname
		(lambda (input)
		  (let loop ()
		    (let ((line (read-line input)))
		      (if (not (eof-object? line))
			  (begin
			    ;; ``Quote'' "^From " as ">From "
			    ;; (note that this isn't really quoting,
			    ;; as there is no requirement that
			    ;; "^[>]+From " be quoted in the same
			    ;; transparent way.)
			    (if (string-prefix-ci? "from " line)
				(write-char #\> port))
			    (write-string line port)
			    (newline port)
			    (loop)))))))
	      (newline port)))))
     (lambda (pathname)
       (let ((buffer (pathname->buffer pathname)))
	 (if buffer
	     (call-with-output-mark (buffer-end buffer)
	       (lambda (port)
		 (append-message (buffer-length buffer) port)))
	     (call-with-append-file pathname
	       (lambda (port)
		 (append-message ((textual-port-operation port 'LENGTH) port)
				 port)))))))
   pathnames))

(define (compute-message-recipients h-start h-end)
  (receive (regexp prefix)
      (if (mail-field-start h-start h-end "resent-to")
	  (values "^\\(resent-to:\\|resent-cc:\\|resent-bcc:\\)[ \t]*"
		  "resent-bcc:")
	  (values "^\\(to:\\|cc:\\|bcc:\\)[ \t]*" "bcc:"))
    (let loop ((start h-start) (addresses '()))
      (let ((f-start (re-search-forward regexp start h-end #t)))
	(if f-start
	    (let* ((f-end (%mail-field-end f-start h-end))
		   (addresses
		    (append (rfc822:string->addresses
			     (extract-string f-start f-end))
			    addresses))
		   (ls (line-start f-start 0)))
	      (if (match-forward prefix ls h-end #t)
		  (begin
		    (delete-string ls (mark1+ f-end 'LIMIT))
		    (loop ls addresses))
		  (loop f-end addresses)))
	    addresses)))))

;;;; Sendmail transmission

(define (send-mail-using-sendmail message-pathname lookup-context)
  (message "Sending...")
  (let ((program
	 (or (ref-variable sendmail-program lookup-context)
	     (os/sendmail-program))))
    (if (ref-variable mail-interactive lookup-context)
	(call-with-temporary-buffer " sendmail errors"
	  (lambda (error-buffer)
	    (let ((error-port (mark->output-port (buffer-end error-buffer))))
	      (run-synchronous-process-1 error-port
		(lambda ()
		  (run-shell-command
		   (string-append program
				  " -oi -t"
				  ;; Always specify who from, since
				  ;; some systems have broken
				  ;; sendmails.
				  " -f" (current-user-name)
				  " < " (->namestring message-pathname))
		   'OUTPUT error-port)))
	      (close-port error-port))
	    (let ((end (buffer-end error-buffer)))
	      (do ((start (buffer-start error-buffer) (replace-match "; ")))
		  ((not (re-search-forward "\n+ *" start end #f)))))
	    (let ((errors (buffer-string error-buffer)))
	      (if (not (string-null? errors))
		  (editor-error "Sending...failed to " errors)))))
	;; If we aren't going to look at the errors, run the program
	;; in the background so control returns to the user as soon as
	;; possible.
	(run-shell-command
	 (string-append program
			" -oi -t"
			;; Always specify who from, since some systems
			;; have broken sendmails.
			" -f" (current-user-name)
			;; These mean "report errors by mail" and
			;; "deliver in background".
			" -oem -odb"
			" < " (->namestring message-pathname))
	 'OUTPUT #f)))
  (message "Sending...done"))

;;;; Direct SMTP transmission

(define (send-mail-using-smtp message-pathname recipients lookup-context)
  (message "Sending...")
  (if (null? recipients)
      (editor-error "No recipients specified for mail."))
  (let ((trace-buffer
	 (and (ref-variable smtp-trace lookup-context)
	      (temporary-buffer "*SMTP-trace*"))))
    (let ((responses
	   (transact-smtp recipients
                          message-pathname
                          trace-buffer
                          lookup-context)))
      (cond ((not (every smtp-response-valid? responses))
	     (pop-up-temporary-buffer "*SMTP-invalid*"
				      '(READ-ONLY FLUSH-ON-SPACE)
	       (lambda (buffer window)
		 window
		 (let ((m (mark-left-inserting-copy (buffer-start buffer))))
		   (for-each (lambda (recipient response)
			       (if (not (smtp-response-valid? response))
				   (begin
				     (insert-string recipient m)
				     (insert-char #\tab m)
				     (insert-string response m)
				     (insert-newline m))))
			     recipients responses)
		   (mark-temporary! m)))))
	    (trace-buffer
	     (set-buffer-point! trace-buffer (buffer-start trace-buffer))
	     (buffer-not-modified! trace-buffer)
	     (pop-up-buffer trace-buffer #f)))
      (message "Sending..."
	       (if (smtp-responses-ok? responses lookup-context)
		   "done"
		   "aborted")))))

(define (transact-smtp recipients message-pathname trace-buffer lookup-context)
  (call-with-smtp-socket (ref-variable mail-relay-host lookup-context)
			 (ref-variable mail-relay-service lookup-context)
			 trace-buffer
    (lambda (port banner)
      banner				;ignore
      (let ((capabilities
	     (smtp-command/ehlo port (smtp-greeting-hostname lookup-context))))
	(smtp-authenticate port capabilities lookup-context)
	(smtp-command/mail port (rfc822:canonicalize-address-string
				 (mail-from-string lookup-context)))
	(let ((responses
	       (map (lambda (recipient)
		      (smtp-command/rcpt port recipient))
		    recipients)))
	  (if (smtp-responses-ok? responses lookup-context)
	      (smtp-command/data port message-pathname)
	      (smtp-command/rset port))
	  (smtp-command/quit port)
	  responses)))))

(define (smtp-response-valid? response)
  (= 250 (smtp-response-number response)))

(define (smtp-responses-ok? responses lookup-context)
  (if (ref-variable smtp-require-valid-recipients lookup-context)
      (every smtp-response-valid? responses)
      (any smtp-response-valid? responses)))

(define (call-with-smtp-socket host-name service trace-buffer receiver)
  (let ((port #f))
    (dynamic-wind
     (lambda ()
       (set! port
	     (make-smtp-port (open-tcp-stream-socket host-name
						     (or service "smtp"))
			     trace-buffer))
       unspecific)
     (lambda ()
       (receiver port (smtp-read-response port 220)))
     (lambda ()
       (if port
	   (begin
	     (close-port (smtp-port-port port))
	     (set! port #f)
	     unspecific))))))

(define-structure smtp-port
  (port #f read-only #t)
  (trace-buffer #f read-only #t))

(define (smtp-read-line port)
  (let ((line (read-line (smtp-port-port port))))
    (if (eof-object? line)
	(editor-error "Premature end of input from SMTP server: " port))
    (smtp-trace-write-string line port)
    (smtp-trace-newline port)
    line))

(define (smtp-write-line port . strings)
  (for-each (lambda (string)
	      (smtp-trace-write-string string port)
	      (write-string string (smtp-port-port port)))
	    strings)
  (smtp-trace-newline port)
  (newline (smtp-port-port port)))

(define (smtp-drain-output port)
  (flush-output-port (smtp-port-port port)))

(define (smtp-trace-write-string string port)
  (let ((trace-buffer (smtp-port-trace-buffer port)))
    (if trace-buffer
	(insert-string string (buffer-end trace-buffer)))))

(define (smtp-trace-newline port)
  (let ((trace-buffer (smtp-port-trace-buffer port)))
    (if trace-buffer
	(insert-newline (buffer-end trace-buffer)))))

(define (smtp-command/ehlo port hostname)
  ;++ This should probably fall back on HELO if the server answers
  ;++ non-250, but honestly, how many non-ESMTP servers are there out
  ;++ there?
  (smtp-write-line port "EHLO " hostname)
  (smtp-read-response port 250))

(define (smtp-command/helo port hostname)
  (smtp-write-line port "HELO " hostname)
  (smtp-read-response port 250))

(define (smtp-command/mail port from)
  (smtp-write-line port "MAIL FROM:<" from ">")
  (smtp-read-response port 250))

(define (smtp-command/rcpt port recipient)
  (smtp-write-line port "RCPT TO:<" recipient ">")
  (smtp-read-response port 250 550))

(define (smtp-command/data port message-pathname)
  (smtp-write-line port "DATA")
  (smtp-read-response port 354)
  (call-with-input-file message-pathname
    (lambda (input)
      (let loop ()
	(let ((line (read-line input)))
	  (if (not (eof-object? line))
	      (begin
		(if (and (fix:> (string-length line) 0)
			 (char=? #\. (string-ref line 0)))
		    (smtp-write-line port "." line)
		    (smtp-write-line port line))
		(loop)))))))
  (smtp-write-line port ".")
  (smtp-read-response port 250))

(define (smtp-command/rset port)
  (smtp-write-line port "RSET")
  (smtp-read-response port 250))

(define (smtp-command/quit port)
  (smtp-write-line port "QUIT")
  (smtp-read-response port 221))

(define (smtp-greeting-hostname lookup-context)
  (let ((hostname (ref-variable smtp-greeting-hostname lookup-context)))
    (if (procedure? hostname)
	(hostname)
	hostname)))

(define (smtp-read-response port . numbers)
  (smtp-drain-output port)
  (let ((response (smtp-read-line port)))
    (let ((n (smtp-response-number response)))
      (if (not (any (lambda (n*) (= n n*)) numbers))
	  (editor-error response))
      (if (smtp-response-continued? response)
	  (let loop ((responses (list response)))
	    (let ((response (smtp-read-line port)))
	      (if (not (= n (smtp-response-number response)))
		  (error "Mismatched codes in multiline response:" n response))
	      (let ((responses (cons response responses)))
		(if (smtp-response-continued? response)
		    (loop responses)
		    (convert-smtp-multiline-response (reverse! responses))))))
	  response))))

(define (smtp-response-number line)
  (or (and (fix:>= (string-length line) 3)
	   (substring->nonnegative-integer line 0 3))
      (error "Malformed SMTP response:" line)))

(define (smtp-response-continued? line)
  (and (fix:>= (string-length line) 4)
       (char=? #\- (string-ref line 3))))

(define (convert-smtp-multiline-response responses)
  (apply string-append
	 (cons* (string-head (car responses) 3)
		" "
		(let ((lines
		       (map (lambda (response) (string-tail response 4))
			    responses)))
		  (cons (car lines)
			(append-map (lambda (line) (list "\n" line))
				    (cdr lines)))))))

;;;;; SMTP Authentication

(define (smtp-authenticate port capabilities lookup-context)
  (define (authenticate method)
    (smtp-authenticate-with-method port method lookup-context))
  (let ((method (ref-variable mail-authentication lookup-context)))
    (if method
	(let ((accepted-methods
	       (smtp-accepted-authentication-methods capabilities)))
	  (if (not (pair? accepted-methods))
	      (editor-failure "No accepted authentication methods.")
	      (cond ((and (eq? method #t)
			  (or (member "LOGIN" accepted-methods)
			      (member "PLAIN" accepted-methods)))
		     => (lambda (tail)
			  (authenticate (car tail))))
		    ((member method accepted-methods)
		     (authenticate method))
		    (else
		     (editor-failure "Authentication method not accepted:"
				     method))))))))

(define rexp:sasl-mechanism		;RFC 2222, Section 3, par. 2
  (let ((char-set
	 (char-set-union char-set:upper-case
			 char-set:numeric
			 (char-set #\- #\_))))
    ;; The regexp compiler loses on this, unfortunately.  Fortunately,
    ;; it doesn't matter, because if there were an excessively long
    ;; name, it would have already caused any harm it could by the
    ;; time we try to examine it here.
    ;;	 (rexp-n*m 1 20 char-set)
    (rexp+ char-set)))

(define regexp:sasl-mechanism (rexp->regexp rexp:sasl-mechanism))

(define rexp:smtp-auth-keywords
  (rexp-sequence (rexp-line-start)
		 "AUTH"
		 (rexp-group (rexp* " " rexp:sasl-mechanism))))

(define regexp:smtp-auth-keywords (rexp->regexp rexp:smtp-auth-keywords))

(define (smtp-accepted-authentication-methods capabilities)
  (let ((match
	 (re-string-search-forward regexp:smtp-auth-keywords capabilities)))
    (if match
	(cdr (burst-string (re-match-extract capabilities match 1) #\space #f))
	'())))

(define (smtp-authenticate-with-method port method lookup-context)
  (smtp-write-line port "AUTH " method)
  (smtp-read-response port 334)
  (let* ((user-name
	  (or (ref-variable smtp-user-name lookup-context)
	      (prompt-for-string "User name" #f)))
	 (pass-phrase-key
	  (smtp-server-pass-phrase-key user-name lookup-context)))
    (cond ((string=? method "LOGIN")
	   (smtp-auth:login port user-name pass-phrase-key))
	  ((string=? method "PLAIN")
	   (smtp-auth:plain port user-name pass-phrase-key))
	  (else (error "Unknown SMTP authentication method:" method)))
    (bind-condition-handler
	(list condition-type:editor-error)
	(lambda (condition)
	  condition			;ignore
	  (delete-stored-pass-phrase pass-phrase-key))
      (lambda ()
	(smtp-read-response port 235)))))

(define (smtp-auth:login port user-name pass-phrase-key)
  (define (base64 string)
    (string-trim
     (call-with-output-string
       (lambda (port)
	 (let ((context (encode-base64:initialize port #f)))
	   (encode-base64:update context (string->bytevector string))
	   (encode-base64:finalize context))))))
  (smtp-write-line port (base64 user-name))
  (smtp-read-response port 334)
  (smtp-write-line port (call-with-stored-pass-phrase pass-phrase-key base64)))

(define (smtp-auth:plain port user-name pass-phrase-key)
  ((lambda (string)
     (smtp-write-line port (string-trim string)))
   (call-with-output-string
     (lambda (port)
       (let ((context (encode-base64:initialize port)))
	 (encode-base64:update context (bytevector 0))
	 (encode-base64:update context (string->bytevector user-name))
	 (encode-base64:update context (bytevector 0))
	 (call-with-stored-pass-phrase pass-phrase-key
	   (lambda (pass)
	     (encode-base64:update context (string->bytevector pass))))
	 (encode-base64:finalize context))))))

(define (smtp-server-pass-phrase-key user-name lookup-context)
  ;++ Should this include `SMTP' anywhere?  Generating
  ;++ `smtp://<user-name>@<host>:<port>' is disgusting, but it would
  ;++ do the trick...
  (string-append user-name
		 "@"
		 (ref-variable mail-relay-host lookup-context)
		 (let ((service
			(ref-variable mail-relay-service lookup-context)))
		   (if (or (eqv? service 25)
			   (equal? service "smtp"))
		       ""
		       (string-append ":"
				      (if (string? service)
					  service
					  (number->string service #d10)))))))

;;;; MIME

(define (write-mime-message-body b-start b-end port)
  (write-message-header-field "MIME-Version" "1.0" port)
  (let ((attachments (buffer-mime-attachments (mark-buffer b-start))))
    (if (null? attachments)
	(write-mime-message-body-1 b-start b-end #f port)
	(write-mime-message-body-with-attachments b-start b-end attachments
						  port))))

(define (write-message-header-field name value port)
  (write-string name port)
  (write-string ": " port)
  (write-string value port)
  (newline port))

(define (write-mime-message-body-1 b-start b-end subpart? port)
  (if (not (and subpart? (ref-variable mail-abbreviate-mime b-start)))
      (write-message-header-field
       "Content-Type"
       (string-append "text/plain; charset="
                      (ref-variable mail-charset b-start))
       port))
  (if (or (any-non-printable-7bit-chars? b-start b-end)
	  (any-lines-too-long? b-start b-end 76))
      (begin
	(write-message-header-field "Content-Transfer-Encoding"
				    "quoted-printable"
				    port)
	(newline port)
	(let ((context (encode-quoted-printable:initialize port #t)))
	  (%group-write (mark-group b-start)
			(mark-index b-start)
			(mark-index b-end)
	    (lambda (string start end)
	      (encode-quoted-printable:update
               context
               (string-copy string)
               start
               end)))
	  (encode-quoted-printable:finalize context)))
      (begin
	(if (not (and subpart? (ref-variable mail-abbreviate-mime b-start)))
	    (write-message-header-field "Content-Transfer-Encoding"
					"7bit"
					port))
	(newline port)
	(write-region-to-port b-start b-end port))))

(define (any-non-printable-7bit-chars? start end)
  (group-find-next-char-in-set (mark-group start)
			       (mark-index start)
			       (mark-index end)
			       char-set:non-printable-7bit))

(define (any-lines-too-long? start end n)
  (let loop ((ls (line-start start 0)))
    (let ((le (line-end ls 0)))
      (or (> (- (mark-index le) (mark-index ls)) n)
	  (let ((ls (line-start le 1 #f)))
	    (and ls
		 (mark< ls end)
		 (loop ls)))))))

(define char-set:printable-7bit
  (char-set-union (ascii-range->char-set #x20 #x7F)
                  (char-set #\tab #\page #\linefeed)))

(define char-set:non-printable-7bit
  (char-set-invert char-set:printable-7bit))

(define regexp:non-printable-7bit
  (char-set->regexp char-set:non-printable-7bit))

(define (write-mime-message-body-with-attachments b-start b-end attachments
						  port)
  (let ((boundary (random-mime-boundary-string 32)))
    (write-message-header-field "Content-Type"
				(string-append "multipart/mixed; boundary=\""
					       boundary
					       "\"")
				port)
    (write-message-header-field "Content-Transfer-Encoding" "7bit" port)
    (newline port)
    (write-string "This is a multi-part message in MIME format." port)
    (write-mime-boundary boundary #f port)
    (write-mime-message-body-1 b-start b-end #t port)
    (for-each (lambda (attachment)
		(write-mime-boundary boundary #f port)
		(write-mime-attachment attachment b-start port))
	      attachments)
    (write-mime-boundary boundary #t port)))

(define (write-mime-boundary boundary final? port)
  (newline port)
  (write-string "--" port)
  (write-string boundary port)
  (if final? (write-string "--" port))
  (newline port))

(define (write-mime-attachment attachment lookup-context port)
  (let ((type (mime-attachment-type attachment))
	(subtype (mime-attachment-subtype attachment)))
    (write-message-header-field
     "Content-Type"
     (string-append (symbol->string type)
		    "/"
		    (symbol->string subtype)
		    (mime-parameters->string
		     (mime-attachment-parameters attachment)))
     port)
    (if (and (eq? type 'MESSAGE) (eq? subtype 'RFC822))
	(if (not (ref-variable mail-abbreviate-mime lookup-context))
	    (write-message-header-field "Content-Transfer-Encoding"
					"7bit"
					port))
	(write-message-header-field "Content-Transfer-Encoding"
				    (if (eq? type 'TEXT)
					"quoted-printable"
					"base64")
				    port))
    (let ((disposition (mime-attachment-disposition attachment)))
      (if disposition
	  (write-message-header-field "Content-Disposition"
				      (mime-disposition->string disposition)
				      port)))
    (newline port)
    (if (and (eq? type 'MESSAGE) (eq? subtype 'RFC822))
	(begin
	  (for-each (lambda (nv)
		      (write-message-header-field (car nv) (cadr nv) port))
		    (mime-attachment-message-headers attachment))
	  (newline port)
	  ((mime-attachment-message-body-generator attachment) port))
	(if (eq? type 'TEXT)
	    (let ((context (encode-quoted-printable:initialize port #t)))
	      (call-with-input-file (mime-attachment-pathname attachment)
		(lambda (input-port)
		  (let ((buffer (make-string 4096)))
		    (let loop ()
		      (let ((n-read (read-string! buffer input-port)))
			(if (> n-read 0)
			    (begin
			      (encode-quoted-printable:update context
							      buffer 0 n-read)
			      (loop))))))))
	      (encode-quoted-printable:finalize context))
	    (let ((context (encode-base64:initialize port #f)))
	      (call-with-binary-input-file
		  (mime-attachment-pathname attachment)
		(lambda (input-port)
		  (let ((buffer (make-bytevector 4096)))
		    (let loop ()
		      (let ((n-read (read-bytevector! buffer input-port)))
			(if (> n-read 0)
			    (begin
			      (encode-base64:update context buffer 0 n-read)
			      (loop))))))))
	      (encode-base64:finalize context))))))

(define (enable-buffer-mime-processing! buffer)
  (buffer-remove! buffer 'MAIL-DISABLE-MIME-PROCESSING))

(define (disable-buffer-mime-processing! buffer)
  (buffer-put! buffer 'MAIL-DISABLE-MIME-PROCESSING #t))

(define (buffer-mime-processing-enabled? buffer)
  (not (buffer-get buffer 'MAIL-DISABLE-MIME-PROCESSING #f)))

(define (add-buffer-mime-attachment! buffer mime-type parameters disposition
				     . rest)
  (let ((attachment
	 (list->vector
	  (cons* (mime-type/top-level mime-type)
		 (mime-type/subtype mime-type)
		 parameters
		 disposition
		 rest))))
    (set-buffer-mime-attachments! buffer
				  (append (buffer-mime-attachments buffer)
					  (list attachment)))
    attachment))

(define (delete-buffer-mime-attachment! buffer attachment)
  (set-buffer-mime-attachments! buffer
				(delq! attachment
				       (buffer-mime-attachments buffer))))

(define (buffer-mime-attachments buffer)
  (buffer-get buffer 'MAIL-MIME-ATTACHMENTS '()))

(define (set-buffer-mime-attachments! buffer attachments)
  (buffer-put! buffer 'MAIL-MIME-ATTACHMENTS attachments)
  (local-set-variable! mode-line-process
		       (let ((n (length attachments)))
			 (and (> n 0)
			     (string-append
			      " ("
			      (number->string n)
			      " attachment"
			      (if (> n 1) "s" "")
			      ")")))
		       buffer)
  (buffer-modeline-event! buffer 'PROCESS-STATUS))

(define-integrable (mime-attachment-type attachment)
  (vector-ref attachment 0))

(define-integrable (mime-attachment-subtype attachment)
  (vector-ref attachment 1))

(define-integrable (mime-attachment-parameters attachment)
  (vector-ref attachment 2))

(define-integrable (mime-attachment-disposition attachment)
  (vector-ref attachment 3))

(define-integrable (mime-attachment-message-headers attachment)
  (vector-ref attachment 4))

(define-integrable (mime-attachment-message-body-generator attachment)
  (vector-ref attachment 5))

(define-integrable (mime-attachment-pathname attachment)
  (vector-ref attachment 4))

(define (mime-parameters->string parameters)
  (decorated-string-append
   "; " "" ""
   (map (lambda (parameter)
	  (string-append (symbol->string (car parameter))
			 "=\""
			 (cadr parameter)
			 "\""))
	parameters)))

(define (mime-disposition->string disposition)
  (string-append (symbol->string (car disposition))
		 (mime-parameters->string (cdr disposition))))

(define (guarantee-mime-compliant-headers h-start h-end)
  (if (any-non-printable-7bit-chars? h-start h-end)
      (begin
	(pop-up-occur-buffer h-start h-end regexp:non-printable-7bit #f)
	(editor-error "Message contains illegal characters in header.")))
  (if (any-lines-too-long? h-start h-end 998)
      (editor-error "Message contains over-long line in header.")))

(define (delete-mime-headers! h-start h-end)
  (let loop ((f-start h-start))
    (if (mark< f-start h-end)
	(let ((colon (search-forward ":" f-start (line-end f-start 0))))
	  (if (not colon)
	      (error "Not a header-field line:" f-start))
	  (let ((name (string-trim (extract-string f-start (mark-1+ colon))))
		(f-start*
		 (if (re-search-forward "^[^ \t]" colon h-end #f)
		     (re-match-start 0)
		     h-end)))
	    (if (or (string-ci=? "mime-version" name)
		    (string-prefix-ci? "content-" name))
		(begin
		  (delete-string f-start f-start*)
		  (loop f-start))
		(loop f-start*)))))))

(define (random-mime-boundary-string length)
  (if (not (exact-nonnegative-integer? length))
      (error:wrong-type-argument length "exact nonnegative integer"
				 'RANDOM-MIME-BOUNDARY-STRING))
  (let* ((prefix "=_")
	 (plen (string-length prefix)))
    (if (not (<= 1 length (- 70 plen)))
	(error:bad-range-argument length 'RANDOM-MIME-BOUNDARY-STRING))
    (string-head (call-with-output-string
		   (lambda (port)
		     (write-string prefix port)
		     (let ((context (encode-base64:initialize port #f)))
		       (let ((n (* (integer-ceiling (- length 2) 4) 3)))
			 (encode-base64:update context (random-bytevector n)))
		       (encode-base64:finalize context))))
		 (+ plen length))))

;;;; Attachment browser

(define-command mail-browse-attachments
  "Visit a buffer showing a list of the MIME attachments for this message.
You can add and delete attachments from that buffer."
  ()
  (lambda ()
    (select-buffer (mail-mime-attachments-browser (selected-buffer)))))

(define (mail-mime-attachments-browser mail-buffer)
  (let ((buffer (get-mime-attachments-buffer mail-buffer #t)))
    (rebuild-mime-attachments-buffer buffer)
    buffer))

(define (get-mime-attachments-buffer mail-buffer intern?)
  (or (let ((buffer
	     (buffer-get mail-buffer 'MIME-ATTACHMENTS-BROWSER #f)))
	(and buffer
	     (if (buffer-alive? buffer)
		 buffer
		 (begin
		   (buffer-remove! mail-buffer 'MIME-ATTACHMENTS-BROWSER)
		   #f))))
      (and intern?
	   (let ((buffer
		  (new-buffer
		   (string-append (buffer-name mail-buffer)
				  "-attachments"))))
	     (buffer-put! mail-buffer 'MIME-ATTACHMENTS-BROWSER buffer)
	     (buffer-put! buffer 'MAIL-BUFFER mail-buffer)
	     buffer))))

(define (rebuild-mime-attachments-buffer buffer)
  (buffer-widen! buffer)
  (with-read-only-defeated (buffer-start buffer)
    (lambda ()
      (fill-mime-attachments-buffer buffer)))
  (set-buffer-major-mode! buffer (ref-mode-object mime-attachments))
  (buffer-not-modified! buffer)
  (set-buffer-point! buffer (line-start (buffer-start buffer) 2 'ERROR)))

(define (fill-mime-attachments-buffer buffer)
  (let ((mail-buffer (buffer-get buffer 'MAIL-BUFFER #f)))
    (if (not (and mail-buffer (buffer-alive? mail-buffer)))
	(error "Missing mail buffer:" buffer))
    (region-delete! (buffer-region buffer))
    (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
      (insert-string-pad-right "Type" 30 #\space mark)
      (insert-char #\space mark)
      (insert-string "Filename" mark)
      (insert-newline mark)
      (insert-chars #\- 30 mark)
      (insert-char #\space mark)
      (insert-chars #\-
		    (max 8 (- (mark-x-size mark) (+ (mark-column mark) 1)))
		    mark)
      (insert-newline mark)
      (for-each (lambda (attachment)
		  (write-mime-attachment-line attachment mark))
		(buffer-mime-attachments mail-buffer))
      (mark-temporary! mark))))

(define (write-mime-attachment-line attachment mark)
  (let ((start (mark-right-inserting-copy mark))
	(type (mime-attachment-type attachment))
	(subtype (mime-attachment-subtype attachment)))
    (insert-string-pad-right (string-append (symbol->string type)
					    "/"
					    (symbol->string subtype))
			     30 #\space mark)
    (if (not (and (eq? type 'MESSAGE) (eq? subtype 'RFC822)))
	(begin
	  (insert-char #\space mark)
	  (insert-string
	   (->namestring (mime-attachment-pathname attachment))
	   mark)))
    (insert-newline mark)
    (region-put! start mark 'MIME-ATTACHMENT attachment)
    (mark-temporary! start)))

(define-major-mode mime-attachments read-only "MIME Attachments"
  "Major mode for browsing MIME mail attachments.
Commands available in this mode:

\\{mime-attachments}"
  (lambda (buffer)
    (buffer-put! buffer 'REVERT-BUFFER-METHOD mime-attachments-revert-buffer)
    (add-kill-buffer-hook buffer mime-attachments-kill-buffer)
    (local-set-variable! truncate-lines #t buffer)
    (local-set-variable! mode-line-modified "--- " buffer)
    (set-buffer-read-only! buffer)
    (disable-group-undo! (buffer-group buffer))
    (event-distributor/invoke! (ref-variable mime-attachments-mode-hook buffer)
			       buffer)))

(define-variable mime-attachments-mode-hook
  "An event distributor that is invoked when entering MIME Attachments mode."
  (make-event-distributor))

(define-key 'mime-attachments #\a 'add-mime-file-attachment)
(define-key 'mime-attachments #\d 'kill-mime-attachment)
(define-key 'mime-attachments #\k 'kill-mime-attachment)
(define-key 'mime-attachments #\? 'describe-mode)
(define-key 'mime-attachments #\q 'mime-attachments-quit)
(define-key 'mime-attachments '(#\c-c #\c-c) 'mime-attachments-quit)

(define (mime-attachments-revert-buffer buffer
					dont-use-auto-save? dont-confirm?)
  dont-use-auto-save?
  (if (or dont-confirm? (prompt-for-yes-or-no? "Revert attachments buffer"))
      (rebuild-mime-attachments-buffer buffer)))

(define (mime-attachments-kill-buffer buffer)
  (let ((mail-buffer (buffer-get buffer 'MAIL-BUFFER #f)))
    (if mail-buffer
	(buffer-remove! mail-buffer 'MIME-ATTACHMENTS-BROWSER))))

(define (selected-mail-buffer)
  (let ((buffer (selected-buffer)))
    (or (buffer-get buffer 'MAIL-BUFFER #f)
	buffer)))

(define-command add-mime-file-attachment
  "Add a file as a MIME attachment to the current mail message.
With prefix argument, allows you to specify the MIME type of the file.
Otherwise, the MIME type is determined from the file's suffix;
 if the suffix is unknown, you may choose a generic text or binary type."
  "FFile to attach\nP"
  (lambda (pathname argument)
    (let ((mail-buffer (selected-mail-buffer)))
      (let ((attachment
	     (receive (mime-type parameters)
		 (pathname->mime-type pathname mail-buffer argument)
	       (add-buffer-mime-attachment!
		mail-buffer
		mime-type
		`(,@parameters
		  (NAME ,(pathname-name pathname)))
		`(ATTACHMENT (FILENAME ,(file-namestring pathname)))
		pathname))))
	(let ((buffer (get-mime-attachments-buffer mail-buffer #f)))
	  (if buffer
	      (let ((mark (mark-left-inserting-copy (buffer-end buffer))))
		(with-read-only-defeated mark
		  (lambda ()
		    (write-mime-attachment-line attachment mark)))
		(mark-temporary! mark))))))))

(define-command kill-mime-attachment
  "Delete the MIME attachment that point is on."
  ()
  (lambda ()
    (let ((point (current-point)))
      (let ((attachment (region-get point 'MIME-ATTACHMENT #f)))
	(if (not attachment)
	    (editor-error "No attachment on current line."))
	(if (prompt-for-yes-or-no? "Delete attachment")
	    (begin
	      (delete-buffer-mime-attachment! (selected-mail-buffer)
					      attachment)
	      (with-read-only-defeated point
		(lambda ()
		  (delete-string (line-start point 0)
				 (line-start point 1 'ERROR))))))))))

(define-command mime-attachments-quit
  "Delete the MIME attachments buffer, returning to the message buffer."
  ()
  (lambda ()
    (let ((buffer (selected-buffer)))
      (let ((mail-buffer (buffer-get buffer 'MAIL-BUFFER #f)))
	(if (not mail-buffer)
	    (editor-error "No mail buffer found!"))
	(select-buffer mail-buffer))
      (kill-buffer-interactive buffer))))

(define (pathname->mime-type pathname buffer prompt?)
  (let ((mime-type
	 (let ((type (pathname-type pathname)))
	   (let ((do-mime
		  (lambda ()
		    (let ((type
			   (prompt-for-alist-value "MIME type"
						   mime-top-level-types
						   #f
						   #t)))
		      (make-mime-type
		       type
		       (string->symbol
			(prompt-for-string "MIME subtype" #f)))))))
	     (if prompt?
		 (do-mime)
		 (let ((entry
			(find (lambda (entry)
				(cond ((string? type)
				       (string-ci=? (car entry) type))
				      ((not type)
				       (not (car entry)))
				      (else
				       (eq? type 'WILD))))
			      (ref-variable file-type-to-mime-type buffer))))
		   (cond (entry (make-mime-type (cadr entry) (caddr entry)))
			 ((pathname-mime-type pathname))
			 (else
			  (let loop ()
			    (case (prompt-for-char
				   "File type (T=text, B=binary, M=MIME)")
			      ((#\t #\T) (make-mime-type 'TEXT 'PLAIN))
			      ((#\b #\B) (make-mime-type 'APPLICATION
							 'OCTET-STREAM))
			      ((#\m #\M) (do-mime))
			      (else (editor-beep) (loop))))))))))))
    (values mime-type
	    (if (eq? (mime-type/top-level mime-type) 'TEXT)
		(let ((charset
		       (ref-variable default-mime-text-charset buffer)))
		  (if (not charset)
		      '()
		      `((CHARSET
			 ,(if (eq? charset 'PROMPT)
			      (prompt-for-string "Charset:" "ISO-8859-1")
			      charset)))))
		'()))))

(define-variable default-mime-text-charset
  "Default charset for MIME text/plain entities, as a string.
If #F, no charset is included.
If the symbol PROMPT, prompt for a charset."
  "ISO-8859-1"
  (lambda (object)
    (or (string? object)
	(eq? object 'PROMPT)
	(eq? object #f))))

(define-variable file-type-to-mime-type
  "Specifies the MIME type/subtype for files with a given type.
This is a list, each element of which is a list of three items:
1. The file type as a string, e.g. \"jpg\".
   This can also be #F for files with no type.
2. The MIME type, one of the following symbols:
      TEXT IMAGE AUDIO VIDEO APPLICATION
3. The MIME subtype, also specified as a symbol."
  '(("scm" TEXT X-SCHEME)
    ("text" TEXT PLAIN)
    ("txi" TEXT X-TEXINFO))
  (lambda (x)
    (list-of-type? x
      (lambda (x)
	(and (list? x)
	     (= (length x) 3)
	     (or (not (car x)) (string? (car x)))
	     (any (lambda (e)
		    (eq? (cdr e) (cadr x)))
		  mime-top-level-types)
	     (symbol? (caddr x)))))))

(define mime-top-level-types
  (map (lambda (s) (cons (symbol->string s) s))
       '(TEXT IMAGE AUDIO VIDEO APPLICATION)))