1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; client-authentication.lisp --- SMTP authentication.
5 ;;; Copyright (C) 2007-2008, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :net.smtp-client
)
26 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 (defvar *smtp-authenticators
* (make-hash-table :test
#'eq
)))
29 (defun invoke-authentication (name args
)
30 (check-type args cons
)
31 (let ((auth-fun (gethash name
*smtp-authenticators
*)))
33 (funcall auth-fun args
)
34 (error "Unknown authentication method: ~A" name
))))
36 (defmacro defauthentication
(name (socket args
) &body body
)
37 `(setf (gethash ,name
*smtp-authenticators
*)
38 #'(lambda (,socket
,args
)
41 (defauthentication :plain
(sock args
)
42 (format-socket sock
"AUTH PLAIN ~A"
43 (string-to-base64-string
44 (format nil
"~A~C~A~C~A" (first args
)
45 #\Null
(first args
) #\Null
47 (read-smtp-return-code sock
235 "Plain authentication failed"))
49 (defauthentication :login
(sock args
)
50 (write-to-smtp sock
"AUTH LOGIN")
51 (read-smtp-return-code sock
334 "Login authentication start failed")
52 (write-to-smtp sock
(string-to-base64-string (first args
)))
53 (read-smtp-return-code sock
334 "Login authentication username send failed")
54 (write-to-smtp sock
(string-to-base64-string (second args
)))
55 (read-smtp-return-code sock
235 "Login authentication password send failed"))