smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998, 1999, 2000 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 (require 'mel) ; binary-funcall
  39
  40 (defgroup smtp nil
  41   "SMTP protocol for sending mail."
  42   :group 'mail)
  43
  44 (defgroup smtp-extensions nil
  45   "SMTP service extensions (RFC1869)."
  46   :group 'smtp)
  47
  48 (defcustom smtp-default-server nil
  49   "Specify default SMTP server."
  50   :type '(choice (const nil) string)
  51   :group 'smtp)
  52
  53 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  54   "The name of the host running SMTP server.
  55 It can also be a function
  56 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  57   :type '(choice (string :tag "Name")
  58                  (function :tag "Function"))
  59   :group 'smtp)
  60
  61 (defcustom smtp-service "smtp"
  62   "SMTP service port number.  \"smtp\" or 25."
  63   :type '(choice (integer :tag "25" 25)
  64                  (string :tag "smtp" "smtp"))
  65   :group 'smtp)
  66
  67 (defcustom smtp-local-domain nil
  68   "Local domain name without a host name.
  69 If the function (system-name) returns the full internet address,
  70 don't define this value."
  71   :type '(choice (const nil) string)
  72   :group 'smtp)
  73
  74 (defcustom smtp-fqdn nil
  75   "Fully qualified domain name used for Message-ID."
  76   :type '(choice (const nil) string)
  77   :group 'smtp)
  78
  79 (defcustom smtp-use-8bitmime t
  80   "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
  81   :type 'boolean
  82   :group 'smtp-extensions)
  83
  84 (defcustom smtp-use-size t
  85   "If non-nil, use ESMTP SIZE (RFC1870) if available."
  86   :type 'boolean
  87   :group 'smtp-extensions)
  88
  89 (defcustom smtp-use-starttls nil
  90   "If non-nil, use STARTTLS (RFC2595) if available."
  91   :type 'boolean
  92   :group 'smtp-extensions)
  93
  94 (defcustom smtp-use-sasl nil
  95   "If non-nil, use SMTP Authentication (RFC2554) if available."
  96   :type 'boolean
  97   :group 'smtp-extensions)
  98
  99 (defcustom smtp-sasl-user-name (user-login-name)
 100   "Identification to be used for authorization."
 101   :type 'string
 102   :group 'smtp-extensions)
 103
 104 (defcustom smtp-sasl-properties nil
 105   "Properties set to SASL client."
 106   :type 'string
 107   :group 'smtp-extensions)
 108
 109 (defcustom smtp-sasl-mechanisms nil
 110   "List of authentication mechanisms."
 111   :type '(repeat string)
 112   :group 'smtp-extensions)
 113
 114 (defvar sasl-mechanisms)
 115
 116 ;;;###autoload
 117 (defvar smtp-open-connection-function #'open-network-stream)
 118
 119 (defvar smtp-read-point nil)
 120
 121 (defvar smtp-connection-alist nil)
 122
 123 (defvar smtp-submit-package-function #'smtp-submit-package)
 124
 125 (defvar smtp-end-of-line "\r\n"
 126   "*String to use on the end of lines when talking to the SMTP server.
 127 This is \"\\r\\n\" by default, but should be \"\\n\" when using and
 128 indirect connection method, e.g. bind `smtp-open-connection-function'
 129 to a custom function as shown below:
 130
 131 \(setq smtp-open-connection-function
 132       (lambda (name buffer host service)
 133         (start-process name buffer \"ssh\" \"-C\" host
 134                        \"telnet\" \"-8\" host service)))")
 135
 136 ;;; @ SMTP package
 137 ;;; A package contains a mail message, an envelope sender address,
 138 ;;; and one or more envelope recipient addresses.  In ESMTP model
 139 ;;; the current sending package should be guaranteed to be accessible
 140 ;;; anywhere from the hook methods (or SMTP commands).
 141
 142 (eval-and-compile
 143   (luna-define-class smtp-package ()
 144                      (sender
 145                       recipients
 146                       buffer))
 147
 148   (luna-define-internal-accessors 'smtp-package))
 149
 150 (defun smtp-make-package (sender recipients buffer)
 151   "Create a new package structure.
 152 A package is a unit of SMTP message
 153 SENDER specifies the package sender, a string.
 154 RECIPIENTS is a list of recipients.
 155 BUFFER may be a buffer or a buffer name which contains mail message."
 156   (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
 157
 158 (defun smtp-package-buffer-internal-size (package)
 159   "Return the size of PACKAGE, an integer."
 160   (save-excursion
 161     (set-buffer (smtp-package-buffer-internal package))
 162     (let ((size
 163            (+ (buffer-size)
 164               ;; Add one byte for each change-of-line
 165               ;; because or CR-LF representation:
 166               (count-lines (point-min) (point-max))
 167               ;; For some reason, an empty line is
 168               ;; added to the message.  Maybe this
 169               ;; is a bug, but it can't hurt to add
 170               ;; those two bytes anyway:
 171               2)))
 172       (goto-char (point-min))
 173       (while (re-search-forward "^\\." nil t)
 174         (setq size (1+ size)))
 175       size)))
 176
 177 ;;; @ SMTP connection
 178 ;;; We should consider the function `open-network-stream' is a emulation
 179 ;;; for another network stream.  They are likely to be implemented with an
 180 ;;; external program and the function `process-contact' returns the
 181 ;;; process id instead of `(HOST SERVICE)' pair.
 182
 183 (eval-and-compile
 184   (luna-define-class smtp-connection ()
 185                      (process
 186                       server
 187                       service
 188                       extensions
 189                       encoder
 190                       decoder))
 191
 192   (luna-define-internal-accessors 'smtp-connection))
 193
 194 (defun smtp-make-connection (process server service)
 195   "Create a new connection structure.
 196 PROCESS is an internal subprocess-object.  SERVER is name of the host
 197 to connect to.  SERVICE is name of the service desired."
 198   (luna-make-entity 'smtp-connection :process process :server server :service service))
 199
 200 (luna-define-generic smtp-connection-opened (connection)
 201   "Say whether the CONNECTION to server has been opened.")
 202
 203 (luna-define-generic smtp-close-connection (connection)
 204   "Close the CONNECTION to server.")
 205
 206 (luna-define-method smtp-connection-opened ((connection smtp-connection))
 207   (let ((process (smtp-connection-process-internal connection)))
 208     (if (memq (process-status process) '(open run))
 209         t)))
 210
 211 (luna-define-method smtp-close-connection ((connection smtp-connection))
 212   (let ((process (smtp-connection-process-internal connection)))
 213     (delete-process process)))
 214
 215 (defun smtp-make-fqdn ()
 216   "Return user's fully qualified domain name."
 217   (if smtp-fqdn
 218       smtp-fqdn
 219     (let ((system-name (system-name)))
 220       (cond
 221        (smtp-local-domain
 222         (concat system-name "." smtp-local-domain))
 223        ((string-match "[^.]\\.[^.]" system-name)
 224         system-name)
 225        (t
 226         (error "Cannot generate valid FQDN"))))))
 227
 228 (defun smtp-find-connection (buffer)
 229   "Find the connection delivering to BUFFER."
 230   (let ((entry (assq buffer smtp-connection-alist))
 231         connection)
 232     (when entry
 233       (setq connection (nth 1 entry))
 234       (if (smtp-connection-opened connection)
 235           connection
 236         (setq smtp-connection-alist
 237               (delq entry smtp-connection-alist))
 238         nil))))
 239
 240 (eval-and-compile
 241   (autoload 'starttls-open-stream "starttls")
 242   (autoload 'starttls-negotiate "starttls"))
 243
 244 (defun smtp-open-connection (buffer server service)
 245   "Open a SMTP connection for a service to a host.
 246 Return a newly allocated connection-object.
 247 BUFFER is the buffer to associate with the connection.  SERVER is name
 248 of the host to connect to.  SERVICE is name of the service desired."
 249   (let ((process
 250          (binary-funcall smtp-open-connection-function
 251                          "SMTP" buffer server service))
 252         connection)
 253     (when process
 254       (setq connection (smtp-make-connection process server service))
 255       (set-process-filter process 'smtp-process-filter)
 256       (setq smtp-connection-alist
 257             (cons (list buffer connection)
 258                   smtp-connection-alist))
 259       connection)))
 260
 261 ;;;###autoload
 262 (defun smtp-via-smtp (sender recipients buffer)
 263   "Like `smtp-send-buffer', but sucks in any errors."
 264   (condition-case nil
 265       (progn
 266         (smtp-send-buffer sender recipients buffer)
 267         t)
 268     (smtp-error)))
 269
 270 (make-obsolete 'smtp-via-smtp "It's old API.")
 271
 272 ;;;###autoload
 273 (defun smtp-send-buffer (sender recipients buffer)
 274   "Send a message.
 275 SENDER is an envelope sender address.
 276 RECIPIENTS is a list of envelope recipient addresses.
 277 BUFFER may be a buffer or a buffer name which contains mail message."
 278   (let ((server
 279          (if (functionp smtp-server)
 280              (funcall smtp-server sender recipients)
 281            smtp-server))
 282         (package
 283          (smtp-make-package sender recipients buffer))
 284         (smtp-open-connection-function
 285          (if smtp-use-starttls
 286              #'starttls-open-stream
 287            smtp-open-connection-function)))
 288     (save-excursion
 289       (set-buffer
 290        (get-buffer-create
 291         (format "*trace of SMTP session to %s*" server)))
 292       (erase-buffer)
 293       (buffer-disable-undo)
 294       (unless (smtp-find-connection (current-buffer))
 295         (smtp-open-connection (current-buffer) server smtp-service))
 296       (make-local-variable 'smtp-read-point)
 297       (setq smtp-read-point (point-min))
 298       (funcall smtp-submit-package-function package))))
 299
 300 (defun smtp-submit-package (package)
 301   (unwind-protect
 302       (progn
 303         (smtp-primitive-greeting package)
 304         (condition-case nil
 305             (smtp-primitive-ehlo package)
 306           (smtp-response-error
 307            (smtp-primitive-helo package)))
 308         (if smtp-use-starttls
 309             (progn
 310             (smtp-primitive-starttls package)
 311             (smtp-primitive-ehlo package)))
 312         (if smtp-use-sasl
 313             (smtp-primitive-auth package))
 314         (smtp-primitive-mailfrom package)
 315         (smtp-primitive-rcptto package)
 316         (smtp-primitive-data package))
 317     (let ((connection (smtp-find-connection (current-buffer))))
 318       (when (smtp-connection-opened connection)
 319         (smtp-primitive-quit package)
 320         (smtp-close-connection connection)))))
 321
 322 ;;; @ hook methods for `smtp-submit-package'
 323 ;;;
 324
 325 (defun smtp-primitive-greeting (package)
 326   (let* ((connection
 327           (smtp-find-connection (current-buffer)))
 328          (response
 329           (smtp-read-response connection)))
 330     (if (/= (car response) 220)
 331         (smtp-response-error response))))
 332
 333 (defun smtp-primitive-ehlo (package)
 334   (let* ((connection
 335           (smtp-find-connection (current-buffer)))
 336          response)
 337     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 338     (setq response (smtp-read-response connection))
 339     (if (/= (car response) 250)
 340         (smtp-response-error response))
 341     (smtp-connection-set-extensions-internal
 342      connection (mapcar
 343                  (lambda (extension)
 344                    (let ((extensions
 345                           (split-string extension)))
 346                      (setcar extensions
 347                              (car (read-from-string
 348                                    (downcase (car extensions)))))
 349                      extensions))
 350                  (cdr response)))))
 351
 352 (defun smtp-primitive-helo (package)
 353   (let* ((connection
 354           (smtp-find-connection (current-buffer)))
 355          response)
 356     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 357     (setq response (smtp-read-response connection))
 358     (if (/= (car response) 250)
 359         (smtp-response-error response))))
 360
 361 (defun smtp-primitive-auth (package)
 362   (let* ((connection
 363           (smtp-find-connection (current-buffer)))
 364          (mechanisms
 365           (cdr (assq 'auth (smtp-connection-extensions-internal 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-internal 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      connection
 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 connection))
 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          connection
 403          (if (sasl-step-data step)
 404              (base64-encode-string (sasl-step-data step) t)
 405            ""))))
 406 ;;;    (smtp-connection-set-encoder-internal
 407 ;;;     connection (sasl-client-encoder client))
 408 ;;;    (smtp-connection-set-decoder-internal
 409 ;;;     connection (sasl-client-decoder client))
 410     ))
 411
 412 (defun smtp-primitive-starttls (package)
 413   (let* ((connection
 414           (smtp-find-connection (current-buffer)))
 415          response)
 416     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 417     (smtp-send-command connection "STARTTLS")
 418     (setq response (smtp-read-response connection))
 419     (if (/= (car response) 220)
 420         (smtp-response-error response))
 421     (starttls-negotiate (smtp-connection-process-internal connection))))
 422
 423 (defun smtp-primitive-mailfrom (package)
 424   (let* ((connection
 425           (smtp-find-connection (current-buffer)))
 426          (extensions
 427           (smtp-connection-extensions-internal
 428            connection))
 429          (sender
 430           (smtp-package-sender-internal package))
 431          extension
 432          response)
 433     ;; SIZE --- Message Size Declaration (RFC1870)
 434     (if (and smtp-use-size
 435              (assq 'size extensions))
 436         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 437     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 438     (if (and smtp-use-8bitmime
 439              (assq '8bitmime extensions))
 440         (setq extension (concat extension " BODY=8BITMIME")))
 441     (smtp-send-command
 442      connection
 443      (if extension
 444          (format "MAIL FROM:<%s> %s" sender extension)
 445        (format "MAIL FROM:<%s>" sender)))
 446     (setq response (smtp-read-response connection))
 447     (if (/= (car response) 250)
 448         (smtp-response-error response))))
 449
 450 (defun smtp-primitive-rcptto (package)
 451   (let* ((connection
 452           (smtp-find-connection (current-buffer)))
 453          (recipients
 454           (smtp-package-recipients-internal package))
 455          response)
 456     (while recipients
 457       (smtp-send-command
 458        connection (format "RCPT TO:<%s>" (pop recipients)))
 459       (setq response (smtp-read-response connection))
 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          response)
 467     (smtp-send-command connection "DATA")
 468     (setq response (smtp-read-response connection))
 469     (if (/= (car response) 354)
 470         (smtp-response-error response))
 471     (save-excursion
 472       (set-buffer (smtp-package-buffer-internal package))
 473       (goto-char (point-min))
 474       (while (not (eobp))
 475         (smtp-send-data
 476          connection (buffer-substring (point) (progn (end-of-line)(point))))
 477         (beginning-of-line 2)))
 478     (smtp-send-command connection ".")
 479     (setq response (smtp-read-response connection))
 480     (if (/= (car response) 250)
 481         (smtp-response-error response))))
 482
 483 (defun smtp-primitive-quit (package)
 484   (let* ((connection
 485           (smtp-find-connection (current-buffer)))
 486          response)
 487     (smtp-send-command connection "QUIT")
 488     (setq response (smtp-read-response connection))
 489     (if (/= (car response) 221)
 490         (smtp-response-error response))))
 491
 492 ;;; @ low level process manipulating function
 493 ;;;
 494 (defun smtp-process-filter (process output)
 495   (save-excursion
 496     (set-buffer (process-buffer process))
 497     (goto-char (point-max))
 498     (insert output)))
 499
 500 (put 'smtp-error 'error-message "SMTP error")
 501 (put 'smtp-error 'error-conditions '(smtp-error error))
 502
 503 (put 'smtp-response-error 'error-message "SMTP response error")
 504 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 505
 506 (defun smtp-response-error (response)
 507   (signal 'smtp-response-error response))
 508
 509 (defun smtp-read-response (connection)
 510   (let ((decoder
 511          (smtp-connection-decoder-internal connection))
 512         (response-continue t)
 513         response)
 514     (while response-continue
 515       (goto-char smtp-read-point)
 516       (while (not (search-forward smtp-end-of-line nil t))
 517         (accept-process-output (smtp-connection-process-internal connection))
 518         (goto-char smtp-read-point))
 519       (if decoder
 520           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 521             (delete-region smtp-read-point (point))
 522             (insert (funcall decoder string) smtp-end-of-line)))
 523       (setq response
 524             (nconc response
 525                    (list (buffer-substring
 526                           (+ 4 smtp-read-point)
 527                           (- (point) 2)))))
 528       (goto-char
 529        (prog1 smtp-read-point
 530          (setq smtp-read-point (point))))
 531       (if (looking-at "[1-5][0-9][0-9] ")
 532           (setq response (cons (read (point-marker)) response)
 533                 response-continue nil)))
 534     response))
 535
 536 (defun smtp-send-command (connection command)
 537   (save-excursion
 538     (let ((process
 539            (smtp-connection-process-internal connection))
 540           (encoder
 541            (smtp-connection-encoder-internal connection)))
 542       (set-buffer (process-buffer process))
 543       (goto-char (point-max))
 544       (setq command (concat command smtp-end-of-line))
 545       (insert command)
 546       (setq smtp-read-point (point))
 547       (if encoder
 548           (setq command (funcall encoder command)))
 549       (process-send-string process command))))
 550
 551 (defun smtp-send-data (connection data)
 552   (let ((process
 553          (smtp-connection-process-internal connection))
 554         (encoder
 555          (smtp-connection-encoder-internal connection)))
 556     ;; Escape "." at start of a line.
 557     (if (eq (string-to-char data) ?.)
 558         (setq data (concat "." data smtp-end-of-line))
 559       (setq data (concat data smtp-end-of-line)))
 560     (if encoder
 561         (setq data (funcall encoder data)))
 562     (process-send-string process data)))
 563
 564 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 565   "Get address list suitable for smtp RCPT TO:<address>."
 566   (let ((simple-address-list "")
 567         this-line
 568         this-line-end
 569         addr-regexp
 570         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 571     (unwind-protect
 572         (save-excursion
 573           ;;
 574           (set-buffer smtp-address-buffer)
 575           (setq case-fold-search t)
 576           (erase-buffer)
 577           (insert (save-excursion
 578                     (set-buffer smtp-text-buffer)
 579                     (buffer-substring-no-properties header-start header-end)))
 580           (goto-char (point-min))
 581           ;; RESENT-* fields should stop processing of regular fields.
 582           (save-excursion
 583             (if (re-search-forward "^RESENT-TO:" header-end t)
 584                 (setq addr-regexp
 585                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 586               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 587
 588           (while (re-search-forward addr-regexp header-end t)
 589             (replace-match "")
 590             (setq this-line (match-beginning 0))
 591             (forward-line 1)
 592             ;; get any continuation lines.
 593             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 594               (forward-line 1))
 595             (setq this-line-end (point-marker))
 596             (setq simple-address-list
 597                   (concat simple-address-list " "
 598                           (mail-strip-quoted-names
 599                            (buffer-substring this-line this-line-end)))))
 600           (erase-buffer)
 601           (insert-string " ")
 602           (insert-string simple-address-list)
 603           (insert-string "\n")
 604           ;; newline --> blank
 605           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 606           ;; comma   --> blank
 607           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 608           ;; tab     --> blank
 609           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 610
 611           (goto-char (point-min))
 612           ;; tidyness in case hook is not robust when it looks at this
 613           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 614
 615           (goto-char (point-min))
 616           (let (recipient-address-list)
 617             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 618               (backward-char 1)
 619               (setq recipient-address-list
 620                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 621                           recipient-address-list)))
 622             recipient-address-list))
 623       (kill-buffer smtp-address-buffer))))
 624
 625 (provide 'smtp)
 626
 627 ;;; smtp.el ends here