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