[cl-smtp-cvs] CVS update: cl-smtp/CHANGELOG cl-smtp/cl-smtp.asd cl-smtp/cl-smtp.lisp

[Jan Idzikowski]

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)