Update of /project/cl-smtp/cvsroot/cl-smtp In directory common-lisp.net:/tmp/cvs-serv3441

Modified Files: CHANGELOG cl-smtp.asd cl-smtp.lisp Log Message: add new key authentication to send-email, send-smtp for for smtp authentication PLAIN and LOGIN, :authentication value list '(:plain "username" "password") or '(:login "username" "password")

Date: Sat Dec 10 22:00:11 2005 Author: jidzikowski

Index: cl-smtp/CHANGELOG diff -u cl-smtp/CHANGELOG:1.1.1.1 cl-smtp/CHANGELOG:1.2 --- cl-smtp/CHANGELOG:1.1.1.1 Tue Nov 1 19:34:57 2005 +++ cl-smtp/CHANGELOG Sat Dec 10 22:00:10 2005 @@ -1,3 +1,9 @@ +Version 20051210.1 +2005-12-10 +"ADD" key authentication for smtp authentication: '(:plain "username" "password") +or '(:login "username" "password") +add dependency to CL-BASE64 except allegro + Version 20050729.1 2005-07-29 "CHANGE" license from LGPL to LLGPL

Index: cl-smtp/cl-smtp.asd diff -u cl-smtp/cl-smtp.asd:1.1.1.1 cl-smtp/cl-smtp.asd:1.2 --- cl-smtp/cl-smtp.asd:1.1.1.1 Tue Nov 1 19:34:57 2005 +++ cl-smtp/cl-smtp.asd Sat Dec 10 22:00:10 2005 @@ -26,7 +26,9 @@ (in-package :cl-smtp)

(asdf:defsystem :cl-smtp - :version "20050729.1" + :version "20051210.1" + :depends-on + (#-allegro :cl-base64) :components (#+sbcl(:file "sbcl") #+allegro(:file "acl")

Index: cl-smtp/cl-smtp.lisp diff -u cl-smtp/cl-smtp.lisp:1.1.1.1 cl-smtp/cl-smtp.lisp:1.2 --- cl-smtp/cl-smtp.lisp:1.1.1.1 Tue Nov 1 19:34:57 2005 +++ cl-smtp/cl-smtp.lisp Sat Dec 10 22:00:10 2005 @@ -57,32 +57,29 @@ (mask str)) resultstr))

+(defun string-to-base64-string (str) + #+allegro (excl:string-to-base64-string str) + #-allegro (cl-base64:string-to-base64-string str)) +

(defun send-email (host from to subject message &key (port 25) cc bcc reply-to extra-headers - display-name) + display-name authentication) (send-smtp host from (check-arg to "to") subject (mask-dot message) :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc") :reply-to reply-to :extra-headers extra-headers - :display-name display-name)) + :display-name display-name + :authentication authentication))

(defun send-smtp (host from to subject message &key (port 25) cc bcc reply-to extra-headers - display-name) + display-name authentication) (let ((sock (socket-stream (make-smtp-socket host port)))) (unwind-protect (progn - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 220) - (error "wrong response from smtp server: ~A" msgstr))) - (write-to-smtp sock (format nil "HELO ~A" (get-host-name))) - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 250) - (error "wrong response from smtp server: ~A" msgstr))) + (open-smtp-connection sock :authentication authentication) (write-to-smtp sock (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) (multiple-value-bind (code msgstr) @@ -132,6 +129,55 @@ (error "in QUIT command:: ~A" msgstr)))) (close sock))))

+(defun open-smtp-connection (sock &key authentication) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 220) + (error "wrong response from smtp server: ~A" msgstr))) + (cond + (authentication + (write-to-smtp sock (format nil "EHLO ~A" (get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr))) + (cond + ((eq (car authentication) :plain) + (write-to-smtp sock (format nil "AUTH PLAIN ~A" + (string-to-base64-string + (format nil "~A~C~A~C~A" (cadr authentication) + #\null (cadr authentication) #\null + (caddr authentication))))) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 235) + (error "plain authentication failed: ~A" msgstr)))) + ((eq (car authentication) :login) + (write-to-smtp sock "AUTH LOGIN") + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 334) + (error "login authentication failed: ~A" msgstr))) + (write-to-smtp sock (string-to-base64-string (cadr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 334) + (error "login authentication send username failed: ~A" msgstr))) + (write-to-smtp sock (string-to-base64-string (caddr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 235) + (error "login authentication send password failed: ~A" msgstr)))) + (t + (error "authentication ~A is not supported in cl-smtp" + (car authentication))))) + (t + (write-to-smtp sock (format nil "HELO ~A" (get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp sock) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr)))))) +

(defun compute-rcpt-command (sock adresses) (dolist (to adresses)