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 (defvar *x-mailer*
  22   (format nil "(~A ~A)"
  23           (lisp-implementation-type)
  24           (lisp-implementation-version)))
  25 \f
  26 ;;;
  27 ;;; Protocol handling
  28 ;;;
  29
  30 (defun check-arg (arg name)
  31   (cond
  32     ((or (stringp arg)
  33          (pathnamep arg))
  34      (list arg))
  35     ((listp arg)
  36      arg)
  37     (t
  38      (error "the \"~A\" argument is not a string or cons" name))))
  39
  40 (defun mask-dot (str)
  41   "replace \r\n.\r\n with \r\n..\r\n"
  42   (let ((dotstr (format nil "~C.~C" #\NewLine #\NewLine))
  43         (maskdotsr (format nil "~C..~C" #\NewLine #\NewLine))
  44         (resultstr ""))
  45     (labels ((mask (tempstr)
  46                (let ((n (search dotstr tempstr)))
  47                  (cond
  48                    (n
  49                     (setf resultstr (concatenate 'string resultstr
  50                                                  (subseq tempstr 0 n)
  51                                                  maskdotsr))
  52                     (mask (subseq tempstr (+ n 3))))
  53                    (t
  54                     (setf resultstr (concatenate 'string resultstr
  55                                                  tempstr)))))))
  56       (mask str))
  57     resultstr))
  58
  59 (defun string-to-base64-string (str)
  60   (string-to-base64-string str))
  61
  62 (defun send-email (host from to subject message
  63                    &key (port 25) cc bcc reply-to extra-headers
  64                    display-name authentication
  65                    attachments (buffer-size 256))
  66   (send-smtp host from (check-arg to "to") subject (mask-dot message)
  67              :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
  68              :reply-to reply-to
  69              :extra-headers extra-headers
  70              :display-name display-name
  71              :authentication authentication
  72              :attachments (check-arg attachments "attachments")
  73              :buffer-size (if (numberp buffer-size)
  74                               buffer-size
  75                               256)))
  76
  77 (defun send-smtp (host from to subject message
  78                   &key (port 25) cc bcc reply-to extra-headers
  79                   display-name authentication attachments buffer-size)
  80   (with-open-stream (sock (make-smtp-socket host port))
  81     (open-smtp-connection sock authentication)
  82     (send-message-envelope sock from to cc bcc)
  83     (invoke-smtp-command :data sock)
  84     (send-message-headers sock from to subject cc reply-to extra-headers display-name)
  85     (send-message-body sock message attachments buffer-size)
  86     (invoke-smtp-command :quit sock)))
  87
  88 (defun open-smtp-connection (sock authentication)
  89   (read-smtp-return-code sock 220 "Wrong response from smtp server")
  90   (cond
  91     (authentication
  92      (invoke-smtp-command :ehlo sock (et:get-host-name))
  93      (invoke-authentication (first authentication) (rest authentication)))
  94     (t
  95      (invoke-smtp-command :helo sock (et:get-host-name)))))
  96
  97 (defun send-message-envelope (sock from to cc bcc)
  98   (invoke-smtp-command :mail-from sock from)
  99   (invoke-smtp-command :rcpt-to sock to)
 100   (invoke-smtp-command :rcpt-to sock cc)
 101   (invoke-smtp-command :rcpt-to sock bcc))
 102
 103 (defun send-message-headers (sock from to subject cc reply-to extra-headers display-name)
 104   (format-socket sock "Date: ~A" (get-email-date-string))
 105   (format-socket sock "From: ~@[~A <~]~A~@[>~]"
 106                  display-name from display-name)
 107   (format-socket sock "To: ~{ ~a~^,~}" to)
 108   (when cc
 109     (format-socket sock "Cc: ~{ ~A~^,~}" cc))
 110   (format-socket sock "Subject: ~A" subject)
 111   (format-socket sock "X-Mailer: cl-smtp ~A"  *x-mailer*)
 112   (when reply-to
 113     (format-socket sock "Reply-To: ~A" reply-to))
 114   (dolist (l extra-headers)
 115     (format-socket sock "~A: ~{~A~^,~}" (car l) (rest l)))
 116   (write-to-smtp sock "Mime-Version: 1.0"))
 117
 118 (defun send-message-body (sock message attachments buffer-size)
 119   (let ((boundary (make-random-boundary)))
 120     (when attachments
 121       (generate-multipart-header sock boundary)
 122       (terpri sock)
 123       (setf message (wrap-message-with-multipart-dividers
 124                      message boundary)))
 125     (write-to-smtp sock message)
 126     (when attachments
 127       (dolist (attachment attachments)
 128         (send-attachment sock attachment boundary buffer-size))
 129       (send-attachments-end-marker sock boundary))
 130     (write-char #\. sock) (terpri sock) (finish-output sock)
 131     (read-smtp-return-code sock 250 "Message send failed")))
 132
 133 (defun get-email-date-string ()
 134   (multiple-value-bind (sec min h d m y wd) (get-decoded-time)
 135     (let* ((month (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1)))
 136            (weekday (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd))
 137            (timezone (get-timezone-from-integer
 138                       (- (encode-universal-time sec min h d m y 0)
 139                          (get-universal-time)))))
 140       (format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D"
 141               weekday d month y h min sec timezone))))
 142
 143 (defun get-timezone-from-integer (x)
 144   (let ((min (/ x 60))
 145         (hour (/ x 3600)))
 146     (if (integerp hour)
 147         (cond
 148           ((>= hour 0)
 149            (format nil "+~2,'0d00" hour))
 150           ((< hour 0)
 151            (format nil "-~2,'0d00" (* -1 hour))))
 152         (multiple-value-bind (h m) (truncate min 60)
 153           (cond
 154             ((>= hour 0)
 155              (format nil "+~2,'0d~2,'0d" h (truncate m)))
 156             ((< hour 0)
 157              (format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m)))))))))