Changeset 2783

Show
Ignore:
Timestamp:
03/23/08 00:03:45 (8 months ago)
Author:
hans
Message:

refactor in preparation for upcoming extension

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r2782 r2783  
    6161  #-allegro (cl-base64:string-to-base64-string str)) 
    6262 
     63(define-condition smtp-error (error) 
     64  ((host :initarg :host :reader host))) 
     65 
     66(define-condition smtp-protocol-error (smtp-error) 
     67  ((command :initarg :command :reader command) 
     68   (expected-response-code :initarg :expected-response-code :reader expected-response-code) 
     69   (response-code :initarg :response-code :reader response-code) 
     70   (response-message :initarg :response-message :reader response-message)) 
     71  (:report (lambda (condition stream) 
     72             (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                       (command condition) 
     76                       (expected-response-code condition) 
     77                       (response-message condition)))))) 
     78 
     79(defun smtp-command (stream command expected-response-code &optional (condition-class 'smtp-protocol-error)) 
     80  (when command 
     81    (write-to-smtp stream command)) 
     82  (multiple-value-bind (code msgstr lines) 
     83      (read-from-smtp stream) 
     84    (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)) 
     90    lines)) 
    6391 
    6492(defun send-email (host from to subject message  
    …… 
    79107             :ssl ssl)) 
    80108 
    81  
    82109(defun send-smtp (host from to subject message  
    83110                  &key (port 25) cc bcc reply-to extra-headers html-message  
    84                   display-name authentication attachments buffer-size ssl) 
     111                  display-name authentication attachments buffer-size ssl 
     112                  (local-hostname (usocket::get-host-name))) 
    85113  (let* ((sock (usocket:socket-stream (usocket:socket-connect host port))) 
    86114         (boundary (make-random-boundary)) 
    …… 
    91119         (let ((stream (open-smtp-connection sock  
    92120                                             :authentication authentication  
    93                                              :ssl ssl))) 
     121                                             :ssl ssl 
     122                                             :local-hostname local-hostname))) 
    94123           (send-smtp-headers stream :from from :to to :cc cc :bcc bcc  
    95124                              :reply-to reply-to 
    …… 
    144173               (send-attachment stream attachment boundary buffer-size)) 
    145174             (send-end-marker stream boundary)) 
    146            (write-char #\. stream) 
    147            (write-blank-line stream) 
    148            (force-output stream) 
    149            (multiple-value-bind (code msgstr) 
    150                (read-from-smtp stream) 
    151              (when (/= code 250) 
    152                (error "Message send failed: ~A" msgstr))) 
    153            (write-to-smtp stream "QUIT") 
    154            (multiple-value-bind (code msgstr) 
    155                (read-from-smtp stream) 
    156              (when (/= code 221) 
    157                (error "in QUIT command:: ~A" msgstr))))       
     175           (smtp-command stream "." 250) 
     176           (smtp-command stream "QUIT" 221))       
    158177      (close sock)))) 
    159178 
    160 (defun open-smtp-connection (stream &key authentication ssl) 
    161   (multiple-value-bind (code msgstr) 
    162       (read-from-smtp stream) 
    163     (when (/= code 220) 
    164       (error "wrong response from smtp server: ~A" msgstr))) 
    165   (when ssl 
    166     (write-to-smtp stream (format nil "EHLO ~A"  
    167                                   (usocket::get-host-name))) 
    168     (multiple-value-bind (code msgstr lines) 
    169         (read-from-smtp stream) 
    170       (when (/= code 250) 
    171         (error "wrong response from smtp server: ~A" msgstr)) 
    172       (when ssl 
    173         (cond 
    174           ((find "STARTTLS" lines :test #'equal) 
    175            (print-debug "this server supports TLS") 
    176            (write-to-smtp stream "STARTTLS") 
    177            (multiple-value-bind (code msgstr) 
    178                (read-from-smtp stream) 
    179              (when (/= code 220) 
    180                (error "Unable to start TLS: ~A" msgstr)) 
    181              (setf stream  
    182                    #+allegro (socket:make-ssl-client-stream stream) 
    183                    #-allegro 
    184                    (let ((s stream)) 
    185                      (cl+ssl:make-ssl-client-stream  
    186                       (cl+ssl:stream-fd stream) 
    187                       :close-callback (lambda () (close s))))) 
    188              #-allegro 
    189              (setf stream (flexi-streams:make-flexi-stream  
    190                            stream 
    191                            :external-format  
    192                            (flexi-streams:make-external-format  
    193                             :latin-1 :eol-style :lf))))) 
    194           (t 
    195            (error "this server does not supports TLS")))))) 
    196   (cond 
    197     (authentication 
    198      (write-to-smtp stream (format nil "EHLO ~A"  
    199                                    (usocket::get-host-name))) 
    200      (multiple-value-bind (code msgstr) 
    201          (read-from-smtp stream) 
    202        (when (/= code 250) 
    203          (error "wrong response from smtp server: ~A" msgstr))) 
    204      (cond 
    205        ((eq (car authentication) :plain) 
    206         (write-to-smtp stream (format nil "AUTH PLAIN ~A"  
    207                                       (string-to-base64-string 
    208                                        (format nil "~A~C~A~C~A"  
    209                                                (cadr authentication) 
    210                                                #\null (cadr authentication)  
    211                                                #\null 
    212                                                (caddr authentication))))) 
    213         (multiple-value-bind (code msgstr) 
    214             (read-from-smtp stream) 
    215           (when (/= code 235) 
    216             (error "plain authentication failed: ~A" msgstr)))) 
    217        ((eq (car authentication) :login) 
    218         (write-to-smtp stream "AUTH LOGIN") 
    219         (multiple-value-bind (code msgstr) 
    220             (read-from-smtp stream) 
    221           (when (/= code 334) 
    222             (error "login authentication failed: ~A" msgstr))) 
    223         (write-to-smtp stream (string-to-base64-string (cadr authentication))) 
    224         (multiple-value-bind (code msgstr) 
    225             (read-from-smtp stream) 
    226           (when (/= code 334) 
    227             (error "login authentication send username failed: ~A" msgstr))) 
    228         (write-to-smtp stream (string-to-base64-string (caddr authentication))) 
    229         (multiple-value-bind (code msgstr) 
    230             (read-from-smtp stream) 
    231           (when (/= code 235) 
    232             (error "login authentication send password failed: ~A" msgstr)))) 
    233        (t 
    234         (error "authentication ~A is not supported in cl-smtp"  
    235                (car authentication))))) 
    236     (t 
    237      (write-to-smtp stream (format nil "HELO ~A" (usocket::get-host-name))) 
    238      (multiple-value-bind (code msgstr) 
    239          (read-from-smtp stream) 
    240        (when (/= code 250) 
    241          (error "wrong response from smtp server: ~A" msgstr))))) 
     179(defun open-smtp-connection (stream &key authentication ssl local-hostname) 
     180  (smtp-command stream nil 
     181                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"  
     228                                   (usocket::get-host-name)) 
     229                    250)) 
    242230  stream) 
    243231   
    …… 
    245233                          &key from to  cc bcc reply-to  
    246234                          extra-headers display-name subject) 
    247   (write-to-smtp stream  
    248                  (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) 
    249   (multiple-value-bind (code msgstr) 
    250       (read-from-smtp stream) 
    251     (when (/= code 250) 
    252       (error "in MAIL FROM command: ~A" msgstr))) 
     235  (smtp-command stream  
     236                (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from) 
     237                250) 
    253238  (compute-rcpt-command stream to) 
    254239  (compute-rcpt-command stream cc) 
    255240  (compute-rcpt-command stream bcc) 
    256   (write-to-smtp stream "DATA") 
    257   (multiple-value-bind (code msgstr) 
    258       (read-from-smtp stream) 
    259     (when (/= code 354) 
    260       (error "in DATA command: ~A" msgstr))) 
     241  (smtp-command stream "DATA" 
     242                354) 
    261243  (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) 
    262244  (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]"  
    …… 
    288270(defun compute-rcpt-command (stream adresses) 
    289271  (dolist (to adresses) 
    290     (write-to-smtp stream (format nil "RCPT TO:<~A>" to)) 
    291     (multiple-value-bind (code msgstr) 
    292         (read-from-smtp stream) 
    293       (when (/= code 250)        
    294         (error "in RCPT TO command: ~A" msgstr))))) 
     272    (smtp-command stream (format nil "RCPT TO:<~A>" to) 
     273                  250))) 
    295274 
    296275(defun write-to-smtp (stream command) 
    …… 
    313292    (if (= (char-code (elt line 3)) (char-code #\-)) 
    314293        (read-from-smtp stream (append lines (list response))) 
    315         (values response-code line lines)))) 
     294        (values response-code response lines)))) 
    316295 
    317296(defun get-email-date-string ()