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