smtp.el

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