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                        (sasl-cram-md5
 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                      (let ((enc-word (copy-sequence passphrase)))
 181                        (smtp-send-command
 182                         process
 183                         (setq enc-word (unwind-protect
 184                                            (sasl-plain "" user enc-word)
 185                                          (fillarray enc-word 0))
 186                               enc-word (unwind-protect
 187                                            (base64-encode-string enc-word)
 188                                          (fillarray enc-word 0))
 189                               enc-word (unwind-protect
 190                                            (concat "AUTH PLAIN " enc-word)
 191                                          (fillarray enc-word 0))))
 192                        (fillarray enc-word 0))
 193                      (setq response (smtp-read-response process))
 194                      (if (or (null (car response))
 195                              (not (integerp (car response)))
 196                              (>= (car response) 400))
 197                          (throw 'done (car (cdr response)))))
 198
 199                     ((string= "login" auth)
 200                      (smtp-send-command
 201                       process
 202                       (concat "AUTH LOGIN " user))
 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                      (smtp-send-command
 209                       process
 210                       (base64-encode-string passphrase))
 211                      (setq response (smtp-read-response process))
 212                      (if (or (null (car response))
 213                              (not (integerp (car response)))
 214                              (>= (car response) 400))
 215                          (throw 'done (car (cdr response)))))
 216
 217                     (t
 218                      (throw 'done (concat "AUTH " auth " not supported")))))
 219
 220             ;; ONEX --- One message transaction only (sendmail extension?)
 221             (if (or (memq 'onex extensions)
 222                     (memq 'xone extensions))
 223                 (progn
 224                   (smtp-send-command process "ONEX")
 225                   (setq response (smtp-read-response process))
 226                   (if (or (null (car response))
 227                           (not (integerp (car response)))
 228                           (>= (car response) 400))
 229                       (throw 'done (car (cdr response))))))
 230
 231             ;; VERB --- Verbose (sendmail extension?)
 232             (if (and smtp-debug-info
 233                      (or (memq 'verb extensions)
 234                          (memq 'xvrb extensions)))
 235                 (progn
 236                   (smtp-send-command process "VERB")
 237                   (setq response (smtp-read-response process))
 238                   (if (or (null (car response))
 239                           (not (integerp (car response)))
 240                           (>= (car response) 400))
 241                       (throw 'done (car (cdr response))))))
 242
 243             ;; XUSR --- Initial (user) submission (sendmail extension?)
 244             (if (memq 'xusr extensions)
 245                 (progn
 246                   (smtp-send-command process "XUSR")
 247                   (setq response (smtp-read-response process))
 248                   (if (or (null (car response))
 249                           (not (integerp (car response)))
 250                           (>= (car response) 400))
 251                       (throw 'done (car (cdr response))))))
 252
 253             ;; MAIL FROM:<sender>
 254             (smtp-send-command
 255              process
 256              (format "MAIL FROM:<%s>%s%s"
 257                      sender
 258                      ;; SIZE --- Message Size Declaration (RFC1870)
 259                      (if (memq 'size extensions)
 260                          (format " SIZE=%d"
 261                                  (save-excursion
 262                                    (set-buffer smtp-text-buffer)
 263                                    (+ (- (point-max) (point-min))
 264                                       ;; Add one byte for each change-of-line
 265                                       ;; because or CR-LF representation:
 266                                       (count-lines (point-min) (point-max))
 267                                       ;; For some reason, an empty line is
 268                                       ;; added to the message.  Maybe this
 269                                       ;; is a bug, but it can't hurt to add
 270                                       ;; those two bytes anyway:
 271                                       2)))
 272                        "")
 273                      ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 274                      (if (and (memq '8bitmime extensions)
 275                               smtp-use-8bitmime)
 276                          " BODY=8BITMIME"
 277                        "")))
 278             (setq response (smtp-read-response process))
 279             (if (or (null (car response))
 280                     (not (integerp (car response)))
 281                     (>= (car response) 400))
 282                 (throw 'done (car (cdr response))))
 283
 284             ;; RCPT TO:<recipient>
 285             (while recipients
 286               (smtp-send-command process
 287                                  (format
 288                                   (if smtp-notify-success
 289                                       "RCPT TO:<%s> NOTIFY=SUCCESS"
 290                                     "RCPT TO:<%s>")
 291                                   (car recipients)))
 292               (setq recipients (cdr recipients))
 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             ;; DATA
 300             (smtp-send-command process "DATA")
 301             (setq response (smtp-read-response process))
 302             (if (or (null (car response))
 303                     (not (integerp (car response)))
 304                     (>= (car response) 400))
 305                 (throw 'done (car (cdr response))))
 306
 307             ;; Mail contents
 308             (smtp-send-data process smtp-text-buffer)
 309
 310             ;; DATA end "."
 311             (smtp-send-command process ".")
 312             (setq response (smtp-read-response process))
 313             (if (or (null (car response))
 314                     (not (integerp (car response)))
 315                     (>= (car response) 400))
 316                 (throw 'done (car (cdr response))))
 317
 318             t)
 319
 320         (if (and process
 321                  (eq (process-status process) 'open))
 322             (progn
 323               ;; QUIT
 324               (smtp-send-command process "QUIT")
 325               (smtp-read-response process)
 326               (delete-process process)))))))
 327
 328 (defun smtp-process-filter (process output)
 329   (save-excursion
 330     (set-buffer (process-buffer process))
 331     (goto-char (point-max))
 332     (insert output)))
 333
 334 (defun smtp-read-response (process)
 335   (let ((case-fold-search nil)
 336         (response-strings nil)
 337         (response-continue t)
 338         (return-value '(nil ()))
 339         match-end)
 340
 341     (while response-continue
 342       (goto-char smtp-read-point)
 343       (while (not (search-forward "\r\n" nil t))
 344         (accept-process-output process)
 345         (goto-char smtp-read-point))
 346
 347       (setq match-end (point))
 348       (setq response-strings
 349             (cons (buffer-substring smtp-read-point (- match-end 2))
 350                   response-strings))
 351
 352       (goto-char smtp-read-point)
 353       (if (looking-at "[0-9]+ ")
 354           (let ((begin (match-beginning 0))
 355                 (end (match-end 0)))
 356             (if smtp-debug-info
 357                 (message "%s" (car response-strings)))
 358
 359             (setq smtp-read-point match-end)
 360
 361             ;; ignore lines that start with "0"
 362             (if (looking-at "0[0-9]+ ")
 363                 nil
 364               (setq response-continue nil)
 365               (setq return-value
 366                     (cons (string-to-int
 367                            (buffer-substring begin end))
 368                           (nreverse response-strings)))))
 369
 370         (if (looking-at "[0-9]+-")
 371             (progn (if smtp-debug-info
 372                      (message "%s" (car response-strings)))
 373                    (setq smtp-read-point match-end)
 374                    (setq response-continue t))
 375           (progn
 376             (setq smtp-read-point match-end)
 377             (setq response-continue nil)
 378             (setq return-value
 379                   (cons nil (nreverse response-strings)))))))
 380     (setq smtp-read-point match-end)
 381     return-value))
 382
 383 (defun smtp-send-command (process command)
 384   (goto-char (point-max))
 385   (insert command "\r\n")
 386   (setq smtp-read-point (point))
 387   (process-send-string process command)
 388   (process-send-string process "\r\n"))
 389
 390 (defun smtp-send-data-1 (process data)
 391   (goto-char (point-max))
 392   (if smtp-debug-info
 393       (insert data "\r\n"))
 394   (setq smtp-read-point (point))
 395   ;; Escape "." at start of a line.
 396   (if (eq (string-to-char data) ?.)
 397       (process-send-string process "."))
 398   (process-send-string process data)
 399   (process-send-string process "\r\n"))
 400
 401 (defun smtp-send-data (process buffer)
 402   (let ((data-continue t)
 403         (sending-data nil)
 404         this-line
 405         this-line-end)
 406
 407     (save-excursion
 408       (set-buffer buffer)
 409       (goto-char (point-min)))
 410
 411     (while data-continue
 412       (save-excursion
 413         (set-buffer buffer)
 414         (beginning-of-line)
 415         (setq this-line (point))
 416         (end-of-line)
 417         (setq this-line-end (point))
 418         (setq sending-data nil)
 419         (setq sending-data (buffer-substring this-line this-line-end))
 420         (if (or (/= (forward-line 1) 0) (eobp))
 421             (setq data-continue nil)))
 422
 423       (smtp-send-data-1 process sending-data))))
 424
 425 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 426   "Get address list suitable for smtp RCPT TO:<address>."
 427   (let ((case-fold-search t)
 428         (simple-address-list "")
 429         this-line
 430         this-line-end
 431         addr-regexp
 432         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 433     (unwind-protect
 434         (save-excursion
 435           ;;
 436           (set-buffer smtp-address-buffer)
 437           (erase-buffer)
 438           (insert (save-excursion
 439                     (set-buffer smtp-text-buffer)
 440                     (buffer-substring-no-properties header-start header-end)))
 441           (goto-char (point-min))
 442           ;; RESENT-* fields should stop processing of regular fields.
 443           (save-excursion
 444             (if (re-search-forward "^RESENT-TO:" header-end t)
 445                 (setq addr-regexp
 446                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 447               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 448
 449           (while (re-search-forward addr-regexp header-end t)
 450             (replace-match "")
 451             (setq this-line (match-beginning 0))
 452             (forward-line 1)
 453             ;; get any continuation lines.
 454             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 455               (forward-line 1))
 456             (setq this-line-end (point-marker))
 457             (setq simple-address-list
 458                   (concat simple-address-list " "
 459                           (mail-strip-quoted-names
 460                            (buffer-substring this-line this-line-end)))))
 461           (erase-buffer)
 462           (insert-string " ")
 463           (insert-string simple-address-list)
 464           (insert-string "\n")
 465           ;; newline --> blank
 466           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 467           ;; comma   --> blank
 468           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 469           ;; tab     --> blank
 470           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 471
 472           (goto-char (point-min))
 473           ;; tidyness in case hook is not robust when it looks at this
 474           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 475
 476           (goto-char (point-min))
 477           (let (recipient-address-list)
 478             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 479               (backward-char 1)
 480               (setq recipient-address-list
 481                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 482                           recipient-address-list)))
 483             recipient-address-list))
 484       (kill-buffer smtp-address-buffer))))
 485
 486 (provide 'smtp)
 487
 488 ;;; smtp.el ends here