protocols/smtp/client-authentication.lisp

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