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