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 'custom)
  35 (require 'mail-utils)                   ; mail-strip-quoted-names
  36 (require 'sasl)
  37 (require 'luna)
  38
  39 (defgroup smtp nil
  40   "SMTP protocol for sending mail."
  41   :group 'mail)
  42
  43 (defgroup smtp-extensions nil
  44   "SMTP service extensions (RFC1869)."
  45   :group 'smtp)
  46
  47 (defcustom smtp-default-server nil
  48   "Specify default SMTP server."
  49   :type '(choice (const nil) string)
  50   :group 'smtp)
  51
  52 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  53   "The name of the host running SMTP server.
  54 It can also be a function
  55 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  56   :type '(choice (string :tag "Name")
  57                  (function :tag "Function"))
  58   :group 'smtp)
  59
  60 (defcustom smtp-service "smtp"
  61   "SMTP service port number.  \"smtp\" or 25."
  62   :type '(choice (integer :tag "25" 25)
  63                  (string :tag "smtp" "smtp"))
  64   :group 'smtp)
  65
  66 (defcustom smtp-local-domain nil
  67   "Local domain name without a host name.
  68 If the function (system-name) returns the full internet address,
  69 don't define this value."
  70   :type '(choice (const nil) string)
  71   :group 'smtp)
  72
  73 (defcustom smtp-fqdn nil
  74   "Fully qualified domain name used for Message-ID."
  75   :type '(choice (const nil) string)
  76   :group 'smtp)
  77
  78 (defcustom smtp-use-8bitmime t
  79   "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
  80   :type 'boolean
  81   :group 'smtp-extensions)
  82
  83 (defcustom smtp-use-size t
  84   "If non-nil, use ESMTP SIZE (RFC1870) if available."
  85   :type 'boolean
  86   :group 'smtp-extensions)
  87
  88 (defcustom smtp-use-starttls nil
  89   "If non-nil, use STARTTLS (RFC2595) if available."
  90   :type 'boolean
  91   :group 'smtp-extensions)
  92
  93 (defcustom smtp-use-sasl nil
  94   "If non-nil, use SMTP Authentication (RFC2554) if available."
  95   :type 'boolean
  96   :group 'smtp-extensions)
  97
  98 (defcustom smtp-sasl-user-name (user-login-name)
  99   "Identification to be used for authorization."
 100   :type 'string
 101   :group 'smtp-extensions)
 102
 103 (defcustom smtp-sasl-properties nil
 104   "Properties set to SASL client."
 105   :type 'string
 106   :group 'smtp-extensions)
 107
 108 (defcustom smtp-sasl-mechanisms nil
 109   "List of authentication mechanisms."
 110   :type '(repeat string)
 111   :group 'smtp-extensions)
 112
 113 (defvar sasl-mechanisms)
 114
 115 (autoload 'binary-open-network-stream "raw-io")
 116 ;;;###autoload
 117 (defvar smtp-open-connection-function #'binary-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          (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   (condition-case nil
 253       (progn
 254         (smtp-send-buffer sender recipients buffer)
 255         t)
 256     (smtp-error)))
 257
 258 (make-obsolete 'smtp-via-smtp "It's old API.")
 259
 260 ;;;###autoload
 261 (defun smtp-send-buffer (sender recipients buffer)
 262   (let ((server
 263          (if (functionp smtp-server)
 264              (funcall smtp-server sender recipients)
 265            smtp-server))
 266         (package
 267          (smtp-make-package sender recipients buffer))
 268         (smtp-open-connection-function
 269          (if smtp-use-starttls
 270              #'starttls-open-stream
 271            smtp-open-connection-function)))
 272     (save-excursion
 273       (set-buffer
 274        (get-buffer-create
 275         (format "*trace of SMTP session to %s*" server)))
 276       (erase-buffer)
 277       (buffer-disable-undo)
 278       (unless (smtp-find-connection (current-buffer))
 279         (smtp-open-connection (current-buffer) server smtp-service))
 280       (make-local-variable 'smtp-read-point)
 281       (setq smtp-read-point (point-min))
 282       (funcall smtp-submit-package-function package))))
 283
 284 (defun smtp-submit-package (package)
 285   (unwind-protect
 286       (progn
 287         (smtp-primitive-greeting package)
 288         (condition-case nil
 289             (smtp-primitive-ehlo package)
 290           (smtp-response-error
 291            (smtp-primitive-helo package)))
 292         (if smtp-use-starttls
 293             (smtp-primitive-starttls package))
 294         (if smtp-use-sasl
 295             (smtp-primitive-auth package))
 296         (smtp-primitive-mailfrom package)
 297         (smtp-primitive-rcptto package)
 298         (smtp-primitive-data package))
 299     (let ((connection (smtp-find-connection (current-buffer))))
 300       (when (smtp-connection-opened connection)
 301         (smtp-primitive-quit package)
 302         (smtp-close-connection connection)))))
 303
 304 ;;; @ hook methods for `smtp-submit-package'
 305 ;;;
 306
 307 (defun smtp-primitive-greeting (package)
 308   (let* ((connection
 309           (smtp-find-connection (current-buffer)))
 310          (response
 311           (smtp-read-response connection)))
 312     (if (/= (car response) 220)
 313         (smtp-response-error response))))
 314
 315 (defun smtp-primitive-ehlo (package)
 316   (let* ((connection
 317           (smtp-find-connection (current-buffer)))
 318          response)
 319     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 320     (setq response (smtp-read-response connection))
 321     (if (/= (car response) 250)
 322         (smtp-response-error response))
 323     (smtp-connection-set-extensions-internal
 324      connection (mapcar
 325                  (lambda (extension)
 326                    (let ((extensions
 327                           (split-string extension)))
 328                      (setcar extensions
 329                              (car (read-from-string
 330                                    (downcase (car extensions)))))
 331                      extensions))
 332                  (cdr response)))))
 333
 334 (defun smtp-primitive-helo (package)
 335   (let* ((connection
 336           (smtp-find-connection (current-buffer)))
 337          response)
 338     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 339     (setq response (smtp-read-response connection))
 340     (if (/= (car response) 250)
 341         (smtp-response-error response))))
 342
 343 (defun smtp-primitive-auth (package)
 344   (let* ((connection
 345           (smtp-find-connection (current-buffer)))
 346          (mechanisms
 347           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 348          (sasl-mechanisms
 349           (or smtp-sasl-mechanisms sasl-mechanisms))
 350          (mechanism
 351           (sasl-find-mechanism mechanisms))
 352          client
 353          name
 354          step
 355          response)
 356     (unless mechanism
 357       (error "No authentication mechanism available"))
 358     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 359                                    (smtp-connection-server-internal connection)))
 360     (if smtp-sasl-properties
 361         (sasl-client-set-properties client smtp-sasl-properties))
 362     (setq name (sasl-mechanism-name mechanism)
 363           ;; Retrieve the initial response
 364           step (sasl-next-step client nil))
 365     (smtp-send-command
 366      connection
 367      (if (sasl-step-data step)
 368          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 369        (format "AUTH %s" name)))
 370     (catch 'done
 371       (while t
 372         (setq response (smtp-read-response connection))
 373         (when (= (car response) 235)
 374           ;; The authentication process is finished.
 375           (setq step (sasl-next-step client step))
 376           (if (null step)
 377               (throw 'done nil))
 378           (smtp-response-error response)) ;Bogus server?
 379         (if (/= (car response) 334)
 380             (smtp-response-error response))
 381         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 382         (setq step (sasl-next-step client step))
 383         (smtp-send-command
 384          connection
 385          (if (sasl-step-data step)
 386              (base64-encode-string (sasl-step-data step) t)
 387            ""))))
 388 ;;;    (smtp-connection-set-encoder-internal
 389 ;;;     connection (sasl-client-encoder client))
 390 ;;;    (smtp-connection-set-decoder-internal
 391 ;;;     connection (sasl-client-decoder client))
 392     ))
 393
 394 (defun smtp-primitive-starttls (package)
 395   (let* ((connection
 396           (smtp-find-connection (current-buffer)))
 397          response)
 398     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 399     (smtp-send-command connection "STARTTLS")
 400     (setq response (smtp-read-response connection))
 401     (if (/= (car response) 220)
 402         (smtp-response-error response))
 403     (starttls-negotiate (smtp-connection-process-internal connection))))
 404
 405 (defun smtp-primitive-mailfrom (package)
 406   (let* ((connection
 407           (smtp-find-connection (current-buffer)))
 408          (extensions
 409           (smtp-connection-extensions-internal
 410            connection))
 411          (sender
 412           (smtp-package-sender-internal package))
 413          extension
 414          response)
 415     ;; SIZE --- Message Size Declaration (RFC1870)
 416     (if (and smtp-use-size
 417              (assq 'size extensions))
 418         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 419     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 420     (if (and smtp-use-8bitmime
 421              (assq '8bitmime extensions))
 422         (setq extension (concat extension " BODY=8BITMIME")))
 423     (smtp-send-command
 424      connection
 425      (if extension
 426          (format "MAIL FROM:<%s> %s" sender extension)
 427        (format "MAIL FROM:<%s>" sender)))
 428     (setq response (smtp-read-response connection))
 429     (if (/= (car response) 250)
 430         (smtp-response-error response))))
 431
 432 (defun smtp-primitive-rcptto (package)
 433   (let* ((connection
 434           (smtp-find-connection (current-buffer)))
 435          (recipients
 436           (smtp-package-recipients-internal package))
 437          response)
 438     (while recipients
 439       (smtp-send-command
 440        connection (format "RCPT TO:<%s>" (pop recipients)))
 441       (setq response (smtp-read-response connection))
 442       (unless (memq (car response) '(250 251))
 443         (smtp-response-error response)))))
 444
 445 (defun smtp-primitive-data (package)
 446   (let* ((connection
 447           (smtp-find-connection (current-buffer)))
 448          response)
 449     (smtp-send-command connection "DATA")
 450     (setq response (smtp-read-response connection))
 451     (if (/= (car response) 354)
 452         (smtp-response-error response))
 453     (save-excursion
 454       (set-buffer (smtp-package-buffer-internal package))
 455       (goto-char (point-min))
 456       (while (not (eobp))
 457         (smtp-send-data
 458          connection (buffer-substring (point) (progn (end-of-line)(point))))
 459         (beginning-of-line 2)))
 460     (smtp-send-command connection ".")
 461     (setq response (smtp-read-response connection))
 462     (if (/= (car response) 250)
 463         (smtp-response-error response))))
 464
 465 (defun smtp-primitive-quit (package)
 466   (let* ((connection
 467           (smtp-find-connection (current-buffer)))
 468          response)
 469     (smtp-send-command connection "QUIT")
 470     (setq response (smtp-read-response connection))
 471     (if (/= (car response) 221)
 472         (smtp-response-error response))))
 473
 474 ;;; @ low level process manipulating function
 475 ;;;
 476 (defun smtp-process-filter (process output)
 477   (save-excursion
 478     (set-buffer (process-buffer process))
 479     (goto-char (point-max))
 480     (insert output)))
 481
 482 (put 'smtp-error 'error-message "SMTP error")
 483 (put 'smtp-error 'error-conditions '(smtp-error error))
 484
 485 (put 'smtp-response-error 'error-message "SMTP response error")
 486 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 487
 488 (defun smtp-response-error (response)
 489   (signal 'smtp-response-error response))
 490
 491 (defun smtp-read-response (connection)
 492   (let ((decoder
 493          (smtp-connection-decoder-internal connection))
 494         (response-continue t)
 495         response)
 496     (while response-continue
 497       (goto-char smtp-read-point)
 498       (while (not (search-forward "\r\n" nil t))
 499         (accept-process-output (smtp-connection-process-internal connection))
 500         (goto-char smtp-read-point))
 501       (if decoder
 502           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 503             (delete-region smtp-read-point (point))
 504             (insert (funcall decoder string) "\r\n")))
 505       (setq response
 506             (nconc response
 507                    (list (buffer-substring
 508                           (+ 4 smtp-read-point)
 509                           (- (point) 2)))))
 510       (goto-char
 511        (prog1 smtp-read-point
 512          (setq smtp-read-point (point))))
 513       (if (looking-at "[1-5][0-9][0-9] ")
 514           (setq response (cons (read (point-marker)) response)
 515                 response-continue nil)))
 516     response))
 517
 518 (defun smtp-send-command (connection command)
 519   (save-excursion
 520     (let ((process
 521            (smtp-connection-process-internal connection))
 522           (encoder
 523            (smtp-connection-encoder-internal connection)))
 524       (set-buffer (process-buffer process))
 525       (goto-char (point-max))
 526       (setq command (concat command "\r\n"))
 527       (insert command)
 528       (setq smtp-read-point (point))
 529       (if encoder
 530           (setq command (funcall encoder command)))
 531       (process-send-string process command))))
 532
 533 (defun smtp-send-data (connection data)
 534   (let ((process
 535          (smtp-connection-process-internal connection))
 536         (encoder
 537          (smtp-connection-encoder-internal connection)))
 538     ;; Escape "." at start of a line.
 539     (if (eq (string-to-char data) ?.)
 540         (setq data (concat "." data "\r\n"))
 541       (setq data (concat data "\r\n")))
 542     (if encoder
 543         (setq data (funcall encoder data)))
 544     (process-send-string process data)))
 545
 546 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 547   "Get address list suitable for smtp RCPT TO:<address>."
 548   (let ((simple-address-list "")
 549         this-line
 550         this-line-end
 551         addr-regexp
 552         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 553     (unwind-protect
 554         (save-excursion
 555           ;;
 556           (set-buffer smtp-address-buffer)
 557           (setq case-fold-search t)
 558           (erase-buffer)
 559           (insert (save-excursion
 560                     (set-buffer smtp-text-buffer)
 561                     (buffer-substring-no-properties header-start header-end)))
 562           (goto-char (point-min))
 563           ;; RESENT-* fields should stop processing of regular fields.
 564           (save-excursion
 565             (if (re-search-forward "^RESENT-TO:" header-end t)
 566                 (setq addr-regexp
 567                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 568               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 569
 570           (while (re-search-forward addr-regexp header-end t)
 571             (replace-match "")
 572             (setq this-line (match-beginning 0))
 573             (forward-line 1)
 574             ;; get any continuation lines.
 575             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 576               (forward-line 1))
 577             (setq this-line-end (point-marker))
 578             (setq simple-address-list
 579                   (concat simple-address-list " "
 580                           (mail-strip-quoted-names
 581                            (buffer-substring this-line this-line-end)))))
 582           (erase-buffer)
 583           (insert-string " ")
 584           (insert-string simple-address-list)
 585           (insert-string "\n")
 586           ;; newline --> blank
 587           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 588           ;; comma   --> blank
 589           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 590           ;; tab     --> blank
 591           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 592
 593           (goto-char (point-min))
 594           ;; tidyness in case hook is not robust when it looks at this
 595           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 596
 597           (goto-char (point-min))
 598           (let (recipient-address-list)
 599             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 600               (backward-char 1)
 601               (setq recipient-address-list
 602                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 603                           recipient-address-list)))
 604             recipient-address-list))
 605       (kill-buffer smtp-address-buffer))))
 606
 607 (provide 'smtp)
 608
 609 ;;; smtp.el ends here