protocols/smtp/client-commands.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-client-commands* (make-hash-table :test #'eq))
  26
  27   (defun make-smtp-cmd-name (name)
  28     (concat-symbol 'smtp- name '-cmd)))
  29
  30 (defun read-smtp-return-code (sock expected-code error-msg)
  31   (multiple-value-bind (code msg)
  32       (read-from-smtp sock)
  33     (when (/= code expected-code)
  34       (error "~A: ~A" error-msg msg))))
  35
  36 (defmacro define-smtp-command (name (sock &rest args) &body body)
  37   (let ((cmd-name (make-smtp-cmd-name name)))
  38     `(progn
  39        (defun ,cmd-name (,sock ,@args)
  40          ,@body)
  41        (setf (gethash ,name *smtp-client-commands*)
  42              ',cmd-name))))
  43
  44 (defmacro invoke-smtp-command (name sock &rest args)
  45   (let ((cmd-sym (gethash name *smtp-client-commands*)))
  46     (if cmd-sym
  47         `(,cmd-sym ,sock ,@args)
  48         (error "Unknown SMTP command: ~A" name))))
  49 \f
  50 ;;;
  51 ;;; SMTP Commands
  52 ;;;
  53
  54 (define-smtp-command :mail-from (sock from)
  55   (format-socket sock "MAIL FROM: <~A>" from)
  56   (read-smtp-return-code sock 250 "in MAIL FROM command"))
  57
  58 (define-smtp-command :rcpt-to (sock addresses)
  59   (dolist (to addresses)
  60     (format-socket sock "RCPT TO: <~A>" to)
  61     (read-smtp-return-code sock 250 "in RCPT TO command")))
  62
  63 (define-smtp-command :data (sock)
  64   (format-socket sock "DATA")
  65   (read-smtp-return-code sock 354 "in DATA command"))
  66
  67 (define-smtp-command :quit (sock)
  68   (format-socket sock "QUIT")
  69   (read-smtp-return-code sock 221 "in QUIT command"))
  70
  71 (define-smtp-command :ehlo (sock host-name)
  72   (format-socket sock "EHLO ~A" host-name)
  73   (read-smtp-return-code sock 250 "in EHLO command"))
  74
  75 (define-smtp-command :helo (sock host-name)
  76   (format-socket sock "HELO ~A" host-name)
  77   (read-smtp-return-code sock 250 "in HELO command"))