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