;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; smtp.cl
;;
;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA  - All rights reserved.
;; copyright (c) 2002-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; This code 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
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA  02111-1307  USA
;;
;;
;; $Id: smtp.cl,v 1.24 2008/09/16 23:22:14 layer Exp $

;; Description:
;;   send mail to an smtp server.  See rfc821 for the spec.

;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-


(defpackage :net.post-office
  (:use #:cl #:excl)
  (: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~%" (list-to-delimited-string tos ", ")))

          (if* (and ccs (not (already-have "Cc")))
             then (format hdrs "Cc: ~a~%" (list-to-delimited-string 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)
        (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-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 :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)))



          (let ((at-bol t)
                (prev-ch nil)
                ch stream)
            (dolist (message messages)
              (when message
                (setf 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 stream nil))
                  (if* (and at-bol (eq ch #.(char-code #\.)))
                     then ;; to prevent . from being interpreted as eol
                          (write-char #\. sock))
                  (if* (eq ch #.(char-code #\newline))
                     then (setq at-bol t)
                          (if* (not (eq prev-ch #.(char-code #\return)))
                             then (write-char #\return sock))
                     else (setq at-bol nil))
                  (write-byte ch sock)
                  (setq prev-ch ch)))))

          (write-char #\return sock) (write-char #\linefeed sock)
          (write-char #\. sock)
          (write-char #\return sock) (write-char #\linefeed sock)

          (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 :tlsv1)))
                                        (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)))
    (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
           (multiple-value-setq (res response)
             (net.sasl:sasl-step
              ctx
              (base64-string-to-usb8-array (subseq msg 4))))
           (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))))))



(provide :smtp)