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