smtp.cl

;; -*- mode: common-lisp; package: net.post-office -*-
;; send mail to an smtp server.
;; Originally, we used rfc821, but rfc5321/rfc5322 are now the definitive
;; resource for this code.
;;
;; See the file LICENSE for the full license governing this code.

#+(version= 10 1)
(sys:defpatch "smtp" 2
  "v2: allow SSL options to connect-to-mail-server to be changed, default to :tlsv1.2;
v1: send-letter: fold header lines per rfc5322."
  :type :system
  :post-loadable t)

(eval-when (compile eval load)
  (require :osi))

(defpackage :net.post-office
  (:use #:lisp #:excl #:excl.osi)
  (:export 
   #:send-letter
   #:send-smtp
   #:send-smtp-auth
   #:test-email-address))

(in-package :net.post-office)

(eval-when (compile load eval)
  (require :streamp)
  (require :sasl)
  (require :mime))

;; the exported functions:

;; (send-letter "mail-server" "from" "to" "message" 
;;		&key cc bcc subject reply-to headers)
;;								
;;  
;;    sends a message to the mail server (which may be a relay server
;;    or the final destination).  "from" is the address to be given
;;    as the sender.  "to" can be a string or a list of strings naming
;;    recipients.   
;;    "message" is the message to be sent.  It can be a string or a stream.
;;    cc and bcc can be either be a string or a  list of strings
;;	naming recipients.  All cc's and bcc's are sent the message
;;	but the bcc's aren't included in the header created.
;;    reply-to's value is a string and in cases a Reply-To header
;;	 to be created.
;;    headers is a string or list of stings. These are raw header lines
;;	added to the header build to send out.
;;
;;    This builds a header and inserts the optional cc, bcc, 
;;    subject and reply-to  lines.
;;
;; (send-smtp "mail-server" "from" "to" &rest messages)
;;    this is like send-letter except that it doesn't build a header.
;;    the messages should contain a header (and if not then sendmail
;;    notices this and builds one -- other MTAs may not be that smart).
;;    The messages ia  list of strings or streams to be concatenated together
;;    and sent as one message
;;
;;
;;  (test-email-address "user@machine.com")
;;    return t is this could be a valid email address on the machine
;;    named.  Do this by contacting the mail server and using the VRFY
;;    command from smtp.  Since some mail servers don't implement VRFY
;;    we return t if VRFY doesn't work.
;;    nil means that this address is bad (or we can't make contact with
;;    the mail server, which could of course be a transient problem).
;;





(defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
  ;; get a response from the smtp server and dispatch in a 'case' like
  ;; fashion to a clause based on the first digit of the return
  ;; code of the response.
  ;; smtp-response, if given, will be bound to string that is
  ;;  the actual response
  ;; 
  (let ((response-class (gensym)))
    `(multiple-value-bind (,response-class 
			   ,@(if* smtp-response then (list smtp-response))
			   ,@(if* response-code then (list response-code)))
	 (progn (force-output ,smtp-stream)
		(wait-for-response ,smtp-stream))
       ;;(declare (ignorable smtp-response))
       (case ,response-class
	 ,@case-clauses))))

(defmacro smtp-send-recv ((smtp-stream cmd smtp-response &optional response-code) &rest case-clauses)
  (let ((stream (gensym))
	(sent (gensym)))
    `(let ((,stream ,smtp-stream)
	   (,sent ,cmd))
       (if* *smtp-debug*
	  then (format *smtp-debug* "to smtp command: ~s~%" ,sent)
	       (force-output *smtp-debug*))
       (write-string ,sent ,stream)
       (write-char #\return ,stream)
       (write-char #\newline ,stream)
       (force-output ,stream)
       (macrolet ((smtp-transaction-error ()
		    (list
		     'error
		     "SMTP transaction failed.  We said: ~s, and the server replied: ~s"
		     (quote ,sent)
		     (quote ,smtp-response))))
	 
	 (response-case (,stream ,smtp-response ,response-code)
	   ,@case-clauses)))))

(defvar *smtp-debug* nil)



(defun send-letter (server from to message
		    &key cc bcc subject reply-to headers
			 login password attachments)
  ;;
  ;; see documentation at the head of this file
  ;;
  
  (if* (mime-part-constructed-p message)
     then (if* (and (not (multipart-mixed-p message)) attachments)
	     then (error "~
attachments are not allowed for non-multipart/mixed messages."))
     else (let ((part
		 (if* (streamp message)
		    then 
			 (make-mime-part :file message)
		  elseif (stringp message)
		    then (make-mime-part :text message)
		    else (error "~
message must be a string, stream, or mime-part-constructed, not ~s" message))))
	    
	    (setf message
	      (if* attachments
		 then (make-mime-part :subparts (list part))
		 else part))))
  
  (let ((hdrs nil)
	(user-headers "")
	(tos (if* (stringp to) 
		then (list to) 
	      elseif (consp to)
		then to
		else (error "to should be a string or list, not ~s" to)))
	(ccs
	 (if* (null cc)
	    then nil
	  elseif (stringp cc) 
	    then (list cc) 
	  elseif (consp cc)
	    then cc
	    else (error "cc should be a string or list, not ~s" cc)))
	(bccs (if* (null bcc)
		 then nil
	       elseif (stringp bcc) 
		 then (list bcc) 
	       elseif (consp bcc)
		 then bcc
		 else (error "bcc should be a string or list, not ~s" bcc))))
    
    (setf hdrs
      (with-output-to-string (hdrs)
	(macrolet ((already-have (name) 
		     `(mime-get-header ,name message)))
	  
	  ;; Give priority to headers already provided in a mime-part.
	  (if* (not (already-have "From"))
	     then (format hdrs "From: ~a~%" from))
	
	  (if* (not (already-have "To"))
	     then (format hdrs "To: ~a~%" (fold-addresses tos)))
	
	  (if* (and ccs (not (already-have "Cc")))
	     then (format hdrs "Cc: ~a~%" (fold-addresses ccs)))
	
	  (if* (and subject (not (already-have "Subject")))
	     then (format hdrs "Subject: ~a~%" subject))
	
	  (if* (and reply-to (not (already-have "Reply-To")))
	     then (format hdrs "Reply-To: ~a~%" reply-to)))))
    
    (if* headers
       then (if* (stringp headers)
	       then (setq headers (list headers))
	     elseif (consp headers)
	       thenret
	       else (error "Unknown headers format: ~s." headers))
	    (setf user-headers
	      (with-output-to-string (header)
		(dolist (h headers) 
		  (format header "~a~%" h)))))

    ;; Temporarily modifies 'message', which may be user-provided.
    (let ((parts-save (mime-part-parts message)))
      (if* attachments
	 then (if (not (consp attachments))
		  (setf attachments (list attachments)))
	    
	      (let (res)
		(dolist (attachment attachments)
		  (if* (mime-part-constructed-p attachment)
		     thenret
		   elseif (or (streamp attachment) (stringp attachment)
			      (pathnamep attachment))
		     then (setf attachment (make-mime-part :file attachment))
		     else (error "~
Attachments must be filenames, streams, or mime-part-constructed, not ~s"
				 attachment))
		  (push attachment res))
	      
		(setf (mime-part-parts message) (append parts-save res))))
      
      (with-mime-part-constructed-stream (s message)
	(if* (and (consp server) (eq :program (car server)))
	   then (send-external-program (cdr server) hdrs user-headers s)
	   else (send-smtp-auth server from (append tos ccs bccs)
				login password
				hdrs
				user-headers
				s)))
      
      (setf (mime-part-parts message) parts-save)
      t)))

(defun send-external-program (program &rest messages
			      &aux (external-format :default))
  (multiple-value-bind (stdout stderr exit-status)
      (command-output
       (if* (stringp program)
	  then program
	elseif (consp program)
	  then #+mswindows program
	       #-mswindows (apply #'vector (car program) program)
	  else (error "Bad program argument: ~s." program))
       :input (lambda (stream)
		(create-message stream messages external-format)))
    (when (/= 0 exit-status)
      (error "external program failed to send email (~s, ~s)."
	     stdout stderr))))

(defun create-message (output-stream messages external-format)
  (let ((at-bol t) 
	(prev-ch nil)
	ch input-stream)
    (dolist (message messages)
      (when message
	(setq input-stream
	  (if* (streamp message)
	     then message 
	     else (make-buffer-input-stream
		   (string-to-octets 
		    message 
		    :null-terminate nil
		    :external-format external-format))))

	(while (setf ch (read-byte input-stream nil))
	  (if* (and at-bol (eq ch #.(char-code #\.)))
	     then ;; to prevent . from being interpreted as eol
		  (write-char #\. output-stream))
	  (if* (eq ch #.(char-code #\newline))
	     then (setq at-bol t)
		  (if* (not (eq prev-ch #.(char-code #\return)))
		     then (write-char #\return output-stream))
	     else (setq at-bol nil))
	  (write-byte ch output-stream)
	  (setq prev-ch ch)))))
  (write-char #\return output-stream)
  (write-char #\linefeed output-stream)
  (write-char #\. output-stream)
  (write-char #\return output-stream)
  (write-char #\linefeed output-stream))

(defun send-smtp (server from to &rest messages)
  (send-smtp-1 server from to nil nil messages))
	  
(defun send-smtp-auth (server from to login password &rest messages)
  (send-smtp-1 server from to login password messages))

(defun send-smtp-1 (server from to login password messages
		    &key (external-format
			  ;; Never used, this might as well be an &aux
			  ;; variable
			  :default))
  ;; send the effective concatenation of the messages via
  ;; smtp to the mail server
  ;; Each message should be a string or a stream.
  ;;
  ;; 'to' can be a single string or a list of strings.
  ;; each string should be in the official rfc822 format  "foo@bar.com"
  ;;

  (let ((sock (connect-to-mail-server server login password)))

    (unwind-protect
	(progn
	  
	  (smtp-send-recv (sock (format nil "MAIL from:<~a>" from) msg)
	    (2 ;; cool
	     nil
	     )
	    (t (smtp-transaction-error)))
	  
	  (let ((tos (if* (stringp to) 
			then (list to) 
		      elseif (consp to)
			then to
			else (error "to should be a string or list, not ~s"
				    to))))
	    (dolist (to tos)
	      (smtp-send-recv (sock (format nil "RCPT to:<~a>" to) msg)
		(2 ;; cool
		 nil
		 )
		(t (smtp-transaction-error)))))
	
	  (smtp-send-recv (sock "DATA" msg)
	    (3 ;; cool
	     nil)
	    (t (smtp-transaction-error)))
	  
	  
	  (create-message sock messages external-format)
	  
	  (response-case (sock msg)
	    (2 nil ; (format t "Message sent to ~a~%" to)
	       )
			 
	    (t (error "message not sent: ~s" msg)))

	  (smtp-send-recv (sock "QUIT" msg)
	    (2 ;; cool
	     nil)
	    (t (smtp-transaction-error))))
      ;; Cleanup
      (close sock))))
	

(defun connect-to-mail-server (server login password)
  ;; make that initial connection to the mail server
  ;; returning a socket connected to it and 
  ;; signaling an error if it can't be made.
  
  (let ((use-port 25) ;; standard SMTP port
	ssl-args
	ssl
	starttls)
    (if* (consp server)
       then (if* (consp (cdr server))
	       then ;; long form
		    (setq ssl-args (cdr server))
		    (setf server (car server))
		    (setq ssl (getf ssl-args :ssl))
		    (remf ssl-args :ssl)
		    (setq use-port (or (getf ssl-args :port)
				       (if ssl 465 use-port)))
		    (remf ssl-args :port)
		    (setq starttls (getf ssl-args :starttls))
		    (remf ssl-args :starttls)
	       else ;; short form
		    (setf use-port (cdr server))
		    (setf server (car server)))
     elseif (stringp server)
       then (multiple-value-bind (match whole m1 m2)
		(match-re "^([^:]+):([0-9]+)$" server)
	      (declare (ignore whole))
	      (if* match
		 then (setf server m1)
		      (setf use-port (parse-integer m2)))))
    
    (let ((ipaddr (determine-mail-server server))
	  (sock)
	  (ok))
      
      (if* (null ipaddr)
	 then (error "Can't determine ip address for mail server ~s" server))
      
      (setq sock (socket:make-socket :remote-host ipaddr
				     :remote-port use-port
				     ))
      (when ssl
	(setq sock (apply #'acl-socket:make-ssl-client-stream sock ssl-args)))
      
      (unwind-protect
	  (tagbody
	    (response-case (sock msg)
			   (2 ;; to the initial connect
			    nil)
			   (t (error "initial connect failed: ~s" msg)))
	    ehlo
	    ;; now that we're connected we can compute our hostname
	    (let ((hostname (socket:ipaddr-to-hostname
			     (socket:local-host sock))))
	      (if* (null hostname)
		 then (setq hostname
			(format nil "[~a]" (socket:ipaddr-to-dotted
					    (socket:local-host sock)))))
	      (let ((mechs (smtp-ehlo sock hostname))
		    auth-mechs)
		(if* (and mechs starttls (member "STARTTLS" mechs :test #'string=))
		   then (smtp-send-recv (sock (format nil "STARTTLS") msg)
					(2 ;; ok
					 (setq sock (acl-socket:make-ssl-client-stream sock :method (getf ssl-args :method :tlsv1.2))))
					(t (smtp-transaction-error)))
			(go ehlo)
		 elseif (and mechs login password
			     (setq auth-mechs (car (member "LOGIN" mechs
						      :test #'(lambda (x y) (search x y))))))
		   then (setf sock 
			  (smtp-authenticate sock server auth-mechs login password)))))
	  
	    ;; all is good
	    (setq ok t))
      
	;; cleanup:
	(if* (null ok) 
	   then (close sock :abort t)
		(setq sock nil)))
    
      ;; return:
      sock
      )))
	    

;; Returns string with mechanisms, or nil if none.
;; This may need to be expanded in the future as we support
;; more of the features that EHLO responds with.
(defun smtp-ehlo (sock our-name)
  (smtp-send-recv (sock (format nil "EHLO ~A" our-name) msg)
    (2 ;; ok
     ;; Collect the auth mechanisms.
     (let (mechs)
       (multiple-value-bind (found whole mech)
	   (match-re "250[- ]AUTH (.*)" msg)
	 (declare (ignore whole))
	 (if found (push mech mechs)))
       (multiple-value-bind (found whole mech)
	   (match-re "250[- ](STARTTLS)" msg)
	 (declare (ignore whole))
	 (if found (push mech mechs)))
       mechs))
    (t
     (smtp-send-recv (sock (format nil "HELO ~A" our-name) msg)
       (2 ;; ok
	nil)
       (t (smtp-transaction-error))))))

(defun smtp-authenticate (sock server mechs login password)
  (let ((ctx (net.sasl:sasl-client-new "smtp" server
				       :user login
				       :pass password))
	(first-server-response t))
    (multiple-value-bind (res selected-mech response)
	(net.sasl:sasl-client-start ctx mechs)
      (if (not (eq res :continue))
	  (error "sasl-client-start unexpectedly returned: ~s" res))
      (smtp-command sock "AUTH ~a" selected-mech)
      (loop
	(response-case (sock msg)
	  (3  ;; need more interaction
	   ;; [rfe12276] Some SMTP servers (notably The Amazon SES
	   ;; SMTP endpoint (email-smtp.us-east-1.amazonaws.com))
	   ;; violate the protocol rules on the first server response.
	   ;; Apparently other SMTP clients are tolerant of this, so
	   ;; we try to be as well.
	   
	   (multiple-value-bind (decoded-server-response err)
	       (ignore-errors (base64-string-to-usb8-array (subseq msg 4)))
	     (when (null decoded-server-response)
	       (if* first-server-response
		  then ;; Ignore initial server response if it's
		       ;; bogus.
		       ;;;(warn "Bogus server initial response: ~s~%" (subseq msg 4))
		       (setf first-server-response nil)
		  else ;; We tolerate a bogus initial response, but no others
		       (error "Failed to decode server response of ~s: ~a"
			      (subseq msg 4)
			      err)))
	     
	     (multiple-value-setq (res response)
	       (net.sasl:sasl-step ctx decoded-server-response))
	     
	     (smtp-command sock "~a" 
			   (usb8-array-to-base64-string response nil))))
	  (2 ;; server is satisfied.
	   ;; Make sure the auth process really completed
	   (if (not (net.sasl:sasl-conn-auth-complete-p ctx))
	       (error "SMTP server indicated authentication complete before mechanisms was satisfied"))
	   ;; It's all good.  
	   (return)) ;; break from loop
	  (t
	   (error "SMTP authentication failed: ~a" msg)))))
    
    ;; Reach here if authentication completed.
    ;; If a security layer was negotiated, return an encapsulated sock,
    ;; otherwise just return the original sock.
    (if (net.sasl:sasl-conn-security-layer-p ctx)
	(net.sasl:sasl-make-stream ctx sock :close-base t)
      sock)))
  

  
(defun test-email-address (address)
  ;; test to see if we can determine if the address is valid
  ;; return nil if the address is bogus
  ;; return t if the address may or may not be bogus
  (if* (or (not (stringp address))
	   (zerop (length address)))
     then (error "mail address should be a non-empty string: ~s" address))
  
  ; split on the @ sign
  (let (name hostname)
    (let ((pos (position #\@ address)))
      (if* (null pos)
	 then (setq name address
		    hostname "localhost")
       elseif (or (eql pos 0)
		  (eql pos (1- (length address))))
	 then ; @ at beginning or end, bogus since we don't do route addrs
	      (return-from test-email-address nil)
	 else (setq name (subseq address 0 pos)
		    hostname (subseq address (1+ pos)))))
  
    (let ((sock (ignore-errors (connect-to-mail-server hostname nil nil))))
      (if* (null sock) then (return-from test-email-address nil))
    
      (unwind-protect
	  (progn
	    (smtp-send-recv (sock (format nil "VRFY ~a" name) msg code)
	      (5
	       (if* (eq code 550)
		  then ; no such user
		       msg ; to remove unused warning
		       nil
		  else ;; otherwise we don't know
		       (return-from test-email-address t)))
	      (t (return-from test-email-address t)))
	    (smtp-send-recv (sock (format nil "VRFY ~a" address) msg code)
	      (5
	       (if* (eq code 550)
		  then ; no such user
		       msg ; to remove unused warning
		       nil
		  else t))
	      (t t)))
	(close sock :abort t)))))
	    
	    
    
    
    
	    
	    
	    





	
      
(defun wait-for-response (stream)
  ;; read the response of the smtp server.
  ;; collect it all in a string.
  ;; Return two values:
  ;; 	response class
  ;;    whole string
  ;; The string should begin with a decimal digit, and that is converted
  ;; into a number which is returned as the response class.
  ;; If the string doesn't begin with a decimal digit then the
  ;; response class is -1.
  ;;
  (flet ((match-chars (string pos1 pos2 count)
	   ;; like strncmp
	   (dotimes (i count t)
	     (if* (not (eq (aref string (+ pos1 i))
			   (aref string (+ pos2 i))))
		then (return nil)))))

    (let ((res (make-array 20 :element-type 'character
			   :adjustable t
			   :fill-pointer 0)))
      (if* (null (read-a-line stream res))
	 then ; eof encountered before end of line
	      (return-from wait-for-response (values -1 res)))

      ;; a multi-line response begins with line containing
      ;; a hyphen in the 4th column:
      ;; xyz-  some text
      ;;
      ;;  and ends with a line containing the same reply code but no
      ;;  hyphen.
      ;; xyz  some text
      ;;

      (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
	 then ;; multi line response
	      (let ((old-length (length res))
		    (new-length nil))
		(loop
		  (if* (null (read-a-line stream res))
		     then ; eof encountered before end of line
			  (return-from wait-for-response (values -1 res)))
		  (setq new-length (length res))
		  ;; see if this is the last line
		  (if* (and (>= (- new-length old-length) 4)
			    (eq (aref res (+ old-length 3)) #\space)
			    (match-chars res 0 old-length 3))
		     then (return))

		  (setq old-length new-length))))

      ;; complete response is in res
      ;; compute class and return the whole thing
      (let ((class (or (and (> (length res) 0)
			    (digit-char-p (aref res 0)))
		       -1)))
	(values class res
		(if* (>= (length res) 3)
		   then ; compute the whole response value
			(+ (* (or (digit-char-p (aref res 0)) 0) 100)
			   (* (or (digit-char-p (aref res 1)) 0) 10)
			   (or (digit-char-p (aref res 2)) 0))))))))

(defun smtp-command (stream &rest format-args)
  ;; send a command to the smtp server
  (let ((command (apply #'format nil format-args)))
    (if* *smtp-debug*
       then (format *smtp-debug* "to smtp command: ~s~%" command)
	    (force-output *smtp-debug*))
    (write-string command stream)
    (write-char #\return stream)
    (write-char #\newline stream)
    (force-output stream)))

(defun read-a-line (stream res)
  ;; read from stream and put the result in the adjust able array res
  ;; if line ends in cr-lf, only put a newline in res.
  ;; If we get an eof before the line finishes, return nil,
  ;; else return t if all is ok
  (let (ch last-ch)
    (loop
      (setq ch (read-char stream nil nil))
      (if* (null ch)
	 then ; premature eof
	      (return nil))

      (if* *smtp-debug*
	 then (format *smtp-debug* "~c" ch)
	      (force-output *smtp-debug*)
	      )

      (if* (eq last-ch #\return)
	 then (if* (eq ch #\linefeed)
		 then (vector-push-extend #\newline res)
		      (return t)
		 else (vector-push-extend last-ch res))
       elseif (eq ch #\linefeed)
	 then ; line ends with just lf, not cr-lf
	      (vector-push-extend #\newline res)
	      (return t)
       elseif (not (eq ch #\return))
	 then (vector-push-extend ch res))

      (setq last-ch ch))))

(eval-when (compile eval)
  (defmacro ipaddrp (obj)
    #+(version>= 8 0) `(socket:ipaddrp ,obj)
    #-(version>= 8 0) `(and (integerp ,obj) (<= 0 ,obj #.(1- (expt 2 32)))))
  )

(defun determine-mail-server (name)
  ;; return the ipaddress to be used to connect to the 
  ;; the mail server.
  ;; name is any method for naming a machine:
  ;;   ip address (binary)
  ;;   string with dotted ip address
  ;;   string naming a domain
  ;; we can only do the mx lookup for the third case, the rest 
  ;; we just return the ipaddress for what we were given
  ;;
  (let (ipaddr)
    (if* (ipaddrp name)
       then name
     elseif (ipaddrp (setq ipaddr (socket:dotted-to-ipaddr name :errorp nil)))
       then ipaddr
       else ; do mx lookup if acldns is being used
	    (if* (or (eq socket:*dns-mode* :acldns)
		     (and (consp socket:*dns-mode*)
			  (member :acldns socket:*dns-mode* :test #'eq)))
	       then (let ((res (socket:dns-query name :type :mx)))
		      (if* (and (consp res) (cadr res))
			 then (cadr res) ; the ip address
			 else (dolist (suffix socket::*domain-search-list*
					(socket:dns-lookup-hostname name))
				(declare (special socket:*domain-search-list*))
				(let ((name 
				       (concatenate 'string name "." suffix)))
				  (setq res (socket:dns-query name :type :mx))
				  (if* (and res (cadr res))
				     then (return (cadr res)))))))
			      
			      
	       else ; just do a hostname lookup
		    (ignore-errors (socket:lookup-hostname name))))))

(defun fold-addresses (addresses)
  ;; Convert ADDRESSES into a string, being mindful of rfc5321
  ;; and section 4.5.3.1.6:
  ;;  Text Line
  ;;    The maximum total length of a text line including the <CRLF> is
  ;;    1000 octets (not counting the leading dot duplicated for
  ;;    transparency).  This number may be increased by the use of SMTP
  ;;    Service Extensions.
  ;; and rfc5322 section 2.1.1:
  ;;  Line Length Limits
  ;;    There are two limits that this specification places on the number
  ;;    of characters in a line.  Each line of characters MUST be no more
  ;;    than 998 characters, and SHOULD be no more than 78 characters,
  ;;    excluding the CRLF.
  ;; The latter rfc defines "unfolding" as:
  ;;  The process of moving from this folded multiple-line representation
  ;;  of a header field to its single line representation is called
  ;;  "unfolding".  Unfolding is accomplished by simply removing any CRLF
  ;;  that is immediately followed by WSP.
  ;;
  ;; So, the continued lines just need some whitespace. We will use 4
  ;; spaces after the CRLF.
  (do* ((break-at
	 ;; after this many characters on line, insert a newline
	 70)
	(spaces #.(make-string 4 :initial-element #\space))
	(addrs addresses (cdr addrs))
	(addr #1=(car addrs) #1#)
	(lastp #1=(not (cdr addrs)) #1#)
	(buf (make-string-output-stream :element-type 'character))
	(lines '()))
      ((null addrs)
       (when (> (file-position buf) 0)
	 (push (get-output-stream-string buf) lines))
       (apply #'concatenate 'simple-string (nreverse lines)))
    (princ addr buf)
    (when (not lastp)
      (princ "," buf)
      (write-char #\space buf)
      (when (>= (file-position buf) break-at)
        (push (get-output-stream-string buf) lines)
	(fresh-line buf)
	(write-string spaces buf)))))


(provide :smtp)