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-string command sock)
  89   (terpri sock)
  90   (finish-output sock))
  91
  92 (defun read-from-smtp (sock)
  93   (let* ((line (read-line sock))
  94          (response-code (parse-integer line :start 0 :junk-allowed t)))
  95     (if (= (char-code (elt line 3)) (char-code #\-))
  96         (read-from-smtp sock)
  97         (values response-code line))))
  98
  99 (defun send-smtp (host from to subject message
 100                   &key (port 25) cc bcc reply-to extra-headers
 101                   display-name authentication attachments buffer-size)
 102   (let ((boundary (make-random-boundary)))
 103     (with-open-stream (sock (make-smtp-socket host port))
 104       (open-smtp-connection sock :authentication authentication)
 105       (write-to-smtp sock (format nil "MAIL FROM: ~@[~A ~]<~A>" display-name from))
 106       (multiple-value-bind (code msgstr)
 107           (read-from-smtp sock)
 108         (when (/= code 250)
 109           (error "in MAIL FROM command: ~A" msgstr)))
 110       (compute-rcpt-command sock to)
 111       (compute-rcpt-command sock cc)
 112       (compute-rcpt-command sock bcc)
 113       (write-to-smtp sock "DATA")
 114       (multiple-value-bind (code msgstr)
 115           (read-from-smtp sock)
 116         (when (/= code 354)
 117           (error "in DATA command: ~A" msgstr)))
 118       (write-to-smtp sock (format nil "Date: ~A" (get-email-date-string)))
 119       (write-to-smtp sock (format nil "From: ~@[~A <~]~A~@[>~]"
 120                                   display-name from display-name))
 121       (write-to-smtp sock (format nil "To: ~{ ~a~^,~}" to))
 122       (when cc
 123         (write-to-smtp sock (format nil "Cc: ~{ ~a~^,~}" cc)))
 124       (write-to-smtp sock (format nil "Subject: ~A" subject))
 125       (write-to-smtp sock (format nil "X-Mailer: cl-smtp ~A"
 126                                   *x-mailer*))
 127       (when reply-to
 128         (write-to-smtp sock (format nil "Reply-To: ~A" reply-to)))
 129       (when (and extra-headers
 130                  (listp extra-headers))
 131         (dolist (l extra-headers)
 132           (write-to-smtp sock
 133                          (format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
 134       (write-to-smtp sock "Mime-Version: 1.0")
 135       (when attachments
 136         (generate-multipart-header sock boundary))
 137       (terpri sock)
 138       (when attachments
 139         (setq message (wrap-message-with-multipart-dividers
 140                        message boundary)))
 141       (write-to-smtp sock message)
 142       (when attachments
 143         (dolist (attachment attachments)
 144           (send-attachment sock attachment boundary buffer-size))
 145         (send-attachments-end-marker sock boundary))
 146       (write-char #\. sock)
 147       (terpri sock)
 148       (finish-output sock)
 149       (multiple-value-bind (code msgstr)
 150           (read-from-smtp sock)
 151         (when (/= code 250)
 152           (error "Message send failed: ~A" msgstr)))
 153       (write-to-smtp sock "QUIT")
 154       (multiple-value-bind (code msgstr)
 155           (read-from-smtp sock)
 156         (when (/= code 221)
 157           (error "in QUIT command:: ~A" msgstr))))))
 158
 159 (defun open-smtp-connection (sock &key authentication)
 160   (multiple-value-bind (code msgstr)
 161       (read-from-smtp sock)
 162     (when (/= code 220)
 163       (error "wrong response from smtp server: ~A" msgstr)))
 164   (cond
 165     (authentication
 166      (write-to-smtp sock (format nil "EHLO ~A" (et:get-host-name)))
 167      (multiple-value-bind (code msgstr)
 168          (read-from-smtp sock)
 169        (when (/= code 250)
 170          (error "wrong response from smtp server: ~A" msgstr)))
 171      (cond
 172        ((eq (car authentication) :plain)
 173         (write-to-smtp sock (format nil "AUTH PLAIN ~A"
 174                                     (string-to-base64-string
 175                                      (format nil "~A~C~A~C~A" (cadr authentication)
 176                                              #\null (cadr authentication) #\null
 177                                              (caddr authentication)))))
 178         (multiple-value-bind (code msgstr)
 179             (read-from-smtp sock)
 180           (when (/= code 235)
 181             (error "plain authentication failed: ~A" msgstr))))
 182        ((eq (car authentication) :login)
 183         (write-to-smtp sock "AUTH LOGIN")
 184         (multiple-value-bind (code msgstr)
 185             (read-from-smtp sock)
 186           (when (/= code 334)
 187             (error "login authentication failed: ~A" msgstr)))
 188         (write-to-smtp sock (string-to-base64-string (cadr authentication)))
 189         (multiple-value-bind (code msgstr)
 190             (read-from-smtp sock)
 191           (when (/= code 334)
 192             (error "login authentication send username failed: ~A" msgstr)))
 193         (write-to-smtp sock (string-to-base64-string (caddr authentication)))
 194         (multiple-value-bind (code msgstr)
 195             (read-from-smtp sock)
 196           (when (/= code 235)
 197             (error "login authentication send password failed: ~A" msgstr))))
 198        (t
 199         (error "authentication ~A is not supported in cl-smtp"
 200                (car authentication)))))
 201     (t
 202      (write-to-smtp sock (format nil "HELO ~A" (et:get-host-name)))
 203      (multiple-value-bind (code msgstr)
 204          (read-from-smtp sock)
 205        (when (/= code 250)
 206          (error "wrong response from smtp server: ~A" msgstr))))))
 207
 208 (defun get-email-date-string ()
 209   (multiple-value-bind (sec min h d m y wd) (get-decoded-time)
 210     (let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1)))
 211            (weekday (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd))
 212            (timezone (get-timezone-from-integer
 213                       (- (encode-universal-time sec min h d m y 0)
 214                          (get-universal-time)))))
 215       (format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D"
 216               weekday d month y h min sec timezone))))
 217
 218 (defun get-timezone-from-integer (x)
 219   (let ((min (/ x 60))
 220         (hour (/ x 3600)))
 221     (if (integerp hour)
 222         (cond
 223           ((>= hour 0)
 224            (format nil "+~2,'0d00" hour))
 225           ((< hour 0)
 226            (format nil "-~2,'0d00" (* -1 hour))))
 227         (multiple-value-bind (h m) (truncate min 60)
 228           (cond
 229             ((>= hour 0)
 230              (format nil "+~2,'0d~2,'0d" h (truncate m)))
 231             ((< hour 0)
 232              (format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m)))))))))