;; mail sending package
;;
;; smtp -  rfc821
;;
(defpackage :net.post-office
  (:use #:lisp #:excl)
  (:export 
   #:send-letter
   #:send-smtp))

(in-package :net.post-office)

;; the exported functions:

;; (send-letter "mail-server" "from" "to" "message" &key subject reply-to)
;;  
;;    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
;;    This builds a header and inserts the optional 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 string to be concatenated together
;;    and sent as one message
;;
;;











(defmacro response-case ((ftp-stream) &rest case-clauses)
  (let ((response-class (gensym)))
    `(multiple-value-bind (,response-class ftp-response)
	 (progn (force-output ,ftp-stream)
		(wait-for-response ,ftp-stream))
       (declare (ignorable ftp-response))
       (case ,response-class
	 ,@case-clauses))))

(defvar *smtp-debug* nil)



(defun send-letter (server from to message
		    &key subject
			 reply-to)
  (let ((header (make-string-output-stream)))
    (format header "From: ~a~c~cTo: "
	    from
	    #\return
	    #\linefeed)
    (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))))
      (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed))
    
    (if* subject
       then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
    
    (if* reply-to
       then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
    
    
    (format header "~c~c" #\return #\linefeed)
    
    (send-smtp server from to (get-output-stream-string header) message)
  
  
  
    ))
    
    
	  
		    

(defun send-smtp (server from to &rest messages)
  ;; send the effective concatenation of the messages via
  ;; smtp to the mail server
  ;; Each message should be a string
  ;;
  ;; '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 (socket:make-socket :remote-host server
				  :remote-port 25  ; smtp
				  )))
    (unwind-protect
	(progn
	  (response-case (sock)
			 (2 ;; to the initial connect
			  nil)
			 (t (error "initial connect failed")))
	  
	  ;; now that we're connected we can compute our hostname
	  (let ((hostname (socket:ipaddr-to-hostname
			   (socket:local-host sock))))
	    (if* (null hostname)
	       then (format nil "[~a]" (socket:ipaddr-to-dotted
					(socket:local-host sock))))
	    (smtp-command sock "HELO ~a" hostname)
	    (response-case (sock)
			   (2 ;; ok
			    nil)
			   (t (error "hello greeting failed"))))
	    
	  (smtp-command sock "MAIL from:<~a>" from)
	  (response-case (sock)
			 (2 ;; cool
			  nil
			  )
			 (t (error "Mail from command failed")))

	  (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-command sock "RCPT to:<~a>" to)
	      (response-case (sock)
			     (2 ;; cool
			      nil
			      )
			     (t (error "rcpt to command failed")))))
	
	  (smtp-command sock "DATA")
	  (response-case (sock)
			 (3 ;; cool
			  nil)
			 (t (error "Data command failed")))
	  ;(format t "sending message~%") (force-output t)	
	  
	  
	  (let ((at-bol t))
	    (dolist (message messages)
	      (dotimes (i (length message))
		(let ((ch (aref message i)))
		  (if* (and at-bol (eq ch #\.))
		     then ; to prevent . from being interpreted as eol
			  (write-char #\. sock))
		  (if* (eq ch #\newline)
		     then (setq at-bol t)
			  (write-char #\return sock)
		     else (setq at-bol nil))
		  (write-char ch sock)))))
	
	  (write-char #\return sock) (write-char #\linefeed sock)
	  (write-char #\. sock)
	  (write-char #\return sock) (write-char #\linefeed sock)
	
	  (response-case (sock)
			 (2 nil ; (format t "Message sent to ~a~%" to)
			    )
			 
			 (t (error "message not sent")))

	  (force-output t)
	  
	  (smtp-command sock "QUIT")
	  (response-case (sock)
			 (2 ;; cool
			  nil)
			 (t (error "quit failed"))))
      (close sock))))







	
      
(defun wait-for-response (stream)
  ;; read the response of the ftp 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)))))      

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