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             (smtp-primitive-starttls package)
 300             (smtp-primitive-ehlo package)))
 301         (if smtp-use-sasl
 302             (smtp-primitive-auth package))
 303         (smtp-primitive-mailfrom package)
 304         (smtp-primitive-rcptto package)
 305         (smtp-primitive-data package))
 306     (let ((connection (smtp-find-connection (current-buffer))))
 307       (when (smtp-connection-opened connection)
 308         (smtp-primitive-quit package)
 309         (smtp-close-connection connection)))))
 310
 311 ;;; @ hook methods for `smtp-submit-package'
 312 ;;;
 313
 314 (defun smtp-primitive-greeting (package)
 315   (let* ((connection
 316           (smtp-find-connection (current-buffer)))
 317          (response
 318           (smtp-read-response connection)))
 319     (if (/= (car response) 220)
 320         (smtp-response-error response))))
 321
 322 (defun smtp-primitive-ehlo (package)
 323   (let* ((connection
 324           (smtp-find-connection (current-buffer)))
 325          response)
 326     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 327     (setq response (smtp-read-response connection))
 328     (if (/= (car response) 250)
 329         (smtp-response-error response))
 330     (smtp-connection-set-extensions-internal
 331      connection (mapcar
 332                  (lambda (extension)
 333                    (let ((extensions
 334                           (split-string extension)))
 335                      (setcar extensions
 336                              (car (read-from-string
 337                                    (downcase (car extensions)))))
 338                      extensions))
 339                  (cdr response)))))
 340
 341 (defun smtp-primitive-helo (package)
 342   (let* ((connection
 343           (smtp-find-connection (current-buffer)))
 344          response)
 345     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 346     (setq response (smtp-read-response connection))
 347     (if (/= (car response) 250)
 348         (smtp-response-error response))))
 349
 350 (defun smtp-primitive-auth (package)
 351   (let* ((connection
 352           (smtp-find-connection (current-buffer)))
 353          (mechanisms
 354           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 355          (sasl-mechanisms
 356           (or smtp-sasl-mechanisms sasl-mechanisms))
 357          (mechanism
 358           (sasl-find-mechanism mechanisms))
 359          client
 360          name
 361          step
 362          response)
 363     (unless mechanism
 364       (error "No authentication mechanism available"))
 365     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 366                                    (smtp-connection-server-internal connection)))
 367     (if smtp-sasl-properties
 368         (sasl-client-set-properties client smtp-sasl-properties))
 369     (setq name (sasl-mechanism-name mechanism)
 370           ;; Retrieve the initial response
 371           step (sasl-next-step client nil))
 372     (smtp-send-command
 373      connection
 374      (if (sasl-step-data step)
 375          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 376        (format "AUTH %s" name)))
 377     (catch 'done
 378       (while t
 379         (setq response (smtp-read-response connection))
 380         (when (= (car response) 235)
 381           ;; The authentication process is finished.
 382           (setq step (sasl-next-step client step))
 383           (if (null step)
 384               (throw 'done nil))
 385           (smtp-response-error response)) ;Bogus server?
 386         (if (/= (car response) 334)
 387             (smtp-response-error response))
 388         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 389         (setq step (sasl-next-step client step))
 390         (smtp-send-command
 391          connection
 392          (if (sasl-step-data step)
 393              (base64-encode-string (sasl-step-data step) t)
 394            ""))))
 395 ;;;    (smtp-connection-set-encoder-internal
 396 ;;;     connection (sasl-client-encoder client))
 397 ;;;    (smtp-connection-set-decoder-internal
 398 ;;;     connection (sasl-client-decoder client))
 399     ))
 400
 401 (defun smtp-primitive-starttls (package)
 402   (let* ((connection
 403           (smtp-find-connection (current-buffer)))
 404          response)
 405     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 406     (smtp-send-command connection "STARTTLS")
 407     (setq response (smtp-read-response connection))
 408     (if (/= (car response) 220)
 409         (smtp-response-error response))
 410     (starttls-negotiate (smtp-connection-process-internal connection))))
 411
 412 (defun smtp-primitive-mailfrom (package)
 413   (let* ((connection
 414           (smtp-find-connection (current-buffer)))
 415          (extensions
 416           (smtp-connection-extensions-internal
 417            connection))
 418          (sender
 419           (smtp-package-sender-internal package))
 420          extension
 421          response)
 422     ;; SIZE --- Message Size Declaration (RFC1870)
 423     (if (and smtp-use-size
 424              (assq 'size extensions))
 425         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 426     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 427     (if (and smtp-use-8bitmime
 428              (assq '8bitmime extensions))
 429         (setq extension (concat extension " BODY=8BITMIME")))
 430     (smtp-send-command
 431      connection
 432      (if extension
 433          (format "MAIL FROM:<%s> %s" sender extension)
 434        (format "MAIL FROM:<%s>" sender)))
 435     (setq response (smtp-read-response connection))
 436     (if (/= (car response) 250)
 437         (smtp-response-error response))))
 438
 439 (defun smtp-primitive-rcptto (package)
 440   (let* ((connection
 441           (smtp-find-connection (current-buffer)))
 442          (recipients
 443           (smtp-package-recipients-internal package))
 444          response)
 445     (while recipients
 446       (smtp-send-command
 447        connection (format "RCPT TO:<%s>" (pop recipients)))
 448       (setq response (smtp-read-response connection))
 449       (unless (memq (car response) '(250 251))
 450         (smtp-response-error response)))))
 451
 452 (defun smtp-primitive-data (package)
 453   (let* ((connection
 454           (smtp-find-connection (current-buffer)))
 455          response)
 456     (smtp-send-command connection "DATA")
 457     (setq response (smtp-read-response connection))
 458     (if (/= (car response) 354)
 459         (smtp-response-error response))
 460     (save-excursion
 461       (set-buffer (smtp-package-buffer-internal package))
 462       (goto-char (point-min))
 463       (while (not (eobp))
 464         (smtp-send-data
 465          connection (buffer-substring (point) (progn (end-of-line)(point))))
 466         (beginning-of-line 2)))
 467     (smtp-send-command connection ".")
 468     (setq response (smtp-read-response connection))
 469     (if (/= (car response) 250)
 470         (smtp-response-error response))))
 471
 472 (defun smtp-primitive-quit (package)
 473   (let* ((connection
 474           (smtp-find-connection (current-buffer)))
 475          response)
 476     (smtp-send-command connection "QUIT")
 477     (setq response (smtp-read-response connection))
 478     (if (/= (car response) 221)
 479         (smtp-response-error response))))
 480
 481 ;;; @ low level process manipulating function
 482 ;;;
 483 (defun smtp-process-filter (process output)
 484   (save-excursion
 485     (set-buffer (process-buffer process))
 486     (goto-char (point-max))
 487     (insert output)))
 488
 489 (put 'smtp-error 'error-message "SMTP error")
 490 (put 'smtp-error 'error-conditions '(smtp-error error))
 491
 492 (put 'smtp-response-error 'error-message "SMTP response error")
 493 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 494
 495 (defun smtp-response-error (response)
 496   (signal 'smtp-response-error response))
 497
 498 (defun smtp-read-response (connection)
 499   (let ((decoder
 500          (smtp-connection-decoder-internal connection))
 501         (response-continue t)
 502         response)
 503     (while response-continue
 504       (goto-char smtp-read-point)
 505       (while (not (search-forward "\r\n" nil t))
 506         (accept-process-output (smtp-connection-process-internal connection))
 507         (goto-char smtp-read-point))
 508       (if decoder
 509           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 510             (delete-region smtp-read-point (point))
 511             (insert (funcall decoder string) "\r\n")))
 512       (setq response
 513             (nconc response
 514                    (list (buffer-substring
 515                           (+ 4 smtp-read-point)
 516                           (- (point) 2)))))
 517       (goto-char
 518        (prog1 smtp-read-point
 519          (setq smtp-read-point (point))))
 520       (if (looking-at "[1-5][0-9][0-9] ")
 521           (setq response (cons (read (point-marker)) response)
 522                 response-continue nil)))
 523     response))
 524
 525 (defun smtp-send-command (connection command)
 526   (save-excursion
 527     (let ((process
 528            (smtp-connection-process-internal connection))
 529           (encoder
 530            (smtp-connection-encoder-internal connection)))
 531       (set-buffer (process-buffer process))
 532       (goto-char (point-max))
 533       (setq command (concat command "\r\n"))
 534       (insert command)
 535       (setq smtp-read-point (point))
 536       (if encoder
 537           (setq command (funcall encoder command)))
 538       (process-send-string process command))))
 539
 540 (defun smtp-send-data (connection data)
 541   (let ((process
 542          (smtp-connection-process-internal connection))
 543         (encoder
 544          (smtp-connection-encoder-internal connection)))
 545     ;; Escape "." at start of a line.
 546     (if (eq (string-to-char data) ?.)
 547         (setq data (concat "." data "\r\n"))
 548       (setq data (concat data "\r\n")))
 549     (if encoder
 550         (setq data (funcall encoder data)))
 551     (process-send-string process data)))
 552
 553 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 554   "Get address list suitable for smtp RCPT TO:<address>."
 555   (let ((simple-address-list "")
 556         this-line
 557         this-line-end
 558         addr-regexp
 559         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 560     (unwind-protect
 561         (save-excursion
 562           ;;
 563           (set-buffer smtp-address-buffer)
 564           (setq case-fold-search t)
 565           (erase-buffer)
 566           (insert (save-excursion
 567                     (set-buffer smtp-text-buffer)
 568                     (buffer-substring-no-properties header-start header-end)))
 569           (goto-char (point-min))
 570           ;; RESENT-* fields should stop processing of regular fields.
 571           (save-excursion
 572             (if (re-search-forward "^RESENT-TO:" header-end t)
 573                 (setq addr-regexp
 574                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 575               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 576
 577           (while (re-search-forward addr-regexp header-end t)
 578             (replace-match "")
 579             (setq this-line (match-beginning 0))
 580             (forward-line 1)
 581             ;; get any continuation lines.
 582             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 583               (forward-line 1))
 584             (setq this-line-end (point-marker))
 585             (setq simple-address-list
 586                   (concat simple-address-list " "
 587                           (mail-strip-quoted-names
 588                            (buffer-substring this-line this-line-end)))))
 589           (erase-buffer)
 590           (insert-string " ")
 591           (insert-string simple-address-list)
 592           (insert-string "\n")
 593           ;; newline --> blank
 594           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 595           ;; comma   --> blank
 596           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 597           ;; tab     --> blank
 598           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 599
 600           (goto-char (point-min))
 601           ;; tidyness in case hook is not robust when it looks at this
 602           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 603
 604           (goto-char (point-min))
 605           (let (recipient-address-list)
 606             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 607               (backward-char 1)
 608               (setq recipient-address-list
 609                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 610                           recipient-address-list)))
 611             recipient-address-list))
 612       (kill-buffer smtp-address-buffer))))
 613
 614 (provide 'smtp)
 615
 616 ;;; smtp.el ends here