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 'custom)
  36 (require 'mail-utils)                   ; mail-strip-quoted-names
  37 (require 'sasl)
  38 (require 'luna)
  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 (defvar smtp-open-connection-function #'open-network-stream)
 117
 118 (defvar smtp-read-point nil)
 119
 120 (defvar smtp-connection-alist nil)
 121
 122 (defvar smtp-submit-package-function #'smtp-submit-package)
 123
 124 ;;; @ SMTP package
 125 ;;; A package contains a mail message, an envelope sender address,
 126 ;;; and one or more envelope recipient addresses.  In ESMTP model
 127 ;;; the current sending package should be guaranteed to be accessible
 128 ;;; anywhere from the hook methods (or SMTP commands).
 129
 130 (eval-and-compile
 131   (luna-define-class smtp-package ()
 132                      (sender
 133                       recipients
 134                       buffer))
 135
 136   (luna-define-internal-accessors 'smtp-package))
 137
 138 (defun smtp-make-package (sender recipients buffer)
 139   "Create a new package structure.
 140 A package is a unit of SMTP message
 141 SENDER specifies the package sender, a string.
 142 RECIPIENTS is a list of recipients.
 143 BUFFER may be a buffer or a buffer name which contains mail message."
 144   (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
 145
 146 (defun smtp-package-buffer-internal-size (package)
 147   "Return the size of PACKAGE, an integer."
 148   (save-excursion
 149     (set-buffer (smtp-package-buffer-internal package))
 150     (let ((size
 151            (+ (buffer-size)
 152               ;; Add one byte for each change-of-line
 153               ;; because or CR-LF representation:
 154               (count-lines (point-min) (point-max))
 155               ;; For some reason, an empty line is
 156               ;; added to the message.  Maybe this
 157               ;; is a bug, but it can't hurt to add
 158               ;; those two bytes anyway:
 159               2)))
 160       (goto-char (point-min))
 161       (while (re-search-forward "^\\." nil t)
 162         (setq size (1+ size)))
 163       size)))
 164
 165 ;;; @ SMTP connection
 166 ;;; We should consider the function `open-network-stream' is a emulation
 167 ;;; for another network stream.  They are likely to be implemented with an
 168 ;;; external program and the function `process-contact' returns the
 169 ;;; process id instead of `(HOST SERVICE)' pair.
 170
 171 (eval-and-compile
 172   (luna-define-class smtp-connection ()
 173                      (process
 174                       server
 175                       service
 176                       extensions
 177                       encoder
 178                       decoder))
 179
 180   (luna-define-internal-accessors 'smtp-connection))
 181
 182 (defun smtp-make-connection (process server service)
 183   "Create a new connection structure.
 184 PROCESS is an internal subprocess-object.  SERVER is name of the host
 185 to connect to.  SERVICE is name of the service desired."
 186   (luna-make-entity 'smtp-connection :process process :server server :service service))
 187
 188 (luna-define-generic smtp-connection-opened (connection)
 189   "Say whether the CONNECTION to server has been opened.")
 190
 191 (luna-define-generic smtp-close-connection (connection)
 192   "Close the CONNECTION to server.")
 193
 194 (luna-define-method smtp-connection-opened ((connection smtp-connection))
 195   (let ((process (smtp-connection-process-internal connection)))
 196     (if (memq (process-status process) '(open run))
 197         t)))
 198
 199 (luna-define-method smtp-close-connection ((connection smtp-connection))
 200   (let ((process (smtp-connection-process-internal connection)))
 201     (delete-process process)))
 202
 203 (defun smtp-make-fqdn ()
 204   "Return user's fully qualified domain name."
 205   (if smtp-fqdn
 206       smtp-fqdn
 207     (let ((system-name (system-name)))
 208       (cond
 209        (smtp-local-domain
 210         (concat system-name "." smtp-local-domain))
 211        ((string-match "[^.]\\.[^.]" system-name)
 212         system-name)
 213        (t
 214         (error "Cannot generate valid FQDN"))))))
 215
 216 (defun smtp-find-connection (buffer)
 217   "Find the connection delivering to BUFFER."
 218   (let ((entry (assq buffer smtp-connection-alist))
 219         connection)
 220     (when entry
 221       (setq connection (nth 1 entry))
 222       (if (smtp-connection-opened connection)
 223           connection
 224         (setq smtp-connection-alist
 225               (delq entry smtp-connection-alist))
 226         nil))))
 227
 228 (eval-and-compile
 229   (autoload 'starttls-open-stream "starttls")
 230   (autoload 'starttls-negotiate "starttls"))
 231
 232 (defun smtp-open-connection (buffer server service)
 233   "Open a SMTP connection for a service to a host.
 234 Return a newly allocated connection-object.
 235 BUFFER is the buffer to associate with the connection.  SERVER is name
 236 of the host to connect to.  SERVICE is name of the service desired."
 237   (let ((process
 238          (as-binary-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