smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;;      Simon Leinen <simon@switch.ch> (ESMTP support)
   7 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   8 ;;      Daiki Ueno <ueno@unixuser.org>
   9 ;; Keywords: SMTP, mail
  10
  11 ;; This file is part of FLIM (Faithful Library about Internet Message).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28
  29 ;;; Commentary:
  30 ;;
  31
  32 ;;; Code:
  33
  34 (require 'pces)
  35 (require 'pcustom)
  36 (require 'mail-utils)                   ; mail-strip-quoted-names
  37 (require 'sasl)
  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 (defvar smtp-open-connection-function #'open-network-stream)
 116
 117 (defvar smtp-read-point nil)
 118
 119 (defvar smtp-connection-alist nil)
 120
 121 (defvar smtp-submit-package-function #'smtp-submit-package)
 122
 123 ;;; @ SMTP package structure
 124 ;;; A package contains a mail message, an envelope sender address,
 125 ;;; and one or more envelope recipient addresses.  In ESMTP model
 126 ;;; the current sending package should be guaranteed to be accessible
 127 ;;; anywhere from the hook methods (or SMTP commands).
 128
 129 (defmacro smtp-package-sender (package)
 130   "Return the sender of PACKAGE, a string."
 131   `(aref ,package 0))
 132
 133 (defmacro smtp-package-recipients (package)
 134   "Return the recipients of PACKAGE, a list of strings."
 135   `(aref ,package 1))
 136
 137 (defmacro smtp-package-buffer (package)
 138   "Return the data of PACKAGE, a buffer."
 139   `(aref ,package 2))
 140
 141 (defmacro smtp-make-package (sender recipients buffer)
 142   "Create a new package structure.
 143 A package is a unit of SMTP message
 144 SENDER specifies the package sender, a string.
 145 RECIPIENTS is a list of recipients.
 146 BUFFER may be a buffer or a buffer name which contains mail message."
 147   `(vector ,sender ,recipients ,buffer))
 148
 149 (defun smtp-package-buffer-size (package)
 150   "Return the size of PACKAGE, an integer."
 151   (save-excursion
 152     (set-buffer (smtp-package-buffer package))
 153     (let ((size
 154            (+ (buffer-size)
 155               ;; Add one byte for each change-of-line
 156               ;; because or CR-LF representation:
 157               (count-lines (point-min) (point-max))
 158               ;; For some reason, an empty line is
 159               ;; added to the message.  Maybe this
 160               ;; is a bug, but it can't hurt to add
 161               ;; those two bytes anyway:
 162               2)))
 163       (goto-char (point-min))
 164       (while (re-search-forward "^\\." nil t)
 165         (setq size (1+ size)))
 166       size)))
 167
 168 ;;; @ SMTP connection structure
 169 ;;; We should consider the function `open-network-stream' is a emulation
 170 ;;; for another network stream.  They are likely to be implemented with an
 171 ;;; external program and the function `process-contact' returns the
 172 ;;; process id instead of `(HOST SERVICE)' pair.
 173
 174 (defmacro smtp-connection-process (connection)
 175   "Return the subprocess-object of CONNECTION."
 176   `(aref ,connection 0))
 177
 178 (defmacro smtp-connection-server (connection)
 179   "Return the server of CONNECTION, a string."
 180   `(aref ,connection 1))
 181
 182 (defmacro smtp-connection-service (connection)
 183   "Return the service of CONNECTION, a string or an integer."
 184   `(aref ,connection 2))
 185
 186 (defmacro smtp-connection-extensions (connection)
 187   "Return the SMTP extensions of CONNECTION, a list of strings."
 188   `(aref ,connection 3))
 189
 190 (defmacro smtp-connection-set-extensions (connection extensions)
 191   "Set the SMTP extensions of CONNECTION.
 192 EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS).
 193 Where EXTENSION is a symbol and PARAMETERS is a list of strings."
 194   `(aset ,connection 3 ,extensions))
 195
 196 (defmacro smtp-make-connection (process server service)
 197   "Create a new connection structure.
 198 PROCESS is an internal subprocess-object.  SERVER is name of the host
 199 to connect to.  SERVICE is name of the service desired."
 200   `(vector ,process ,server ,service nil))
 201
 202 (defun smtp-connection-opened (connection)
 203   "Say whether the CONNECTION to server has been opened."
 204   (let ((process (smtp-connection-process connection)))
 205     (if (memq (process-status process) '(open run))
 206         t)))
 207
 208 (defun smtp-close-connection (connection)
 209   "Close the CONNECTION to server."
 210   (let ((process (smtp-connection-process connection)))
 211     (delete-process process)))
 212
 213 (defun smtp-make-fqdn ()
 214   "Return user's fully qualified domain name."
 215   (if smtp-fqdn
 216       smtp-fqdn
 217     (let ((system-name (system-name)))
 218       (cond
 219        (smtp-local-domain
 220         (concat system-name "." smtp-local-domain))
 221        ((string-match "[^.]\\.[^.]" system-name)
 222         system-name)
 223        (t
 224         (error "Cannot generate valid FQDN"))))))
 225
 226 (defun smtp-find-connection (buffer)
 227   "Find the connection delivering to BUFFER."
 228   (let ((entry (assq buffer smtp-connection-alist))
 229         connection)
 230     (when entry
 231       (setq connection (nth 1 entry))
 232       (if (smtp-connection-opened connection)
 233           connection
 234         (setq smtp-connection-alist
 235               (delq entry smtp-connection-alist))
 236         nil))))
 237
 238 (eval-and-compile
 239   (autoload 'starttls-open-stream "starttls")
 240   (autoload 'starttls-negotiate "starttls"))
 241
 242 (defun smtp-open-connection (buffer server service)
 243   "Open a SMTP connection for a service to a host.
 244 Return a newly allocated connection-object.
 245 BUFFER is the buffer to associate with the connection.  SERVER is name
 246 of the host to connect to.  SERVICE is name of the service desired."
 247   (let ((process
 248          (as-binary-process
 249           (funcall smtp-open-connection-function
 250                    "SMTP" buffer  server service)))
 251         connection)
 252     (when process
 253       (setq connection (smtp-make-connection process server service))
 254       (set-process-filter process 'smtp-process-filter)
 255       (setq smtp-connection-alist
 256             (cons (list buffer connection)
 257                   smtp-connection-alist))
 258       connection)))
 259
 260 ;;;###autoload
 261 (defun smtp-via-smtp (sender recipients buffer)
 262   (condition-case nil
 263       (progn
 264         (smtp-send-buffer sender recipients buffer)
 265         t)
 266     (smtp-error)))
 267
 268 (make-obsolete 'smtp-via-smtp "It's old API.")
 269
 270 ;;;###autoload
 271 (defun smtp-send-buffer (sender recipients buffer)
 272   (let ((server
 273          (if (functionp smtp-server)
 274              (funcall smtp-server sender recipients)
 275            smtp-server))
 276         (package
 277          (smtp-make-package sender recipients buffer))
 278         (smtp-open-connection-function
 279          (if smtp-use-starttls
 280              #'starttls-open-stream
 281            smtp-open-connection-function)))
 282     (save-excursion
 283       (set-buffer
 284        (get-buffer-create
 285         (format "*trace of SMTP session to %s*" server)))
 286       (erase-buffer)
 287       (buffer-disable-undo)
 288       (unless (smtp-find-connection (current-buffer))
 289         (smtp-open-connection (current-buffer) server smtp-service))
 290       (make-local-variable 'smtp-read-point)
 291       (setq smtp-read-point (point-min))
 292       (funcall smtp-submit-package-function package))))
 293
 294 (defun smtp-submit-package (package)
 295   (unwind-protect
 296       (progn
 297         (smtp-primitive-greeting package)
 298         (condition-case nil
 299             (smtp-primitive-ehlo package)
 300           (smtp-response-error
 301            (smtp-primitive-helo package)))
 302         (if smtp-use-starttls
 303             (smtp-primitive-starttls package))
 304         (if smtp-use-sasl
 305             (smtp-primitive-auth package))
 306         (smtp-primitive-mailfrom package)
 307         (smtp-primitive-rcptto package)
 308         (smtp-primitive-data package))
 309     (let ((connection (smtp-find-connection (current-buffer))))
 310       (when (smtp-connection-opened connection)
 311         (smtp-primitive-quit package)
 312         (smtp-close-connection connection)))))
 313
 314 ;;; @ hook methods for `smtp-submit-package'
 315 ;;;
 316
 317 (defun smtp-primitive-greeting (package)
 318   (let* ((connection
 319           (smtp-find-connection (current-buffer)))
 320          (response
 321           (smtp-read-response
 322            (smtp-connection-process connection))))
 323     (if (/= (car response) 220)
 324         (smtp-response-error response))))
 325
 326 (defun smtp-primitive-ehlo (package)
 327   (let* ((connection
 328           (smtp-find-connection (current-buffer)))
 329          (process
 330           (smtp-connection-process connection))
 331          response)
 332     (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn)))
 333     (setq response (smtp-read-response process))
 334     (if (/= (car response) 250)
 335         (smtp-response-error response))
 336     (smtp-connection-set-extensions
 337      connection (mapcar
 338                  (lambda (extension)
 339                    (let ((extensions
 340                           (split-string extension)))
 341                      (setcar extensions
 342                              (car (read-from-string
 343                                    (downcase (car extensions)))))
 344                      extensions))
 345                  (cdr response)))))
 346
 347 (defun smtp-primitive-helo (package)
 348   (let* ((connection
 349           (smtp-find-connection (current-buffer)))
 350          (process
 351           (smtp-connection-process connection))
 352          response)
 353     (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
 354     (setq response (smtp-read-response process))
 355     (if (/= (car response) 250)
 356         (smtp-response-error response))))
 357
 358 (defun smtp-primitive-auth (package)
 359   (let* ((connection
 360           (smtp-find-connection (current-buffer)))
 361          (process
 362           (smtp-connection-process connection))
 363          (mechanisms
 364           (cdr (assq 'auth (smtp-connection-extensions connection))))
 365          (sasl-mechanisms
 366           (or smtp-sasl-mechanisms sasl-mechanisms))
 367          (mechanism
 368           (sasl-find-mechanism mechanisms))
 369          client
 370          name
 371          step
 372          response)
 373     (unless mechanism
 374       (error "No authentication mechanism available"))
 375     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 376                                    (smtp-connection-server connection)))
 377     (if smtp-sasl-properties
 378         (sasl-client-set-properties client smtp-sasl-properties))
 379     (setq name (sasl-mechanism-name mechanism)
 380           ;; Retrieve the initial response
 381           step (sasl-next-step client nil))
 382     (smtp-send-command
 383      process
 384      (if (sasl-step-data step)
 385          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 386        (format "AUTH %s" name)))
 387     (catch 'done
 388       (while t
 389         (setq response (smtp-read-response process))
 390         (when (= (car response) 235)
 391           ;; The authentication process is finished.
 392           (setq step (sasl-next-step client step))
 393           (if (null step)
 394               (throw 'done nil))
 395           (smtp-response-error response)) ;Bogus server?
 396         (if (/= (car response) 334)
 397             (smtp-response-error response))
 398         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 399         (setq step (sasl-next-step client step))
 400         (smtp-send-command
 401          process (if (sasl-step-data step)
 402                      (base64-encode-string (sasl-step-data step) t)
 403                    ""))))))
 404
 405 (defun smtp-primitive-starttls (package)
 406   (let* ((connection
 407           (smtp-find-connection (current-buffer)))
 408          (process
 409           (smtp-connection-process connection))
 410          response)
 411     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 412     (smtp-send-command process "STARTTLS")
 413     (setq response (smtp-read-response process))
 414     (if (/= (car response) 220)
 415         (smtp-response-error response))
 416     (starttls-negotiate process)
 417     ;; for sendmail warning XXX
 418     (smtp-primitive-helo package)))
 419
 420 (defun smtp-primitive-mailfrom (package)
 421   (let* ((connection
 422           (smtp-find-connection (current-buffer)))
 423          (process
 424           (smtp-connection-process connection))
 425          (extensions
 426           (smtp-connection-extensions
 427            connection))
 428          (sender
 429           (smtp-package-sender package))
 430          extension
 431          response)
 432     ;; SIZE --- Message Size Declaration (RFC1870)
 433     (if (and smtp-use-size
 434              (assq 'size extensions))
 435         (setq extension (format "SIZE=%d" (smtp-package-buffer-size package))))
 436     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 437     (if (and smtp-use-8bitmime
 438              (assq '8bitmime extensions))
 439         (setq extension (concat extension " BODY=8BITMIME")))
 440     (smtp-send-command
 441      process
 442      (if extension
 443          (format "MAIL FROM:<%s> %s" sender extension)
 444        (format "MAIL FROM:<%s>" sender)))
 445     (setq response (smtp-read-response process))
 446     (if (/= (car response) 250)
 447         (smtp-response-error response))))
 448
 449 (defun smtp-primitive-rcptto (package)
 450   (let* ((connection
 451           (smtp-find-connection (current-buffer)))
 452          (process
 453           (smtp-connection-process connection))
 454          (recipients
 455           (smtp-package-recipients package))
 456          response)
 457     (while recipients
 458       (smtp-send-command
 459        process (format "RCPT TO:<%s>" (pop recipients)))
 460       (setq response (smtp-read-response process))
 461       (unless (memq (car response) '(250 251))
 462         (smtp-response-error response)))))
 463
 464 (defun smtp-primitive-data (package)
 465   (let* ((connection
 466           (smtp-find-connection (current-buffer)))
 467          (process
 468           (smtp-connection-process connection))
 469          response)
 470     (smtp-send-command process "DATA")
 471     (setq response (smtp-read-response process))
 472     (if (/= (car response) 354)
 473         (smtp-response-error response))
 474     (save-excursion
 475       (set-buffer (smtp-package-buffer package))
 476       (goto-char (point-min))
 477       (while (not (eobp))
 478         (smtp-send-data
 479          process (buffer-substring (point) (progn (end-of-line)(point))))
 480         (beginning-of-line 2)))
 481     (smtp-send-command process ".")
 482     (setq response (smtp-read-response process))
 483     (if (/= (car response) 250)
 484         (smtp-response-error response))))
 485
 486 (defun smtp-primitive-quit (package)
 487   (let* ((connection
 488           (smtp-find-connection (current-buffer)))
 489          (process
 490           (smtp-connection-process connection))
 491          response)
 492     (smtp-send-command process "QUIT")
 493     (setq response (smtp-read-response process))
 494     (if (/= (car response) 221)
 495         (smtp-response-error response))))
 496
 497 ;;; @ low level process manipulating function
 498 ;;;
 499 (defun smtp-process-filter (process output)
 500   (save-excursion
 501     (set-buffer (process-buffer process))
 502     (goto-char (point-max))
 503     (insert output)))
 504
 505 (put 'smtp-error 'error-message "SMTP error")
 506 (put 'smtp-error 'error-conditions '(smtp-error error))
 507
 508 (put 'smtp-response-error 'error-message "SMTP response error")
 509 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 510
 511 (defun smtp-response-error (response)
 512   (signal 'smtp-response-error response))
 513
 514 (defun smtp-read-response (process)
 515   (let ((response-continue t)
 516         response)
 517     (while response-continue
 518       (goto-char smtp-read-point)
 519       (while (not (search-forward "\r\n" nil t))
 520         (accept-process-output process)
 521         (goto-char smtp-read-point))
 522       (setq response
 523             (nconc response
 524                    (list (buffer-substring
 525                           (+ 4 smtp-read-point)
 526                           (- (point) 2)))))
 527       (goto-char
 528        (prog1 smtp-read-point
 529          (setq smtp-read-point (point))))
 530       (if (looking-at "[1-5][0-9][0-9] ")
 531           (setq response (cons (read (point-marker)) response)
 532                 response-continue nil)))
 533     response))
 534
 535 (defun smtp-send-command (process command)
 536   (save-excursion
 537     (set-buffer (process-buffer process))
 538     (goto-char (point-max))
 539     (insert command "\r\n")
 540     (setq smtp-read-point (point))
 541     (process-send-string process command)
 542     (process-send-string process "\r\n")))
 543
 544 (defun smtp-send-data (process data)
 545   ;; Escape "." at start of a line.
 546   (if (eq (string-to-char data) ?.)
 547       (process-send-string process "."))
 548   (process-send-string process data)
 549   (process-send-string process "\r\n"))
 550
 551 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 552   "Get address list suitable for smtp RCPT TO:<address>."
 553   (let ((simple-address-list "")
 554         this-line
 555         this-line-end
 556         addr-regexp
 557         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 558     (unwind-protect
 559         (save-excursion
 560           ;;
 561           (set-buffer smtp-address-buffer)
 562           (setq case-fold-search t)
 563           (erase-buffer)
 564           (insert (save-excursion
 565                     (set-buffer smtp-text-buffer)
 566                     (buffer-substring-no-properties header-start header-end)))
 567           (goto-char (point-min))
 568           ;; RESENT-* fields should stop processing of regular fields.
 569           (save-excursion
 570             (if (re-search-forward "^RESENT-TO:" header-end t)
 571                 (setq addr-regexp
 572                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 573               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 574
 575           (while (re-search-forward addr-regexp header-end t)
 576             (replace-match "")
 577             (setq this-line (match-beginning 0))
 578             (forward-line 1)
 579             ;; get any continuation lines.
 580             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 581               (forward-line 1))
 582             (setq this-line-end (point-marker))
 583             (setq simple-address-list
 584                   (concat simple-address-list " "
 585                           (mail-strip-quoted-names
 586                            (buffer-substring this-line this-line-end)))))
 587           (erase-buffer)
 588           (insert-string " ")
 589           (insert-string simple-address-list)
 590           (insert-string "\n")
 591           ;; newline --> blank
 592           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 593           ;; comma   --> blank
 594           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 595           ;; tab     --> blank
 596           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 597
 598           (goto-char (point-min))
 599           ;; tidyness in case hook is not robust when it looks at this
 600           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 601
 602           (goto-char (point-min))
 603           (let (recipient-address-list)
 604             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 605               (backward-char 1)
 606               (setq recipient-address-list
 607                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 608                           recipient-address-list)))
 609             recipient-address-list))
 610       (kill-buffer smtp-address-buffer))))
 611
 612 (provide 'smtp)
 613
 614 ;;; smtp.el ends here