smtp.el

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