smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;;      Simon Leinen <simon@switch.ch> (ESMTP support)
   7 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   8 ;;      Daiki Ueno <ueno@unixuser.org>
   9 ;; Keywords: SMTP, mail
  10
  11 ;; This file is part of FLIM (Faithful Library about Internet Message).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Code:
  29
  30 (require 'poe)
  31 (require 'poem)
  32 (require 'pcustom)
  33 (require 'mail-utils)                   ; mail-strip-quoted-names
  34
  35 (eval-when-compile (require 'cl))       ; push
  36
  37 (require 'net-trans)
  38
  39 (eval-and-compile
  40   (luna-define-class smtp-transaction (net-transaction)
  41                      (process
  42                       extensions))
  43
  44   (luna-define-internal-accessors 'smtp-transaction))
  45
  46 (defgroup smtp nil
  47   "SMTP protocol for sending mail."
  48   :group 'mail)
  49
  50 (defcustom smtp-default-server nil
  51   "Specify default SMTP server."
  52   :type '(choice (const nil) string)
  53   :group 'smtp)
  54
  55 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  56   "The name of the host running SMTP server.  It can also be a function
  57 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  58   :type '(choice (string :tag "Name")
  59                  (function :tag "Function"))
  60   :group 'smtp)
  61
  62 (defcustom smtp-service "smtp"
  63   "SMTP service port number. \"smtp\" or 25."
  64   :type '(choice (integer :tag "25" 25)
  65                  (string :tag "smtp" "smtp"))
  66   :group 'smtp)
  67
  68 (defcustom smtp-use-8bitmime t
  69   "If non-nil, use ESMTP 8BITMIME if available."
  70   :type 'boolean
  71   :group 'smtp)
  72
  73 (defcustom smtp-local-domain nil
  74   "Local domain name without a host name.
  75 If the function (system-name) returns the full internet address,
  76 don't define this value."
  77   :type '(choice (const nil) string)
  78   :group 'smtp)
  79
  80 (defcustom smtp-notify-success nil
  81   "If non-nil, notification for successful mail delivery is returned
  82  to user (RFC1891)."
  83   :type 'boolean
  84   :group 'smtp)
  85
  86 (defvar smtp-transaction-compose-function
  87   #'smtp-default-transaction-compose-function)
  88
  89 (defvar smtp-open-connection-function (function open-network-stream))
  90
  91 (defvar smtp-read-point nil)
  92
  93 (defun smtp-make-fqdn ()
  94   "Return user's fully qualified domain name."
  95   (let ((system-name (system-name)))
  96     (cond
  97      (smtp-local-domain
  98       (concat system-name "." smtp-local-domain))
  99      ((string-match "[^.]\\.[^.]" system-name)
 100       system-name)
 101      (t
 102       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 103
 104 (defun smtp-greeting (trans)
 105   (let ((response
 106          (smtp-read-response
 107           (smtp-transaction-process-internal trans))))
 108     (or (smtp-check-response response)
 109         (net-transaction-error trans 'greeting))
 110     trans))
 111
 112 (defun smtp-ehlo (trans)
 113   (smtp-send-command
 114    (smtp-transaction-process-internal trans)
 115    (format "EHLO %s" (smtp-make-fqdn)))
 116   (let ((response
 117          (smtp-read-response
 118           (smtp-transaction-process-internal trans))))
 119     (or (smtp-check-response response)
 120         (net-transaction-error trans 'ehlo))
 121     (smtp-transaction-set-extensions-internal
 122      trans (mapcar
 123             (lambda (extension)
 124               (car (read-from-string (downcase extension))))
 125             (cdr response)))
 126     trans))
 127
 128 (defun smtp-helo (trans)
 129   (smtp-send-command
 130    (smtp-transaction-process-internal trans)
 131    (format "HELO %s" (smtp-make-fqdn)))
 132   (let ((response
 133          (smtp-read-response
 134           (smtp-transaction-process-internal trans))))
 135     (or (smtp-check-response response)
 136         (net-transaction-error trans 'helo))
 137     trans))
 138
 139 (defun smtp-mailfrom (sender buffer trans)
 140   (smtp-send-command
 141    (smtp-transaction-process-internal trans)
 142    (format "MAIL FROM:<%s>%s%s"
 143            sender
 144            ;; SIZE --- Message Size Declaration (RFC1870)
 145            (if (memq 'size
 146                      (smtp-transaction-extensions-internal trans))
 147                (format " SIZE=%d"
 148                        (save-excursion
 149                          (set-buffer buffer)
 150                          (+ (- (point-max) (point-min))
 151                             ;; Add one byte for each change-of-line
 152                             ;; because or CR-LF representation:
 153                             (count-lines (point-min) (point-max))
 154                             ;; For some reason, an empty line is
 155                             ;; added to the message.    Maybe this
 156                             ;; is a bug, but it can't hurt to add
 157                             ;; those two bytes anyway:
 158                             2)))
 159              "")
 160            ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 161            (if (and (memq '8bitmime
 162                           (smtp-transaction-extensions-internal trans))
 163                     smtp-use-8bitmime)
 164                " BODY=8BITMIME"
 165              "")))
 166   (let ((response
 167          (smtp-read-response
 168           (smtp-transaction-process-internal trans))))
 169     (or (smtp-check-response response)
 170         (net-transaction-error trans 'mailfrom))
 171     trans))
 172
 173 (defun smtp-rcptto (recipient trans)
 174   (let (response)
 175     (smtp-send-command
 176      (smtp-transaction-process-internal trans)
 177      (format
 178       (if smtp-notify-success
 179           "RCPT TO:<%s> NOTIFY=SUCCESS"
 180         "RCPT TO:<%s>")
 181       recipient))
 182     (setq response
 183           (smtp-read-response
 184            (smtp-transaction-process-internal trans)))
 185     (or (smtp-check-response response)
 186         (net-transaction-error trans 'rcptto))
 187     trans))
 188
 189 (defun smtp-data (buffer trans)
 190   (smtp-send-command
 191    (smtp-transaction-process-internal trans)
 192    "DATA")
 193   (let ((response
 194          (smtp-read-response
 195           (smtp-transaction-process-internal trans))))
 196     (or (smtp-check-response response)
 197         (net-transaction-error trans 'data))
 198
 199     ;; Mail contents
 200     (smtp-send-data
 201      (smtp-transaction-process-internal trans)
 202      buffer)
 203     ;; DATA end "."
 204     (smtp-send-command
 205      (smtp-transaction-process-internal trans)
 206      ".")
 207     (setq response
 208           (smtp-read-response
 209            (smtp-transaction-process-internal trans)))
 210     (or (smtp-check-response response)
 211         (net-transaction-error trans 'data))
 212     trans))
 213
 214 (defun smtp-closure-partial-apply (function &rest args)
 215   `(lambda (trans) (funcall #',function ,@args trans)))
 216
 217 (defun smtp-default-transaction-compose-function (sender recipients buffer)
 218   (net-transaction-compose-&&
 219    (net-transaction-compose-&&
 220     (net-transaction-compose-&&
 221      (net-transaction-compose-&&
 222       #'smtp-greeting
 223       (net-transaction-compose-|| #'smtp-ehlo #'smtp-helo))
 224      (smtp-closure-partial-apply #'smtp-mailfrom sender buffer))
 225     (net-transaction-fold-left
 226      (lambda (accu recipient)
 227        (net-transaction-compose-&&
 228         accu (smtp-closure-partial-apply #'smtp-rcptto recipient)))
 229      #'identity recipients))
 230    (smtp-closure-partial-apply #'smtp-data buffer)))
 231
 232 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
 233   (let ((server (if (functionp smtp-server)
 234                     (funcall smtp-server sender recipients)
 235                   smtp-server))
 236         process response extensions trans error)
 237     (save-excursion
 238       (set-buffer
 239        (get-buffer-create
 240         (format "*trace of SMTP session to %s*" server)))
 241       (buffer-disable-undo)
 242       (erase-buffer)
 243       (make-local-variable 'smtp-read-point)
 244       (setq smtp-read-point (point-min))
 245       (unwind-protect
 246           (let ((function
 247                  (funcall smtp-transaction-compose-function
 248                           sender recipients smtp-text-buffer)))
 249             (or (functionp function)
 250                 (error "Unable to compose SMTP commands"))
 251             (if (and (listp function) (eq (car function) 'lambda))
 252                 (setq function (byte-compile function)));; XXX
 253             (as-binary-process
 254              (setq process
 255                    (funcall smtp-open-connection-function
 256                             "SMTP" (current-buffer) server smtp-service)))
 257             (when process
 258               (set-process-filter process 'smtp-process-filter)
 259               (setq trans
 260                     (luna-make-entity 'smtp-transaction
 261                                       :process process)
 262                     error
 263                     (catch (net-transaction-error-name trans)
 264                       (funcall function trans)
 265                       nil))
 266               (not error)))
 267         (when (and process
 268                    (memq (process-status process) '(open run)))
 269           ;; QUIT
 270           (smtp-send-command process "QUIT")
 271           (delete-process process))))))
 272
 273 (defun smtp-process-filter (process output)
 274   (save-excursion
 275     (set-buffer (process-buffer process))
 276     (goto-char (point-max))
 277     (insert output)))
 278
 279 (defun smtp-read-response (process)
 280   (let ((case-fold-search nil)
 281         response
 282         (response-continue t)
 283         match-end)
 284     (while response-continue
 285       (goto-char smtp-read-point)
 286       (while (not (search-forward "\r\n" nil t))
 287         (accept-process-output process)
 288         (goto-char smtp-read-point))
 289       (setq match-end (point))
 290       (setq response
 291             (nconc response
 292                    (list (buffer-substring (+ 4 smtp-read-point)
 293                                            (- match-end 2)))))
 294       (goto-char smtp-read-point)
 295       (when (looking-at "[1-5][0-9][0-9] ")
 296         (setq response-continue nil)
 297         (push (read (point-marker)) response))
 298       (setq smtp-read-point match-end))
 299     response))
 300
 301 (defun smtp-check-response (response)
 302   (memq (/ (car response) 100) '(2 3)));; XXX
 303
 304 (defun smtp-send-command (process command)
 305   (goto-char (point-max))
 306   (insert command "\r\n")
 307   (setq smtp-read-point (point))
 308   (process-send-string process command)
 309   (process-send-string process "\r\n"))
 310
 311 (defun smtp-send-data-1 (process data)
 312   (goto-char (point-max))
 313   (setq smtp-read-point (point))
 314   ;; Escape "." at start of a line.
 315   (if (eq (string-to-char data) ?.)
 316       (process-send-string process "."))
 317   (process-send-string process data)
 318   (process-send-string process "\r\n"))
 319
 320 (defun smtp-send-data (process buffer)
 321   (let ((data-continue t)
 322         (sending-data nil)
 323         this-line
 324         this-line-end)
 325
 326     (save-excursion
 327       (set-buffer buffer)
 328       (goto-char (point-min)))
 329
 330     (while data-continue
 331       (save-excursion
 332         (set-buffer buffer)
 333         (beginning-of-line)
 334         (setq this-line (point))
 335         (end-of-line)
 336         (setq this-line-end (point))
 337         (setq sending-data nil)
 338         (setq sending-data (buffer-substring this-line this-line-end))
 339         (if (or (/= (forward-line 1) 0) (eobp))
 340             (setq data-continue nil)))
 341
 342       (smtp-send-data-1 process sending-data))))
 343
 344 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 345   "Get address list suitable for smtp RCPT TO:<address>."
 346   (let ((simple-address-list "")
 347         this-line
 348         this-line-end
 349         addr-regexp
 350         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 351     (unwind-protect
 352         (save-excursion
 353           ;;
 354           (set-buffer smtp-address-buffer)
 355           (setq case-fold-search t)
 356           (erase-buffer)
 357           (insert (save-excursion
 358                     (set-buffer smtp-text-buffer)
 359                     (buffer-substring-no-properties header-start header-end)))
 360           (goto-char (point-min))
 361           ;; RESENT-* fields should stop processing of regular fields.
 362           (save-excursion
 363             (if (re-search-forward "^RESENT-TO:" header-end t)
 364                 (setq addr-regexp
 365                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 366               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 367
 368           (while (re-search-forward addr-regexp header-end t)
 369             (replace-match "")
 370             (setq this-line (match-beginning 0))
 371             (forward-line 1)
 372             ;; get any continuation lines.
 373             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 374               (forward-line 1))
 375             (setq this-line-end (point-marker))
 376             (setq simple-address-list
 377                   (concat simple-address-list " "
 378                           (mail-strip-quoted-names
 379                            (buffer-substring this-line this-line-end)))))
 380           (erase-buffer)
 381           (insert-string " ")
 382           (insert-string simple-address-list)
 383           (insert-string "\n")
 384           ;; newline --> blank
 385           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 386           ;; comma   --> blank
 387           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 388           ;; tab     --> blank
 389           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 390
 391           (goto-char (point-min))
 392           ;; tidyness in case hook is not robust when it looks at this
 393           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 394
 395           (goto-char (point-min))
 396           (let (recipient-address-list)
 397             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 398               (backward-char 1)
 399               (setq recipient-address-list
 400                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 401                           recipient-address-list)))
 402             recipient-address-list))
 403       (kill-buffer smtp-address-buffer))))
 404
 405 (provide 'smtp)
 406
 407 ;;; smtp.el ends here