Changeset 2784

Show
Ignore:
Timestamp:
03/23/08 15:19:51 (8 months ago)
Author:
hans
Message:

More CL-SMTP refactoring. Add new API WITH-SMTP-MAIL that can be used to send
preformatted messages (with headers)

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/thirdparty/cl-smtp/README

    r2782 r2784  
    2626  - host (String)                  : hostname or ip-adress of the smtpserver 
    2727  - from (String)                  : email adress  
    28   - to (String or Cons of Strings) : email adress  
     28  - to (String or List of Strings) : email adress  
    2929  - subject (String)               : subject text 
    3030  - message (String)               : message body 
    3131  keywords: 
    32   - cc (String or Cons of Strings) : email adress carbon copy 
    33   - bcc (String or Cons of Strings): email adress blind carbon copy 
     32  - cc (String or List of Strings) : email adress carbon copy 
     33  - bcc (String or List of Strings): email adress blind carbon copy 
    3434  - reply-to (String)              : email adress 
    3535  - displayname (String)           : displayname of the sender 
    36   - extra-headers (Cons)           : extra headers as alist 
     36  - extra-headers (List)           : extra headers as alist 
    3737  - html-message (String)          : message body formatted with HTML tags 
    38   - authentication (Cons)          : list with 3 elements 
    39                                      (:method "username" "password") 
     38  - authentication (List)          : list with 2 or elements 
     39                                     ([:method] "username" "password") 
    4040                                     method is a keyword :plain or :login 
     41                                     If the method is not specified, the 
     42                                     proper method is determined automatically. 
    4143  - attachments (String or Pathname: attachments to send 
    42                 Cons of String/Pathnames) 
     44                List of String/Pathnames) 
    4345  - buffer-size (Number default 256): controls how much of a attachment file 
    4446                                      is read on each loop before encoding  
    4547                                      and transmitting the contents,  
    4648                                      the number is interpretted in KB  
    47   - ssl (Boolean)                   : if true than use the STARTTLS functionality to make a ssl connection 
     49  - ssl (Boolean)                   : if true than use the STARTTLS functionality 
     50                                      to make a ssl connection 
    4851 
    4952Returns nil or error with message 

  • trunk/thirdparty/cl-smtp/cl-smtp.asd

    r2782 r2784  
    1818 
    1919(defpackage :cl-smtp 
    20         (:use :cl :asdf) 
    21         (:export :send-email)) 
     20  (:use :cl :asdf) 
     21  (:export "SEND-EMAIL" 
     22           "WITH-SMTP-MAIL" 
     23 
     24           "SMTP-ERROR" 
     25           "SMTP-PROTOCOL-ERROR" 
     26           "NO-SUPPORTED-AUTHENTICATION-METHOD" 
     27           "RCPT-FAILED" 
     28           "IGNORE-RECIPIENT")) 
    2229 
    2330(in-package :cl-smtp) 
    …… 
    3037 
    3138(asdf:defsystem :cl-smtp 
    32        :version "20071113.1" 
    33        :perform (load-op :after (op webpage) 
    34                          (pushnew :cl-smtp cl:*features*)) 
    35        :depends-on (:usocket #-allegro :cl-base64  
    36                              #-allegro :flexi-streams 
    37                              #-allegro :cl+ssl) 
    38        :components ((:file "cl-smtp" :depends-on ("attachments")) 
    39                     (:file "attachments") 
    40                     (:file "mime-types"))) 
     39  :version "20071113.1" 
     40  :perform (load-op :after (op webpage) 
     41                    (pushnew :cl-smtp cl:*features*)) 
     42  :depends-on (:usocket #-allegro :cl-base64  
     43                        #-allegro :flexi-streams 
     44                        #-allegro :cl+ssl) 
     45  :components ((:file "cl-smtp" :depends-on ("attachments")) 
     46               (:file "attachments") 
     47               (:file "mime-types"))) 

  • trunk/thirdparty/cl-smtp/cl-smtp.lisp

    r2783 r2784  
    3535    (error "the \"~A\" argument is not a string or cons" name)))) 
    3636 
     37(eval-when (:compile-toplevel :load-toplevel :execute) 
     38  (defvar *line-with-one-dot* #.(format nil "~C~C.~C~C" #\Return #\NewLine 
     39                                        #\Return #\NewLine)) 
     40  (defvar *line-with-two-dots* #.(format nil "~C~C..~C~C" #\Return #\NewLine 
     41                                         #\Return #\NewLine))) 
     42 
    3743(defun mask-dot (str) 
    38   "replace \r\n.\r\n with \r\n..\r\n" 
    39   (let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine 
    40                         #\Return #\NewLine)) 
    41         (maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine 
    42                         #\Return #\NewLine)) 
    43         (resultstr "")) 
     44  "Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n" 
     45  (let ((resultstr "")) 
    4446    (labels ((mask (tempstr) 
    45                (let ((n (search dotstr tempstr))) 
     47               (let ((n (search *line-with-one-dot* tempstr))) 
    4648                 (cond 
    4749                  (n 
    4850                   (setf resultstr (concatenate 'string resultstr  
    4951                                                (subseq tempstr 0 n) 
    50                                                 maskdotsr)) 
    51                    (mask (subseq tempstr (+ n 5)))) 
     52                                                *line-with-two-dots*)) 
     53                   (mask (subseq tempstr (+ n #.(length *line-with-one-dot*))))) 
    5254                  (t 
    5355                   (setf resultstr (concatenate 'string resultstr  
    …… 
    6264 
    6365(define-condition smtp-error (error) 
    64   ((host :initarg :host :reader host))) 
     66  ()) 
    6567 
    6668(define-condition smtp-protocol-error (smtp-error) 
    …… 
    7173  (:report (lambda (condition stream) 
    7274             (print-unreadable-object (condition stream :type t) 
    73                (format stream "while talking to smtp server ~A, a command failed:~%command: ~S expected: ~A response: ~A" 
    74                        (host condition) 
     75               (format stream "a command failed:~%command: ~S expected: ~A response: ~A" 
    7576                       (command condition) 
    7677                       (expected-response-code condition) 
    7778                       (response-message condition)))))) 
    7879 
    79 (defun smtp-command (stream command expected-response-code &optional (condition-class 'smtp-protocol-error)) 
     80(define-condition rcpt-failed (smtp-protocol-error) 
     81  ((recipient :initarg :recipient 
     82              :reader recipient)) 
     83  (:report (lambda (condition stream) 
     84             (print-unreadable-object (condition stream :type t) 
     85               (format stream "while trying to send email through SMTP, the server rejected the recipient ~A: ~A" 
     86                       (recipient condition) 
     87                       (response-message condition)))))) 
     88 
     89(defun smtp-command (stream command expected-response-code 
     90                     &key (condition-class 'smtp-error) condition-arguments) 
    8091  (when command 
    8192    (write-to-smtp stream command)) 
    …… 
    8394      (read-from-smtp stream) 
    8495    (when (/= code expected-response-code) 
    85       (error condition-class 
    86              :command command 
    87              :expected-response-code expected-response-code 
    88              :response-code code 
    89              :response-message msgstr)) 
     96      (apply #'error 
     97             condition-class 
     98             (append condition-arguments 
     99                     (list :command command 
     100                           :expected-response-code expected-response-code 
     101                           :response-code code 
     102                           :response-message msgstr)))) 
    90103    lines)) 
     104 
     105(defun do-with-smtp-mail (host port from to thunk &key authentication ssl local-hostname) 
     106  (usocket:with-client-socket (socket stream host port) 
     107    (let ((stream (smtp-handshake stream 
     108                                  :authentication authentication  
     109                                  :ssl ssl 
     110                                  :local-hostname local-hostname))) 
     111      (initiate-smtp-mail stream from to) 
     112      (funcall thunk stream) 
     113      (finish-smtp-mail stream)))) 
     114 
     115(defmacro with-smtp-mail ((stream-var host port from to &key authentication ssl local-hostname) 
     116                          &body body) 
     117  "Encapsulate a SMTP MAIl conversation.  A connection to the SMTP 
     118   server on HOST and PORT is established and a MAIL command is 
     119   initiated with FROM being the mail sender and TO being the list of 
     120   recipients.  BODY is evaluated with STREAM-VAR being the stream 
     121   connected to the remote SMTP server.  BODY is expected to write the 
     122   RFC2821 message (headers and body) to STREAM-VAR." 
     123  `(do-with-smtp-mail ,host ,port ,from ,to 
     124                      (lambda (,stream-var) ,@body) 
     125                      :authentication ,authentication  
     126                      :ssl ,ssl 
     127                      :local-hostname ,local-hostname)) 
    91128 
    92129(defun send-email (host from to subject message  
    …… 
    111148                  display-name authentication attachments buffer-size ssl 
    112149                  (local-hostname (usocket::get-host-name))) 
    113   (let* ((sock (usocket:socket-stream (usocket:socket-connect host port))) 
    114          (boundary (make-random-boundary)) 
    115          (html-boundary (if (and attachments html-message) 
    116                             (make-random-boundary) 
    117                             boundary))) 
    118     (unwind-protect 
    119          (let ((stream (open-smtp-connection sock  
    120                                              :authentication authentication  
    121                                              :ssl ssl 
    122                                              :local-hostname local-hostname))) 
    123            (send-smtp-headers stream :from from :to to :cc cc :bcc bcc  
    124                               :reply-to reply-to 
    125                               :display-name display-name  
    126                               :extra-headers extra-headers :subject subject) 
    127            (when (or attachments html-message) 
    128              (send-multipart-headers  
    129               stream :attachment-boundary (when attachments boundary)  
    130               :html-boundary html-boundary)) 
    131            ;;----------- Send  the body Message --------------------------- 
    132            ;;--- Send the proper headers depending on plain-text,  
    133            ;;--- multi-part or html email  
    134            (cond ((and attachments html-message) 
    135                   ;; if both present, start attachment section,  
    136                   ;; then define alternative section,  
    137                   ;; then write alternative header 
    138                   (progn  
    139                     (generate-message-header  
    140                      stream :boundary boundary :include-blank-line? nil) 
    141                     (generate-multipart-header stream html-boundary  
    142                                                :multipart-type "alternative") 
    143                     (write-blank-line stream) 
    144                     (generate-message-header  
    145                      stream :boundary html-boundary :content-type *content-type*  
    146                      :content-disposition "inline" :include-blank-line? nil))) 
    147                  (attachments  
    148                   (generate-message-header  
    149                    stream :boundary boundary  
    150                    :content-type *content-type* :content-disposition "inline" 
    151                    :include-blank-line? nil)) 
    152                  (html-message 
    153                   (generate-message-header  
    154                    stream :boundary html-boundary :content-type *content-type*  
    155                    :content-disposition "inline")) 
    156                  (t  
    157                   (generate-message-header stream :content-type *content-type* 
    158                                            :include-blank-line? nil))) 
    159            (write-blank-line stream) 
    160            (write-to-smtp stream message) 
    161            (write-blank-line stream) 
    162            ;;---------- Send  Html text if needed ------------------------- 
    163            (when html-message 
    164              (generate-message-header  
    165               stream :boundary html-boundary  
    166               :content-type "text/html; charset=ISO-8859-1"  
    167               :content-disposition "inline") 
    168              (write-to-smtp stream html-message) 
    169              (send-end-marker stream html-boundary)) 
    170            ;;---------- Send Attachments ----------------------------------- 
    171            (when attachments 
    172              (dolist (attachment attachments) 
    173                (send-attachment stream attachment boundary buffer-size)) 
    174              (send-end-marker stream boundary)) 
    175            (smtp-command stream "." 250) 
    176            (smtp-command stream "QUIT" 221))       
    177       (close sock)))) 
    178  
    179 (defun open-smtp-connection (stream &key authentication ssl local-hostname) 
     150  (with-smtp-mail (stream host port from (append to cc bcc) 
     151                          :authentication authentication  
     152                          :ssl ssl 
     153                          :local-hostname local-hostname) 
     154    (let* ((boundary (make-random-boundary)) 
     155           (html-boundary (if (and attachments html-message) 
     156                              (make-random-boundary) 
     157                              boundary))) 
     158      (send-mail-headers stream 
     159                         :from from 
     160                         :to to 
     161                         :cc cc 
     162                         :reply-to reply-to 
     163                         :display-name display-name  
     164                         :extra-headers extra-headers :subject subject) 
     165      (when (or attachments html-message) 
     166        (send-multipart-headers stream 
     167                                :attachment-boundary (when attachments boundary)  
     168                                :html-boundary html-boundary)) 
     169      ;;----------- Send  the body Message --------------------------- 
     170      ;;--- Send the proper headers depending on plain-text,  
     171      ;;--- multi-part or html email  
     172      (cond ((and attachments html-message) 
     173             ;; if both present, start attachment section,  
     174             ;; then define alternative section,  
     175             ;; then write alternative header 
     176             (progn  
     177               (generate-message-header  
     178                stream :boundary boundary :include-blank-line? nil) 
     179               (generate-multipart-header stream html-boundary  
     180                                          :multipart-type "alternative") 
     181               (write-blank-line stream) 
     182               (generate-message-header  
     183                stream :boundary html-boundary :content-type *content-type*  
     184                :content-disposition "inline" :include-blank-line? nil))) 
     185            (attachments  
     186             (generate-message-header  
     187              stream :boundary boundary  
     188              :content-type *content-type* :content-disposition "inline" 
     189              :include-blank-line? nil)) 
     190            (html-message 
     191             (generate-message-header  
     192              stream :boundary html-boundary :content-type *content-type*  
     193              :content-disposition "inline")) 
     194            (t  
     195             (generate-message-header stream :content-type *content-type* 
     196                                      :include-blank-line? nil))) 
     197      (write-blank-line stream) 
     198      (write-to-smtp stream message) 
     199      (write-blank-line stream) 
     200      ;;---------- Send  Html text if needed ------------------------- 
     201      (when html-message 
     202        (generate-message-header  
     203         stream :boundary html-boundary  
     204         :content-type "text/html; charset=ISO-8859-1"  
     205         :content-disposition "inline") 
     206        (write-to-smtp stream html-message) 
     207        (send-end-marker stream html-boundary)) 
     208      ;;---------- Send Attachments ----------------------------------- 
     209      (when attachments 
     210        (dolist (attachment attachments) 
     211          (send-attachment stream attachment boundary buffer-size)) 
     212        (send-end-marker stream boundary))))) 
     213 
     214(define-condition no-supported-authentication-method (smtp-error) 
     215  ((features :initarg :features :reader features)) 
     216  (:report (lambda (condition stream) 
     217             (print-unreadable-object (condition stream :type t) 
     218               (format stream "SMTP authentication has been requested, but the SMTP server did not advertise any ~ 
     219                               supported authentication scheme.  Features announced: ~{~S~^, ~}" 
     220                       (features condition)))))) 
     221 
     222(defun smtp-authenticate (stream authentication features) 
     223  "Authenticate to the SMTP server connected on STREAM. 
     224   AUTHENTICATION is a list of two or three elements.  If the first 
     225   element is a keyword, it specifies the desired authentication 
     226   method (:PLAIN or :LOGIN), which is currently ignored.  The actual 
     227   method used is determined by looking at the advertised features of 
     228   the SMTP server.  The (other) two elements of the AUTHENTICATION 
     229   list are the login username and password.  FEATURES is the list of 
     230   features announced by the SMTP server. 
     231 
     232   If the server does not announce any compatible authentication scheme, 
     233   the NO-SUPPORTED-AUTHENTICATION-METHOD error is signalled." 
     234  (when (keywordp (car authentication)) 
     235    (pop authentication)) 
     236  (destructuring-bind (username password) authentication 
     237    (cond 
     238      ((member "AUTH PLAIN" features :test #'equal) 
     239       (smtp-command stream (format nil "AUTH PLAIN ~A"  
     240                                    (string-to-base64-string 
     241                                     (format nil "~A~C~A~C~A"  
     242                                             username 
     243                                             #\null username 
     244                                             #\null password))) 
     245                     235)) 
     246      ((member "AUTH LOGIN" features :test #'equal) 
     247       (smtp-command stream "AUTH LOGIN" 
     248                     334) 
     249       (smtp-command stream (string-to-base64-string username) 
     250                     334) 
     251       (smtp-command stream (string-to-base64-string password) 
     252                     235)) 
     253      (t 
     254       (error 'no-supported-authentication-method :features features))))) 
     255 
     256(defun smtp-handshake (stream &key authentication ssl local-hostname) 
     257  "Perform the initial SMTP handshake on STREAM.  Returns the stream 
     258   to use further down in the conversation, which may be different from 
     259   the original stream if we switched to SSL." 
     260 
     261  ;; Read the initial greeting from the SMTP server 
    180262  (smtp-command stream nil 
    181263                220) 
    182   (if (or ssl authentication) 
    183       ;; When SSL or authentication requested, perform ESMTP EHLO 
    184       (let ((lines (smtp-command stream (format nil "EHLO ~A" local-hostname) 
    185                                  250))) 
    186         (when ssl 
    187           (unless (find "STARTTLS" lines :test #'equal) 
    188             (error "this server does not supports TLS")) 
    189           (print-debug "this server supports TLS") 
    190           (smtp-command stream "STARTTLS" 
    191                         220) 
    192           (setf stream  
    193                 #+allegro (socket:make-ssl-client-stream stream) 
    194                 #-allegro 
    195                 (let ((s stream)) 
    196                   (cl+ssl:make-ssl-client-stream  
    197                    (cl+ssl:stream-fd stream) 
    198                    :close-callback (lambda () (close s))))) 
    199           #-allegro 
    200           (setf stream (flexi-streams:make-flexi-stream  
    201                         stream 
    202                         :external-format  
    203                         (flexi-streams:make-external-format  
    204                          :latin-1 :eol-style :lf)))) 
    205         (when authentication 
    206           (ecase (car authentication) 
    207             (:plain 
    208              (smtp-command stream (format nil "AUTH PLAIN ~A"  
    209                                           (string-to-base64-string 
    210                                            (format nil "~A~C~A~C~A"  
    211                                                    (cadr authentication) 
    212                                                    #\null (cadr authentication)  
    213                                                    #\null 
    214                                                    (caddr authentication)))) 
    215                            235)) 
    216             (:login 
    217              (smtp-command stream "AUTH LOGIN" 
    218                            334) 
    219              (smtp-command stream (string-to-base64-string (cadr authentication)) 
    220                            334) 
    221              (smtp-command stream (string-to-base64-string (caddr authentication)) 
    222                            235)) 
    223             (t 
    224              (smtp-command stream (format nil "HELO ~A" local-hostname) 
    225                            250))))) 
    226       ;; No authentication or SSL requested, perform classic SMTP HELO 
    227       (smtp-command stream (format nil "HELO ~A"  
     264 
     265  (unless (or ssl authentication) 
     266    ;; Unless we want ESMTP features, perform classic SMTP handshake and return 
     267    (smtp-command stream (format nil "HELO ~A"  
    228268                                   (usocket::get-host-name)) 
    229                     250)) 
     269                  250) 
     270    (return-from smtp-handshake stream)) 
     271 
     272  ;; When SSL or authentication requested, perform ESMTP EHLO 
     273  (let (features) 
     274    (labels 
     275        ((do-ehlo () 
     276           (setf features (rest (smtp-command stream (format nil "EHLO ~A" local-hostname) 
     277                                              250)))) 
     278         (convert-connection-to-ssl () 
     279           (setf stream  
     280                 #+allegro (socket:make-ssl-client-stream stream) 
     281                 #-allegro 
     282                 (let ((s stream)) 
     283                   (cl+ssl:make-ssl-client-stream  
     284                    (cl+ssl:stream-fd stream) 
     285                    :close-callback (lambda () (close s))))) 
     286           #-allegro 
     287           (setf stream (flexi-streams:make-flexi-stream  
     288                         stream 
     289                         :external-format  
     290                         (flexi-streams:make-external-format  
     291                          :latin-1 :eol-style :lf))))) 
     292      (ecase ssl 
     293        ((or t :starttls) 
     294         (do-ehlo) 
     295         (unless (find "STARTTLS" features :test #'equal) 
     296           (error "this server does not supports TLS")) 
     297         (print-debug "this server supports TLS") 
     298         (smtp-command stream "STARTTLS" 
     299                       220) 
     300         (convert-connection-to-ssl) 
     301         ;; After STARTTLS, the connection is "like new".  Re-do the 
     302         ;; EHLO command to switch the server to ESMTP mode and read 
     303         ;; the list of announced features again. 
     304         (do-ehlo)) 
     305        (:tls 
     306         ;; Plain SSL connection 
     307         (convert-connection-to-ssl) 
     308         (do-ehlo)))) 
     309    (when authentication 
     310      (smtp-authenticate stream authentication features))) 
    230311  stream) 
    231312   
    232 (defun send-smtp-headers (stream  
    233                           &key from to  cc bcc reply-to  
     313(defun initiate-smtp-mail (stream from to) 
     314  "Initiate an SMTP MAIL command, sending a MAIL FROM command for the 
     315   email address in FROM and RCPT commands for all receipients in TO, 
     316   which is expected to be a list. 
     317 
     318   If any of the TO addresses is not accepted, a RCPT-FAILED condition 
     319   is signalled.  This condition may be handled by the caller in order 
     320   to send the email anyway." 
     321  (smtp-command stream  
     322                (format nil "MAIL FROM:<~A>" from) 
     323                250) 
     324  (dolist (address to) 
     325    (restart-case  
     326        (smtp-command stream (format nil "RCPT TO:<~A>" address) 
     327                      250 
     328                      :condition-class 'rcpt-failed 
     329                      :condition-arguments (list :recipient address)) 
     330      (ignore-recipient ()))) 
     331  (smtp-command stream "DATA" 
     332                354)) 
     333 
     334(defun finish-smtp-mail (stream) 
     335  "Finish sending an email to the SMTP server connected to on STREAM. 
     336   The server is expected to be inside of the DATA SMTP command.  The 
     337   connection is then terminated by sending a QUIT command." 
     338  (smtp-command stream "." 250) 
     339  (smtp-command stream "QUIT" 221)) 
     340 
     341(defun send-mail-headers (stream  
     342                          &key from to cc reply-to  
    234343                          extra-headers display-name subject) 
    235   (smtp-command stream  
    236                 (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from) 
    237                 250) 
    238   (compute-rcpt-command stream to) 
    239   (compute-rcpt-command stream cc) 
    240   (compute-rcpt-command stream bcc) 
    241   (smtp-command stream "DATA" 
    242                 354) 
     344  "Send email headers according to the given arguments to the SMTP 
     345   server connected to on STREAM.  The server is expected to have 
     346   previously accepted the DATA SMTP command." 
    243347  (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) 
    244348  (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]"  
    …… 
    268372        (t nil))) 
    269373 
    270 (defun compute-rcpt-command (stream adresses) 
    271   (dolist (to adresses) 
    272     (smtp-command stream (format nil "RCPT TO:<~A>" to) 
    273                   250))) 
    274  
    275374(defun write-to-smtp (stream command) 
    276375  (print-debug (format nil "to server: ~A" command))  
    …… 
    308407        (hour (/ x 3600))) 
    309408    (if (integerp hour) 
    310         (cond 
     409        (cond 
    311410          ((>= hour 0) 
    312411           (format nil "+~2,'0d00" hour)) 
    313412          ((< hour 0) 
    314           (format nil "-~2,'0d00" (* -1 hour)))) 
    315       (multiple-value-bind (h m) (truncate min 60) 
    316        (cond 
     413          (format nil "-~2,'0d00" (* -1 hour)))) 
     414        (multiple-value-bind (h m) (truncate min 60) 
     415          (cond 
    317416          ((>= hour 0) 
    318417           (format nil "+~2,'0d~2,'0d" h (truncate m)))