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
 418 (defun smtp-primitive-mailfrom (package)
 419   (let* ((connection
 420           (smtp-find-connection (current-buffer)))
 421          (process
 422           (smtp-connection-process connection))
 423          (extensions
 424           (smtp-connection-extensions
 425            connection))
 426          (sender
 427           (smtp-package-sender package))
 428          extension
 429          response)
 430     ;; SIZE --- Message Size Declaration (RFC1870)
 431     (if (and smtp-use-size
 432              (assq 'size extensions))
 433         (setq extension (format "SIZE=%d" (smtp-package-buffer-size package))))
 434     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 435     (if (and smtp-use-8bitmime
 436              (assq '8bitmime extensions))
 437         (setq extension (concat extension " BODY=8BITMIME")))
 438     (smtp-send-command
 439      process
 440      (if extension
 441          (format "MAIL FROM:<%s> %s" sender extension)
 442        (format "MAIL FROM:<%s>" sender)))
 443     (setq response (smtp-read-response process))
 444     (if (/= (car response) 250)
 445         (smtp-response-error response))))
 446
 447 (defun smtp-primitive-rcptto (package)
 448   (let* ((connection
 449           (smtp-find-connection (current-buffer)))
 450          (process
 451           (smtp-connection-process connection))
 452          (recipients
 453           (smtp-package-recipients package))
 454          response)
 455     (while recipients
 456       (smtp-send-command
 457        process (format "RCPT TO:<%s>" (pop recipients)))
 458       (setq response (smtp-read-response process))
 459       (unless (memq (car response) '(250 251))
 460         (smtp-response-error response)))))
 461
 462 (defun smtp-primitive-data (package)
 463   (let* ((connection
 464           (smtp-find-connection (current-buffer)))
 465          (process
 466           (smtp-connection-process connection))
 467          response)
 468     (smtp-send-command process "DATA")
 469     (setq response (smtp-read-response process))
 470     (if (/= (car response) 354)
 471         (smtp-response-error response))
 472     (save-excursion
 473       (set-buffer (smtp-package-buffer package))
 474       (goto-char (point-min))
 475       (while (not (eobp))
 476         (smtp-send-data
 477          process (buffer-substring (point) (progn (end-of-line)(point))))
 478         (beginning-of-line 2)))
 479     (smtp-send-command process ".")
 480     (setq response (smtp-read-response process))
 481     (if (/= (car response) 250)
 482         (smtp-response-error response))))
 483
 484 (defun smtp-primitive-quit (package)
 485   (let* ((connection
 486           (smtp-find-connection (current-buffer)))
 487          (process
 488           (smtp-connection-process connection))
 489          response)
 490     (smtp-send-command process "QUIT")
 491     (setq response (smtp-read-response process))
 492     (if (/= (car response) 221)
 493         (smtp-response-error response))))
 494
 495 ;;; @ low level process manipulating function
 496 ;;;
 497 (defun smtp-process-filter (process output)
 498   (save-excursion
 499     (set-buffer (process-buffer process))
 500     (goto-char (point-max))
 501     (insert output)))
 502
 503 (put 'smtp-error 'error-message "SMTP error")
 504 (put 'smtp-error 'error-conditions '(smtp-error error))
 505
 506 (put 'smtp-response-error 'error-message "SMTP response error")
 507 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 508
 509 (defun smtp-response-error (response)
 510   (signal 'smtp-response-error response))
 511
 512 (defun smtp-read-response (process)
 513   (let ((response-continue t)
 514         response)
 515     (while response-continue
 516       (goto-char smtp-read-point)
 517       (while (not (search-forward "\r\n" nil t))
 518         (accept-process-output process)
 519         (goto-char smtp-read-point))
 520       (setq response
 521             (nconc response
 522                    (list (buffer-substring
 523                           (+ 4 smtp-read-point)
 524                           (- (point) 2)))))
 525       (goto-char
 526        (prog1 smtp-read-point
 527          (setq smtp-read-point (point))))
 528       (if (looking-at "[1-5][0-9][0-9] ")
 529           (setq response (cons (read (point-marker)) response)
 530                 response-continue nil)))
 531     response))
 532
 533 (defun smtp-send-command (process command)
 534   (save-excursion
 535     (set-buffer (process-buffer process))
 536     (goto-char (point-max))
 537     (insert command "\r\n")
 538     (setq smtp-read-point (point))
 539     (process-send-string process command)
 540     (process-send-string process "\r\n")))
 541
 542 (defun smtp-send-data (process data)
 543   ;; Escape "." at start of a line.
 544   (if (eq (string-to-char data) ?.)
 545       (process-send-string process "."))
 546   (process-send-string process data)
 547   (process-send-string process "\r\n"))
 548
 549 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 550   "Get address list suitable for smtp RCPT TO:<address>."
 551   (let ((simple-address-list "")
 552         this-line
 553         this-line-end
 554         addr-regexp
 555         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 556     (unwind-protect
 557         (save-excursion
 558           ;;
 559           (set-buffer smtp-address-buffer)
 560           (setq case-fold-search t)
 561           (erase-buffer)
 562           (insert (save-excursion
 563                     (set-buffer smtp-text-buffer)
 564                     (buffer-substring-no-properties header-start header-end)))
 565           (goto-char (point-min))
 566           ;; RESENT-* fields should stop processing of regular fields.
 567           (save-excursion
 568             (if (re-search-forward "^RESENT-TO:" header-end t)
 569                 (setq addr-regexp
 570                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 571               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 572
 573           (while (re-search-forward addr-regexp header-end t)
 574             (replace-match "")
 575             (setq this-line (match-beginning 0))
 576             (forward-line 1)
 577             ;; get any continuation lines.
 578             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 579               (forward-line 1))
 580             (setq this-line-end (point-marker))
 581             (setq simple-address-list
 582                   (concat simple-address-list " "
 583                           (mail-strip-quoted-names
 584                            (buffer-substring this-line this-line-end)))))
 585           (erase-buffer)
 586           (insert-string " ")
 587           (insert-string simple-address-list)
 588           (insert-string "\n")
 589           ;; newline --> blank
 590           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 591           ;; comma   --> blank
 592           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 593           ;; tab     --> blank
 594           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 595
 596           (goto-char (point-min))
 597           ;; tidyness in case hook is not robust when it looks at this
 598           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 599
 600           (goto-char (point-min))
 601           (let (recipient-address-list)
 602             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 603               (backward-char 1)
 604               (setq recipient-address-list
 605                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 606                           recipient-address-list)))
 607             recipient-address-list))
 608       (kill-buffer smtp-address-buffer))))
 609
 610 (provide 'smtp)
 611
 612 ;;; smtp.el ends here