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
  29 ;;; Commentary:
  30 ;;
  31
  32 ;;; Code:
  33
  34 (require 'pces)
  35 (require 'pcustom)
  36 (require 'mail-utils)                   ; mail-strip-quoted-names
  37
  38 (defgroup smtp nil
  39   "SMTP protocol for sending mail."
  40   :group 'mail)
  41
  42 (defgroup smtp-extensions nil
  43   "SMTP service extensions (RFC1869)."
  44   :group 'smtp)
  45
  46 (defcustom smtp-default-server nil
  47   "Specify default SMTP server."
  48   :type '(choice (const nil) string)
  49   :group 'smtp)
  50
  51 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  52   "The name of the host running SMTP server.
  53 It can also be a function
  54 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  55   :type '(choice (string :tag "Name")
  56                  (function :tag "Function"))
  57   :group 'smtp)
  58
  59 (defcustom smtp-service "smtp"
  60   "SMTP service port number.  \"smtp\" or 25."
  61   :type '(choice (integer :tag "25" 25)
  62                  (string :tag "smtp" "smtp"))
  63   :group 'smtp)
  64
  65 (defcustom smtp-local-domain nil
  66   "Local domain name without a host name.
  67 If the function (system-name) returns the full internet address,
  68 don't define this value."
  69   :type '(choice (const nil) string)
  70   :group 'smtp)
  71
  72 (defcustom smtp-fqdn nil
  73   "Fully qualified domain name used for Message-ID."
  74   :type '(choice (const nil) string)
  75   :group 'smtp)
  76
  77 (defcustom smtp-use-8bitmime t
  78   "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
  79   :type 'boolean
  80   :group 'smtp-extensions)
  81
  82 (defcustom smtp-use-size t
  83   "If non-nil, use ESMTP SIZE (RFC1870) if available."
  84   :type 'boolean
  85   :group 'smtp-extensions)
  86
  87 (defcustom smtp-use-starttls nil
  88   "If non-nil, use STARTTLS (RFC2595) if available."
  89   :type 'boolean
  90   :group 'smtp-extensions)
  91
  92 (defcustom smtp-use-sasl nil
  93   "If non-nil, use SMTP Authentication (RFC2554) if available."
  94   :type 'boolean
  95   :group 'smtp-extensions)
  96
  97 (defcustom smtp-sasl-user-name (user-login-name)
  98   "Identification to be used for authorization."
  99   :type 'string
 100   :group 'smtp-extensions)
 101
 102 (defcustom smtp-sasl-user-realm smtp-local-domain
 103   "Realm name to be used for authorization."
 104   :type 'string
 105   :group 'smtp-extensions)
 106
 107 (defcustom smtp-sasl-mechanisms nil
 108   "List of authentication mechanisms."
 109   :type '(repeat string)
 110   :group 'smtp-extensions)
 111
 112 (defvar sasl-mechanisms)
 113
 114 (defvar smtp-open-connection-function #'open-network-stream)
 115
 116 (defvar smtp-read-point nil)
 117
 118 (defvar smtp-connection-alist nil)
 119
 120 (defvar smtp-submit-package-function #'smtp-submit-package)
 121
 122 ;;; @ SMTP package structure
 123 ;;; A package contains a mail message, an envelope sender address,
 124 ;;; and one or more envelope recipient addresses.  In ESMTP model,
 125 ;;; we should guarantee the user to access the current sending package
 126 ;;; anywhere from the hook methods (or SMTP commands).
 127
 128 (defmacro smtp-package-sender (package)
 129   "Return the sender of PACKAGE, a string."
 130   `(aref ,package 0))
 131
 132 (defmacro smtp-package-recipients (package)
 133   "Return the recipients of PACKAGE, a list of strings."
 134   `(aref ,package 1))
 135
 136 (defmacro smtp-package-buffer (package)
 137   "Return the data of PACKAGE, a buffer."
 138   `(aref ,package 2))
 139
 140 (defmacro smtp-make-package (sender recipients buffer)
 141   "Create a new package structure.
 142 A package is a unit of SMTP message which contains a mail message,
 143 an envelope sender address, and one or more envelope recipient addresses.
 144 SENDER specifies the package sender, a string.
 145 RECIPIENTS is a list of recipients.
 146 BUFFER may be a buffer or a buffer name which contains mail message."
 147   `(vector ,sender ,recipients ,buffer))
 148
 149 (defun smtp-package-buffer-size (package)
 150   "Return the size of PACKAGE, an integer."
 151   (save-excursion
 152     (set-buffer (smtp-package-buffer package))
 153     (let ((size
 154            (+ (buffer-size)
 155               ;; Add one byte for each change-of-line
 156               ;; because or CR-LF representation:
 157               (count-lines (point-min) (point-max))
 158               ;; For some reason, an empty line is
 159               ;; added to the message.  Maybe this
 160               ;; is a bug, but it can't hurt to add
 161               ;; those two bytes anyway:
 162               2)))
 163       (goto-char (point-min))
 164       (while (re-search-forward "^\\." nil t)
 165         (setq size (1+ size)))
 166       size)))
 167
 168 ;;; @ SMTP connection structure
 169 ;;; We should take care of a emulation for another network stream.
 170 ;;; They are likely to be implemented with a external program and the function
 171 ;;; `process-contact' returns the process ID instead of `(HOST SERVICE)' pair.
 172
 173 (defmacro smtp-connection-process (connection)
 174   "Return the subprocess-object of CONNECTION."
 175   `(aref ,connection 0))
 176
 177 (defmacro smtp-connection-server (connection)
 178   "Return the server of CONNECTION, a string."
 179   `(aref ,connection 1))
 180
 181 (defmacro smtp-connection-service (connection)
 182   "Return the service of CONNECTION, a string or an integer."
 183   `(aref ,connection 2))
 184
 185 (defmacro smtp-connection-extensions (connection)
 186   "Return the SMTP extensions of CONNECTION, a list of strings."
 187   `(aref ,connection 3))
 188
 189 (defmacro smtp-connection-set-extensions (connection extensions)
 190   "Set the SMTP extensions of CONNECTION.
 191 EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS).
 192 Where EXTENSION is a symbol and PARAMETERS is a list of strings."
 193   `(aset ,connection 3 ,extensions))
 194
 195 (defmacro smtp-make-connection (process server service)
 196   "Create a new connection structure.
 197 PROCESS is an internal subprocess-object.  SERVER is name of the host
 198 to connect to.  SERVICE is name of the service desired."
 199   `(vector ,process ,server ,service nil))
 200
 201 (defun smtp-connection-opened (connection)
 202   "Say whether the CONNECTION to server has been opened."
 203   (let ((process (smtp-connection-process connection)))
 204     (if (memq (process-status process) '(open run))
 205         t)))
 206
 207 (defun smtp-close-connection (connection)
 208   "Close the CONNECTION to server."
 209   (let ((process (smtp-connection-process connection)))
 210     (delete-process process)))
 211
 212 (defun smtp-make-fqdn ()
 213   "Return user's fully qualified domain name."
 214   (if smtp-fqdn
 215       smtp-fqdn
 216     (let ((system-name (system-name)))
 217       (cond
 218        (smtp-local-domain
 219         (concat system-name "." smtp-local-domain))
 220        ((string-match "[^.]\\.[^.]" system-name)
 221         system-name)
 222        (t
 223         (error "Cannot generate valid FQDN"))))))
 224
 225 (defun smtp-find-connection (buffer)
 226   "Find the connection delivering to BUFFER."
 227   (let ((entry (assq buffer smtp-connection-alist))
 228         connection)
 229     (when entry
 230       (setq connection (nth 1 entry))
 231       (if (smtp-connection-opened connection)
 232           connection
 233         (setq smtp-connection-alist
 234               (delq entry smtp-connection-alist))
 235         nil))))
 236
 237 (eval-and-compile
 238   (autoload 'starttls-open-stream "starttls")
 239   (autoload 'starttls-negotiate "starttls"))
 240
 241 (defun smtp-open-connection (buffer server service)
 242   "Open a SMTP connection for a service to a host.
 243 Return a newly allocated connection-object.
 244 BUFFER is the buffer to associate with the connection.  SERVER is name
 245 of the host to connect to.  SERVICE is name of the service desired."
 246   (let ((process
 247          (as-binary-process
 248           (funcall smtp-open-connection-function
 249                    "SMTP" buffer  server service)))
 250         connection)
 251     (when process
 252       (setq connection (smtp-make-connection process server service))
 253       (set-process-filter process 'smtp-process-filter)
 254       (setq smtp-connection-alist
 255             (cons (list buffer connection)
 256                   smtp-connection-alist))
 257       connection)))
 258
 259 ;;;###autoload
 260 (defun smtp-via-smtp (sender recipients buffer)
 261   (condition-case nil
 262       (progn
 263         (smtp-send-buffer sender recipients buffer)
 264         t)
 265     (smtp-error)))
 266
 267 (make-obsolete 'smtp-via-smtp "It's old API.")
 268
 269 ;;;###autoload
 270 (defun smtp-send-buffer (sender recipients buffer)
 271   (let ((server
 272          (if (functionp smtp-server)
 273              (funcall smtp-server sender recipients)
 274            smtp-server))
 275         (package
 276          (smtp-make-package sender recipients buffer))
 277         (smtp-open-connection-function
 278          (if smtp-use-starttls
 279              #'starttls-open-stream
 280            smtp-open-connection-function)))
 281     (save-excursion
 282       (set-buffer
 283        (get-buffer-create
 284         (format "*trace of SMTP session to %s*" server)))
 285       (erase-buffer)
 286       (buffer-disable-undo)
 287       (unless (smtp-find-connection (current-buffer))
 288         (smtp-open-connection (current-buffer) server smtp-service))
 289       (make-local-variable 'smtp-read-point)
 290       (setq smtp-read-point (point-min))
 291       (funcall smtp-submit-package-function package))))
 292
 293 (defun smtp-submit-package (package)
 294   (unwind-protect
 295       (progn
 296         (smtp-primitive-greeting package)
 297         (condition-case nil
 298             (smtp-primitive-ehlo package)
 299           (smtp-response-error
 300            (smtp-primitive-helo package)))
 301         (if smtp-use-starttls
 302             (smtp-primitive-starttls package))
 303         (if smtp-use-sasl
 304             (smtp-primitive-auth package))
 305         (smtp-primitive-mailfrom package)
 306         (smtp-primitive-rcptto package)
 307         (smtp-primitive-data package))
 308     (let ((connection (smtp-find-connection (current-buffer))))
 309       (when (smtp-connection-opened connection)
 310         ;; QUIT
 311         (smtp-primitive-quit package)
 312         (smtp-close-connection connection)))))
 313
 314 ;;; @ hook methods for `smtp-submit-package'
 315 ;;;
 316
 317 (defun smtp-primitive-greeting (package)
 318   (let* ((connection
 319           (smtp-find-connection (current-buffer)))
 320          (response
 321           (smtp-read-response
 322            (smtp-connection-process connection))))
 323     (if (/= (car response) 220)
 324         (smtp-response-error response))))
 325
 326 (defun smtp-primitive-ehlo (package)
 327   (let* ((connection
 328           (smtp-find-connection (current-buffer)))
 329          (process
 330           (smtp-connection-process connection))
 331          response)
 332     (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn)))
 333     (setq response (smtp-read-response process))
 334     (if (/= (car response) 250)
 335         (smtp-response-error response))
 336     (smtp-connection-set-extensions
 337      connection (mapcar
 338                  (lambda (extension)
 339                    (let ((extensions
 340                           (split-string extension)))
 341                      (setcar extensions
 342                              (car (read-from-string
 343                                    (downcase (car extensions)))))
 344                      extensions))
 345                  (cdr response)))))
 346
 347 (defun smtp-primitive-helo (package)
 348   (let* ((connection
 349           (smtp-find-connection (current-buffer)))
 350          (process
 351           (smtp-connection-process connection))
 352          response)
 353     (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
 354     (setq response (smtp-read-response process))
 355     (if (/= (car response) 250)
 356         (smtp-response-error response))))
 357
 358 (eval-and-compile
 359   (autoload 'sasl-make-instantiator "sasl")
 360   (autoload 'sasl-find-authenticator "sasl")
 361   (autoload 'sasl-authenticator-mechanism "sasl")
 362   (autoload 'sasl-evaluate-challenge "sasl"))
 363
 364 (defun smtp-primitive-auth (package)
 365   (let* ((connection
 366           (smtp-find-connection (current-buffer)))
 367          (process
 368           (smtp-connection-process connection))
 369          (mechanisms
 370           (cdr (assq 'auth (smtp-connection-extensions connection))))
 371          (authenticator
 372           (let ((sasl-mechanisms smtp-sasl-mechanisms))
 373             (sasl-find-authenticator mechanisms)))
 374          instantiator
 375          mechanism
 376          sasl-response
 377          response)
 378     (unless authenticator
 379       (error "No authentication mechanism available"))
 380     (setq instantiator
 381           (sasl-make-instantiator
 382            smtp-sasl-user-name "smtp" (smtp-connection-server connection)))
 383     (if smtp-sasl-user-realm
 384         (sasl-instantiator-set-property
 385          instantiator 'realm smtp-sasl-user-realm))
 386     (setq mechanism (sasl-authenticator-mechanism authenticator)
 387           ;; Retrieve the initial response
 388           sasl-response (sasl-evaluate-challenge authenticator instantiator))
 389     (smtp-send-command
 390      process
 391      (if (nth 1 sasl-response)
 392          (format "AUTH %s %s" mechanism (base64-encode-string (nth 1 sasl-response) t))
 393        (format "AUTH %s" mechanism)))
 394     (catch 'done
 395       (while t
 396         (setq response (smtp-read-response process))
 397         (when (= (car response) 235)
 398           ;; The authentication process is finished.
 399           (setq sasl-response
 400                 (sasl-evaluate-challenge authenticator instantiator sasl-response))
 401           (if (null sasl-response)
 402               (throw 'done nil))
 403           (smtp-response-error response)) ;Bogus server?
 404         (if (/= (car response) 334)
 405             (smtp-response-error response))
 406         (setcar (cdr sasl-response) (base64-decode-string (nth 1 response)))
 407         (setq sasl-response
 408               (sasl-evaluate-challenge
 409                authenticator instantiator sasl-response))
 410         (smtp-send-command
 411          process (if (nth 1 sasl-response)
 412                      (base64-encode-string (nth 1 sasl-response) t)
 413                    ""))))))
 414
 415 (defun smtp-primitive-starttls (package)
 416   (let* ((connection
 417           (smtp-find-connection (current-buffer)))
 418          (process
 419           (smtp-connection-process connection))
 420          response)
 421     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 422     (smtp-send-command process "STARTTLS")
 423     (setq response (smtp-read-response process))
 424     (if (/= (car response) 220)
 425         (smtp-response-error response))
 426     (starttls-negotiate process)))
 427
 428 (defun smtp-primitive-mailfrom (package)
 429   (let* ((connection
 430           (smtp-find-connection (current-buffer)))
 431          (process
 432           (smtp-connection-process connection))
 433          (extensions
 434           (smtp-connection-extensions
 435            connection))
 436          (sender
 437           (smtp-package-sender package))
 438          extension
 439          response)
 440     ;; SIZE --- Message Size Declaration (RFC1870)
 441     (if (and smtp-use-size
 442              (assq 'size extensions))
 443         (setq extension (format "SIZE=%d" (smtp-package-buffer-size package))))
 444     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 445     (if (and smtp-use-8bitmime
 446              (assq '8bitmime extensions))
 447         (setq extension (concat extension " BODY=8BITMIME")))
 448     (smtp-send-command
 449      process
 450      (if extension
 451          (format "MAIL FROM:<%s> %s" sender extension)
 452        (format "MAIL FROM:<%s>" sender)))
 453     (setq response (smtp-read-response process))
 454     (if (/= (car response) 250)
 455         (smtp-response-error response))))
 456
 457 (defun smtp-primitive-rcptto (package)
 458   (let* ((connection
 459           (smtp-find-connection (current-buffer)))
 460          (process
 461           (smtp-connection-process connection))
 462          (recipients
 463           (smtp-package-recipients package))
 464          response)
 465     (while recipients
 466       (smtp-send-command
 467        process (format "RCPT TO:<%s>" (pop recipients))))
 468     (setq response (smtp-read-response process))
 469     (unless (memq (car response) '(250 251))
 470       (smtp-response-error response))))
 471
 472 (defun smtp-primitive-data (package)
 473   (let* ((connection
 474           (smtp-find-connection (current-buffer)))
 475          (process
 476           (smtp-connection-process connection))
 477          response)
 478     (smtp-send-command process "DATA")
 479     (setq response (smtp-read-response process))
 480     (if (/= (car response) 354)
 481         (smtp-response-error response))
 482     (save-excursion
 483       (set-buffer (smtp-package-buffer package))
 484       (goto-char (point-min))
 485       (while (not (eobp))
 486         (smtp-send-data
 487          process (buffer-substring (point) (progn (end-of-line)(point))))
 488         (forward-char)))
 489     (smtp-send-command process ".")
 490     (setq response (smtp-read-response process))
 491     (if (/= (car response) 250)
 492         (smtp-response-error response))))
 493
 494 (defun smtp-primitive-quit (package)
 495   (let* ((connection
 496           (smtp-find-connection (current-buffer)))
 497          (process
 498           (smtp-connection-process connection))
 499          response)
 500     (smtp-send-command process "QUIT")
 501     (setq response (smtp-read-response process))
 502     (if (/= (car response) 221)
 503         (smtp-response-error response))))
 504
 505 ;;; @ low level process manipulating function
 506 ;;;
 507 (defun smtp-process-filter (process output)
 508   (save-excursion
 509     (set-buffer (process-buffer process))
 510     (goto-char (point-max))
 511     (insert output)))
 512
 513 (put 'smtp-error 'error-message "SMTP error")
 514 (put 'smtp-error 'error-conditions '(smtp-error error))
 515
 516 (put 'smtp-response-error 'error-message "SMTP response error")
 517 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 518
 519 (defun smtp-response-error (response)
 520   (signal 'smtp-response-error response))
 521
 522 (defun smtp-read-response (process)
 523   (let (case-fold-search
 524         (response-continue t)
 525         response)
 526     (while response-continue
 527       (goto-char smtp-read-point)
 528       (while (not (search-forward "\r\n" nil t))
 529         (accept-process-output process)
 530         (goto-char smtp-read-point))
 531       (setq response
 532             (nconc response
 533                    (list (buffer-substring
 534                           (+ 4 smtp-read-point)
 535                           (- (point) 2)))))
 536       (goto-char
 537        (prog1 smtp-read-point
 538          (setq smtp-read-point (point))))
 539       (if (looking-at "[1-5][0-9][0-9] ")
 540           (setq response (cons (read (point-marker)) response)
 541                 response-continue nil)))
 542     response))
 543
 544 (defun smtp-send-command (process command)
 545   (save-excursion
 546     (set-buffer (process-buffer process))
 547     (goto-char (point-max))
 548     (insert command "\r\n")
 549     (setq smtp-read-point (point))
 550     (process-send-string process command)
 551     (process-send-string process "\r\n")))
 552
 553 (defun smtp-send-data (process data)
 554   (save-excursion
 555     (set-buffer (process-buffer process))
 556     (goto-char (point-max))
 557     (setq smtp-read-point (point))
 558     ;; Escape "." at start of a line.
 559     (if (eq (string-to-char data) ?.)
 560         (process-send-string process "."))
 561     (process-send-string process data)
 562     (process-send-string process "\r\n")))
 563
 564 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 565   "Get address list suitable for smtp RCPT TO:<address>."
 566   (let ((simple-address-list "")
 567         this-line
 568         this-line-end
 569         addr-regexp
 570         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 571     (unwind-protect
 572         (save-excursion
 573           ;;
 574           (set-buffer smtp-address-buffer)
 575           (setq case-fold-search t)
 576           (erase-buffer)
 577           (insert (save-excursion
 578                     (set-buffer smtp-text-buffer)
 579                     (buffer-substring-no-properties header-start header-end)))
 580           (goto-char (point-min))
 581           ;; RESENT-* fields should stop processing of regular fields.
 582           (save-excursion
 583             (if (re-search-forward "^RESENT-TO:" header-end t)
 584                 (setq addr-regexp
 585                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 586               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 587
 588           (while (re-search-forward addr-regexp header-end t)
 589             (replace-match "")
 590             (setq this-line (match-beginning 0))
 591             (forward-line 1)
 592             ;; get any continuation lines.
 593             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 594               (forward-line 1))
 595             (setq this-line-end (point-marker))
 596             (setq simple-address-list
 597                   (concat simple-address-list " "
 598                           (mail-strip-quoted-names
 599                            (buffer-substring this-line this-line-end)))))
 600           (erase-buffer)
 601           (insert-string " ")
 602           (insert-string simple-address-list)
 603           (insert-string "\n")
 604           ;; newline --> blank
 605           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 606           ;; comma   --> blank
 607           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 608           ;; tab     --> blank
 609           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 610
 611           (goto-char (point-min))
 612           ;; tidyness in case hook is not robust when it looks at this
 613           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 614
 615           (goto-char (point-min))
 616           (let (recipient-address-list)
 617             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 618               (backward-char 1)
 619               (setq recipient-address-list
 620                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 621                           recipient-address-list)))
 622             recipient-address-list))
 623       (kill-buffer smtp-address-buffer))))
 624
 625 (provide 'smtp)
 626
 627 ;;; smtp.el ends here