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 ;;; Code:
  29
  30 (require 'poe)
  31 (require 'poem)
  32 (require 'pcustom)
  33 (require 'mail-utils)                   ; mail-strip-quoted-names
  34
  35 (eval-when-compile (require 'cl))       ; push
  36
  37 (require 'net-trans)
  38
  39 (eval-and-compile
  40   (luna-define-class smtp-transaction (transaction)
  41                      (process
  42                       extensions
  43                       sender
  44                       recipients
  45                       buffer))
  46
  47   (luna-define-internal-accessors 'smtp-transaction))
  48
  49 (defgroup smtp nil
  50   "SMTP protocol for sending mail."
  51   :group 'mail)
  52
  53 (defcustom smtp-default-server nil
  54   "Specify default SMTP server."
  55   :type '(choice (const nil) string)
  56   :group 'smtp)
  57
  58 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  59   "The name of the host running SMTP server.  It can also be a function
  60 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  61   :type '(choice (string :tag "Name")
  62                  (function :tag "Function"))
  63   :group 'smtp)
  64
  65 (defcustom smtp-service "smtp"
  66   "SMTP service port number. \"smtp\" or 25."
  67   :type '(choice (integer :tag "25" 25)
  68                  (string :tag "smtp" "smtp"))
  69   :group 'smtp)
  70
  71 (defcustom smtp-use-8bitmime t
  72   "If non-nil, use ESMTP 8BITMIME if available."
  73   :type 'boolean
  74   :group 'smtp)
  75
  76 (defcustom smtp-local-domain nil
  77   "Local domain name without a host name.
  78 If the function (system-name) returns the full internet address,
  79 don't define this value."
  80   :type '(choice (const nil) string)
  81   :group 'smtp)
  82
  83 (defcustom smtp-debug-info nil
  84   "*smtp debug info printout. messages and process buffer."
  85   :type 'boolean
  86   :group 'smtp)
  87
  88 (defcustom smtp-notify-success nil
  89   "If non-nil, notification for successful mail delivery is returned
  90  to user (RFC1891)."
  91   :type 'boolean
  92   :group 'smtp)
  93
  94 (defvar smtp-open-connection-function (function open-network-stream))
  95
  96 (defvar smtp-default-commands
  97   '(&& smtp-greeting (|| smtp-ehlo smtp-helo)
  98        smtp-mailfrom smtp-rcptto  smtp-data))
  99
 100 (defvar smtp-commands smtp-default-commands)
 101
 102 (defvar smtp-read-point nil)
 103
 104 (defvar smtp-transaction-function nil)
 105
 106 (defun smtp-make-fqdn ()
 107   "Return user's fully qualified domain name."
 108   (let ((system-name (system-name)))
 109     (cond
 110      (smtp-local-domain
 111       (concat system-name "." smtp-local-domain))
 112      ((string-match "[^.]\\.[^.]" system-name)
 113       system-name)
 114      (t
 115       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 116
 117 (luna-define-generic smtp-greeting (trans))
 118 (luna-define-generic smtp-ehlo (trans))
 119 (luna-define-generic smtp-helo (trans))
 120 (luna-define-generic smtp-mailfrom (trans))
 121 (luna-define-generic smtp-rcptto (trans))
 122 (luna-define-generic smtp-data (trans))
 123
 124 (luna-define-method smtp-greeting ((trans smtp-transaction))
 125   (let ((response
 126          (smtp-read-response
 127           (smtp-transaction-process-internal trans))))
 128     (or (smtp-check-response response)
 129         (transaction-error trans 'greeting))
 130     trans))
 131
 132 (luna-define-method smtp-ehlo ((trans smtp-transaction))
 133   (smtp-send-command
 134    (smtp-transaction-process-internal trans)
 135    (format "EHLO %s" (smtp-make-fqdn)))
 136   (let ((response
 137          (smtp-read-response
 138           (smtp-transaction-process-internal trans))))
 139     (or (smtp-check-response response)
 140         (transaction-error trans 'ehlo))
 141     (smtp-transaction-set-extensions-internal trans (cdr response))
 142     trans))
 143
 144 (luna-define-method smtp-helo ((trans smtp-transaction))
 145   (smtp-send-command
 146    (smtp-transaction-process-internal trans)
 147    (format "HELO %s" (smtp-make-fqdn)))
 148   (let ((response
 149          (smtp-read-response
 150           (smtp-transaction-process-internal trans))))
 151     (or (smtp-check-response response)
 152         (transaction-error trans 'helo))
 153     trans))
 154
 155 (luna-define-method smtp-mailfrom ((trans smtp-transaction))
 156   (smtp-send-command
 157    (smtp-transaction-process-internal trans)
 158    (format "MAIL FROM:<%s>%s%s"
 159            (smtp-transaction-sender-internal trans)
 160            ;; SIZE --- Message Size Declaration (RFC1870)
 161            (if (memq 'size
 162                      (smtp-transaction-extensions-internal trans))
 163                (format " SIZE=%d"
 164                        (save-excursion
 165                          (set-buffer
 166                           (smtp-transaction-buffer-internal trans))
 167                          (+ (- (point-max) (point-min))
 168                             ;; Add one byte for each change-of-line
 169                             ;; because or CR-LF representation:
 170                             (count-lines (point-min) (point-max))
 171                             ;; For some reason, an empty line is
 172                             ;; added to the message.    Maybe this
 173                             ;; is a bug, but it can't hurt to add
 174                             ;; those two bytes anyway:
 175                             2)))
 176              "")
 177            ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 178            (if (and (memq '8bitmime
 179                           (smtp-transaction-extensions-internal trans))
 180                     smtp-use-8bitmime)
 181                " BODY=8BITMIME"
 182              "")))
 183   (let ((response
 184          (smtp-read-response
 185           (smtp-transaction-process-internal trans))))
 186     (or (smtp-check-response response)
 187         (transaction-error trans 'mailfrom))
 188     trans))
 189
 190 (luna-define-method smtp-rcptto ((trans smtp-transaction))
 191   (let ((recipients
 192          (smtp-transaction-recipients-internal trans))
 193         response)
 194     (while recipients
 195       (smtp-send-command
 196        (smtp-transaction-process-internal trans)
 197        (format
 198         (if smtp-notify-success
 199             "RCPT TO:<%s> NOTIFY=SUCCESS"
 200           "RCPT TO:<%s>")
 201         (car recipients)))
 202       (setq response
 203             (smtp-read-response
 204              (smtp-transaction-process-internal trans)))
 205       (or (smtp-check-response response)
 206           (transaction-error trans 'rcptto))
 207       (setq recipients (cdr recipients)))
 208     trans))
 209
 210 (luna-define-method smtp-data ((trans smtp-transaction))
 211   (smtp-send-command
 212    (smtp-transaction-process-internal trans)
 213    "DATA")
 214   (let ((response
 215          (smtp-read-response
 216           (smtp-transaction-process-internal trans))))
 217     (or (smtp-check-response response)
 218         (transaction-error trans 'data))
 219
 220     ;; Mail contents
 221     (smtp-send-data
 222      (smtp-transaction-process-internal trans)
 223      (smtp-transaction-buffer-internal trans))
 224
 225     ;; DATA end "."
 226     (smtp-send-command
 227      (smtp-transaction-process-internal trans)
 228      ".")
 229     (setq response
 230           (smtp-read-response
 231            (smtp-transaction-process-internal trans)))
 232     (or (smtp-check-response response)
 233         (transaction-error trans 'data))
 234     trans))
 235
 236 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
 237   (let ((server (if (functionp smtp-server)
 238                     (funcall smtp-server sender recipients)
 239                   smtp-server))
 240         process response extensions
 241         transaction error)
 242     (save-excursion
 243       (set-buffer
 244        (get-buffer-create
 245         (format "*trace of SMTP session to %s*" server)))
 246       (buffer-disable-undo)
 247       (erase-buffer)
 248       (make-local-variable 'smtp-read-point)
 249       (setq smtp-read-point (point-min))
 250       (make-local-variable 'smtp-transaction-function)
 251       (or smtp-transaction-function
 252           (let ((function (transaction-compose-commands smtp-commands)))
 253             (or (functionp function)
 254                 (error "Unable to compose SMTP commands"))
 255             (setq smtp-transaction-function function)))
 256       (unwind-protect
 257           (progn
 258             (as-binary-process
 259              (setq process
 260                    (funcall smtp-open-connection-function
 261                             "SMTP" (current-buffer) server smtp-service)))
 262             (when process
 263               (set-process-filter process 'smtp-process-filter)
 264               (setq transaction
 265                     (luna-make-entity 'smtp-transaction
 266                                       :process process
 267                                       :sender sender
 268                                       :recipients recipients
 269                                       :buffer smtp-text-buffer)
 270                     error
 271                     (catch (transaction-error-name transaction)
 272                       (funcall smtp-transaction-function transaction)
 273                       nil))
 274               (not error)))
 275         (when (and process
 276                    (memq (process-status process) '(open run)))
 277           ;; QUIT
 278           (smtp-send-command process "QUIT")
 279           (delete-process process))))))
 280
 281 (defun smtp-process-filter (process output)
 282   (save-excursion
 283     (set-buffer (process-buffer process))
 284     (goto-char (point-max))
 285     (insert output)))
 286
 287 (defun smtp-read-response (process)
 288   (let ((case-fold-search nil)
 289         (response-strings nil)
 290         (response-continue t)
 291         (return-value '(nil ()))
 292         match-end)
 293
 294     (while response-continue
 295       (goto-char smtp-read-point)
 296       (while (not (search-forward "\r\n" nil t))
 297         (accept-process-output process)
 298         (goto-char smtp-read-point))
 299
 300       (setq match-end (point))
 301       (setq response-strings
 302             (cons (buffer-substring smtp-read-point (- match-end 2))
 303                   response-strings))
 304
 305       (goto-char smtp-read-point)
 306       (if (looking-at "[0-9]+ ")
 307           (let ((begin (match-beginning 0))
 308                 (end (match-end 0)))
 309             (if smtp-debug-info
 310                 (message "%s" (car response-strings)))
 311
 312             (setq smtp-read-point match-end)
 313
 314             ;; ignore lines that start with "0"
 315             (if (looking-at "0[0-9]+ ")
 316                 nil
 317               (setq response-continue nil)
 318               (setq return-value
 319                     (cons (string-to-int
 320                            (buffer-substring begin end))
 321                           (nreverse response-strings)))))
 322
 323         (if (looking-at "[0-9]+-")
 324             (progn (if smtp-debug-info
 325                      (message "%s" (car response-strings)))
 326                    (setq smtp-read-point match-end)
 327                    (setq response-continue t))
 328           (progn
 329             (setq smtp-read-point match-end)
 330             (setq response-continue nil)
 331             (setq return-value
 332                   (cons nil (nreverse response-strings)))))))
 333     (setq smtp-read-point match-end)
 334     return-value))
 335
 336 (defun smtp-check-response (response)
 337   (> (car response) 200))
 338
 339 (defun smtp-send-command (process command)
 340   (goto-char (point-max))
 341   (insert command "\r\n")
 342   (setq smtp-read-point (point))
 343   (process-send-string process command)
 344   (process-send-string process "\r\n"))
 345
 346 (defun smtp-send-data-1 (process data)
 347   (goto-char (point-max))
 348   (if smtp-debug-info
 349       (insert data "\r\n"))
 350   (setq smtp-read-point (point))
 351   ;; Escape "." at start of a line.
 352   (if (eq (string-to-char data) ?.)
 353       (process-send-string process "."))
 354   (process-send-string process data)
 355   (process-send-string process "\r\n"))
 356
 357 (defun smtp-send-data (process buffer)
 358   (let ((data-continue t)
 359         (sending-data nil)
 360         this-line
 361         this-line-end)
 362
 363     (save-excursion
 364       (set-buffer buffer)
 365       (goto-char (point-min)))
 366
 367     (while data-continue
 368       (save-excursion
 369         (set-buffer buffer)
 370         (beginning-of-line)
 371         (setq this-line (point))
 372         (end-of-line)
 373         (setq this-line-end (point))
 374         (setq sending-data nil)
 375         (setq sending-data (buffer-substring this-line this-line-end))
 376         (if (or (/= (forward-line 1) 0) (eobp))
 377             (setq data-continue nil)))
 378
 379       (smtp-send-data-1 process sending-data))))
 380
 381 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 382   "Get address list suitable for smtp RCPT TO:<address>."
 383   (let ((simple-address-list "")
 384         this-line
 385         this-line-end
 386         addr-regexp
 387         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 388     (unwind-protect
 389         (save-excursion
 390           ;;
 391           (set-buffer smtp-address-buffer)
 392           (setq case-fold-search t)
 393           (erase-buffer)
 394           (insert (save-excursion
 395                     (set-buffer smtp-text-buffer)
 396                     (buffer-substring-no-properties header-start header-end)))
 397           (goto-char (point-min))
 398           ;; RESENT-* fields should stop processing of regular fields.
 399           (save-excursion
 400             (if (re-search-forward "^RESENT-TO:" header-end t)
 401                 (setq addr-regexp
 402                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 403               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 404
 405           (while (re-search-forward addr-regexp header-end t)
 406             (replace-match "")
 407             (setq this-line (match-beginning 0))
 408             (forward-line 1)
 409             ;; get any continuation lines.
 410             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 411               (forward-line 1))
 412             (setq this-line-end (point-marker))
 413             (setq simple-address-list
 414                   (concat simple-address-list " "
 415                           (mail-strip-quoted-names
 416                            (buffer-substring this-line this-line-end)))))
 417           (erase-buffer)
 418           (insert-string " ")
 419           (insert-string simple-address-list)
 420           (insert-string "\n")
 421           ;; newline --> blank
 422           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 423           ;; comma   --> blank
 424           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 425           ;; tab     --> blank
 426           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 427
 428           (goto-char (point-min))
 429           ;; tidyness in case hook is not robust when it looks at this
 430           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 431
 432           (goto-char (point-min))
 433           (let (recipient-address-list)
 434             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 435               (backward-char 1)
 436               (setq recipient-address-list
 437                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 438                           recipient-address-list)))
 439             recipient-address-list))
 440       (kill-buffer smtp-address-buffer))))
 441
 442 (provide 'smtp)
 443
 444 ;;; smtp.el ends here