protocols/smtp/smtp.lisp

   1 ;;; -*- mode: Lisp -*-
   2
   3 ;;; This file is part of CL-SMTP, the Lisp SMTP Client
   4
   5 ;;; Copyright (C) 2004/2005 Jan Idzikowski
   6
   7 ;;; This library is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the Lisp Lesser General Public License
   9 ;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
  10
  11 ;;; This library is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; Lisp Lesser GNU General Public License for more details.
  15
  16 ;;; File: cl-smtp.lisp
  17 ;;; Description: main smtp client logic
  18
  19 (in-package :net.smtp-client)
  20
  21 (defparameter *debug* nil)
  22 (defparameter *x-mailer*
  23   (format nil "(~A ~A)"
  24           (lisp-implementation-type)
  25           (lisp-implementation-version)))
  26
  27 (defun check-arg (arg name)
  28   (cond
  29     ((or (stringp arg)
  30          (pathnamep arg))
  31      (list arg))
  32     ((listp arg)
  33      arg)
  34     (t
  35      (error "the \"~A\" argument is not a string or cons" name))))
  36
  37 (defun mask-dot (str)
  38   "replace \r\n.\r\n with \r\n..\r\n"
  39   (let ((dotstr (format nil "~C.~C" #\NewLine #\NewLine))
  40         (maskdotsr (format nil "~C..~C" #\NewLine #\NewLine))
  41         (resultstr ""))
  42     (labels ((mask (tempstr)
  43                (let ((n (search dotstr tempstr)))
  44                  (cond
  45                    (n
  46                     (setf resultstr (concatenate 'string resultstr
  47                                                  (subseq tempstr 0 n)
  48                                                  maskdotsr))
  49                     (mask (subseq tempstr (+ n 3))))
  50                    (t
  51                     (setf resultstr (concatenate 'string resultstr
  52                                                  tempstr)))))))
  53       (mask str))
  54     resultstr))
  55
  56 (defun string-to-base64-string (str)
  57   (cl-base64:string-to-base64-string str))
  58
  59 (defun send-email (host from to subject message
  60                    &key (port 25) cc bcc reply-to extra-headers
  61                    display-name authentication
  62                    attachments (buffer-size 256))
  63   (send-smtp host from (check-arg to "to") subject (mask-dot message)
  64              :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
  65              :reply-to reply-to
  66              :extra-headers extra-headers
  67              :display-name display-name
  68              :authentication authentication
  69              :attachments (check-arg attachments "attachments")
  70              :buffer-size (if (numberp buffer-size)
  71                               buffer-size
  72                               256)))
  73
  74 (defun make-smtp-socket (host port)
  75   (make-socket :address-family :internet :type :stream :connect :active
  76                :remote-host host :remote-port port
  77                :external-format '(:iso-8859-1 :line-terminator :dos)))
  78
  79 (defun compute-rcpt-command (sock adresses)
  80   (dolist (to adresses)
  81     (write-to-smtp sock (format nil "RCPT TO: <~A>" to))
  82     (multiple-value-bind (code msgstr)
  83         (read-from-smtp sock)
  84       (when (/= code 250)
  85         (error "in RCPT TO command: ~A" msgstr)))))
  86
  87 (defun write-to-smtp (sock command)
  88   (write-line command sock)
  89   (finish-output sock))
  90
  91 (defun read-from-smtp (sock)
  92   (let* ((line (read-line sock))
  93          (response-code (parse-integer line :start 0 :junk-allowed t)))
  94     (if (= (char-code (elt line 3)) (char-code #\-))
  95         (read-from-smtp sock)
  96         (values response-code line))))
  97
  98 (defun send-smtp (host from to subject message
  99                   &key (port 25) cc bcc reply-to extra-headers
 100                   display-name authentication attachments buffer-size)
 101   (let ((boundary (make-random-boundary)))
 102     (with-open-stream (sock (make-smtp-socket host port))
 103       (open-smtp-connection sock :authentication authentication)
 104       (write-to-smtp sock (format nil "MAIL FROM: ~@[~A ~]<~A>" display-name from))
 105       (multiple-value-bind (code msgstr)
 106           (read-from-smtp sock)
 107         (when (/= code 250)
 108           (error "in MAIL FROM command: ~A" msgstr)))
 109       (compute-rcpt-command sock to)
 110       (compute-rcpt-command sock cc)
 111       (compute-rcpt-command sock bcc)
 112       (write-to-smtp sock "DATA")
 113       (multiple-value-bind (code msgstr)
 114           (read-from-smtp sock)
 115         (when (/= code 354)
 116           (error "in DATA command: ~A" msgstr)))
 117       (write-to-smtp sock (format nil "Date: ~A" (get-email-date-string)))
 118       (write-to-smtp sock (format nil "From: ~@[~A <~]~A~@[>~]"
 119                                   display-name from display-name))
 120       (write-to-smtp sock (format nil "To: ~{ ~a~^,~}" to))
 121       (when cc
 122         (write-to-smtp sock (format nil "Cc: ~{ ~a~^,~}" cc)))
 123       (write-to-smtp sock (format nil "Subject: ~A" subject))
 124       (write-to-smtp sock (format nil "X-Mailer: cl-smtp ~A"
 125                                   *x-mailer*))
 126       (when reply-to
 127         (write-to-smtp sock (format nil "Reply-To: ~A" reply-to)))
 128       (when (and extra-headers
 129                  (listp extra-headers))
 130         (dolist (l extra-headers)
 131           (write-to-smtp sock
 132                          (format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
 133       (write-to-smtp sock "Mime-Version: 1.0")
 134       (when attachments
 135         (generate-multipart-header sock boundary))
 136       (terpri sock)
 137       (when attachments
 138         (setq message (wrap-message-with-multipart-dividers
 139                        message boundary)))
 140       (write-to-smtp sock message)
 141       (when attachments
 142         (dolist (attachment attachments)
 143           (send-attachment sock attachment boundary buffer-size))
 144         (send-attachments-end-marker sock boundary))
 145       (write-char #\. sock)
 146       (terpri sock)
 147       (finish-output sock)
 148       (multiple-value-bind (code msgstr)
 149           (read-from-smtp sock)
 150         (when (/= code 250)
 151           (error "Message send failed: ~A" msgstr)))
 152       (write-to-smtp sock "QUIT")
 153       (multiple-value-bind (code msgstr)
 154           (read-from-smtp sock)
 155         (when (/= code 221)
 156           (error "in QUIT command:: ~A" msgstr))))))
 157
 158 (defun open-smtp-connection (sock &key authentication)
 159   (multiple-value-bind (code msgstr)
 160       (read-from-smtp sock)
 161     (when (/= code 220)
 162       (error "wrong response from smtp server: ~A" msgstr)))
 163   (cond
 164     (authentication
 165      (write-to-smtp sock (format nil "EHLO ~A" (et:get-host-name)))
 166      (multiple-value-bind (code msgstr)
 167          (read-from-smtp sock)
 168        (when (/= code 250)
 169          (error "wrong response from smtp server: ~A" msgstr)))
 170      (cond
 171        ((eq (car authentication) :plain)
 172         (write-to-smtp sock (format nil "AUTH PLAIN ~A"
 173                                     (string-to-base64-string
 174                                      (format nil "~A~C~A~C~A" (cadr authentication)
 175                                              #\null (cadr authentication) #\null
 176                                              (caddr authentication)))))
 177         (multiple-value-bind (code msgstr)
 178             (read-from-smtp sock)
 179           (when (/= code 235)
 180             (error "plain authentication failed: ~A" msgstr))))
 181        ((eq (car authentication) :login)
 182         (write-to-smtp sock "AUTH LOGIN")
 183         (multiple-value-bind (code msgstr)
 184             (read-from-smtp sock)
 185           (when (/= code 334)
 186             (error "login authentication failed: ~A" msgstr)))
 187         (write-to-smtp sock (string-to-base64-string (cadr authentication)))
 188         (multiple-value-bind (code msgstr)
 189             (read-from-smtp sock)
 190           (when (/= code 334)
 191             (error "login authentication send username failed: ~A" msgstr)))
 192         (write-to-smtp sock (string-to-base64-string (caddr authentication)))
 193         (multiple-value-bind (code msgstr)
 194             (read-from-smtp sock)
 195           (when (/= code 235)
 196             (error "login authentication send password failed: ~A" msgstr))))
 197        (t
 198         (error "authentication ~A is not supported in cl-smtp"
 199                (car authentication)))))
 200     (t
 201      (write-to-smtp sock (format nil "HELO ~A" (et:get-host-name)))
 202      (multiple-value-bind (code msgstr)
 203          (read-from-smtp sock)
 204        (when (/= code 250)
 205          (error "wrong response from smtp server: ~A" msgstr))))))
 206
 207 (defun get-email-date-string ()
 208   (multiple-value-bind (sec min h d m y wd) (get-decoded-time)
 209     (let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1)))
 210            (weekday (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd))
 211            (timezone (get-timezone-from-integer
 212                       (- (encode-universal-time sec min h d m y 0)
 213                          (get-universal-time)))))
 214       (format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D"
 215               weekday d month y h min sec timezone))))
 216
 217 (defun get-timezone-from-integer (x)
 218   (let ((min (/ x 60))
 219         (hour (/ x 3600)))
 220     (if (integerp hour)
 221         (cond
 222           ((>= hour 0)
 223            (format nil "+~2,'0d00" hour))
 224           ((< hour 0)
 225            (format nil "-~2,'0d00" (* -1 hour))))
 226         (multiple-value-bind (h m) (truncate min 60)
 227           (cond
 228             ((>= hour 0)
 229              (format nil "+~2,'0d~2,'0d" h (truncate m)))
 230             ((< hour 0)
 231              (format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m)))))))))