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 ;;      Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
  10 ;; Maintainer: Kenichi OKADA <okada@opaopa.org>
  11 ;; Keywords: SMTP, mail, SASL
  12
  13 ;; This file is part of FLIM (Faithful Library about Internet Message).
  14
  15 ;; This program is free software; you can redistribute it and/or
  16 ;; modify it under the terms of the GNU General Public License as
  17 ;; published by the Free Software Foundation; either version 2, or (at
  18 ;; your option) any later version.
  19
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 ;; General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with this program; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Code:
  31
  32 (require 'poe)
  33 (require 'poem)
  34 (require 'pcustom)
  35 (require 'mail-utils)                   ; mail-strip-quoted-names
  36
  37 (eval-when-compile (require 'sasl))
  38 (eval-and-compile
  39   (autoload 'starttls-open-stream "starttls")
  40   (autoload 'starttls-negotiate "starttls")
  41   (autoload 'sasl-cram-md5 "sasl")
  42   (autoload 'sasl-plain "sasl")
  43   (autoload 'sasl-scram-md5-client-msg-1 "sasl")
  44   (autoload 'sasl-scram-md5-client-msg-2 "sasl")
  45   (autoload 'sasl-scram-md5-authenticate-server "sasl")
  46   (autoload 'sasl-digest-md5-digest-response "sasl"))
  47
  48 (eval-when-compile (require 'cl))       ; push
  49
  50 (defgroup smtp nil
  51   "SMTP protocol for sending mail."
  52   :group 'mail)
  53
  54 (defcustom smtp-default-server nil
  55   "*Specify default SMTP server."
  56   :type '(choice (const nil) string)
  57   :group 'smtp)
  58
  59 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  60   "*The name of the host running SMTP server.  It can also be a function
  61 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  62   :type '(choice (string :tag "Name")
  63                  (function :tag "Function"))
  64   :group 'smtp)
  65
  66 (defcustom smtp-service "smtp"
  67   "*SMTP service port number. \"smtp\" or 25."
  68   :type '(choice (integer :tag "25" 25)
  69                  (string :tag "smtp" "smtp"))
  70   :group 'smtp)
  71
  72 (defcustom smtp-use-8bitmime t
  73   "*If non-nil, use ESMTP 8BITMIME if available."
  74   :type 'boolean
  75   :group 'smtp)
  76
  77 (defcustom smtp-local-domain nil
  78   "*Local domain name without a host name.
  79 If the function (system-name) returns the full internet address,
  80 don't define this value."
  81   :type '(choice (const nil) string)
  82   :group 'smtp)
  83
  84 (defcustom smtp-debug-info nil
  85   "*smtp debug info printout. messages and process buffer."
  86   :type 'boolean
  87   :group 'smtp)
  88
  89 (defcustom smtp-notify-success nil
  90   "*If non-nil, notification for successful mail delivery is returned
  91  to user (RFC1891)."
  92   :type 'boolean
  93   :group 'smtp)
  94
  95 (defcustom smtp-authenticate-type nil
  96   "*SMTP authentication mechanism (RFC2554)."
  97   :type 'symbol
  98   :group 'smtp)
  99
 100 (defvar smtp-authenticate-user nil)
 101 (defvar smtp-authenticate-passphrase nil)
 102
 103 (defvar smtp-authenticate-method-alist
 104   '((cram-md5 smtp-auth-cram-md5)
 105     (plain smtp-auth-plain)
 106     (login smtp-auth-login)
 107     (anonymous smtp-auth-anonymous)
 108     (scram-md5 smtp-auth-scram-md5)
 109     (digest-md5 smtp-auth-digest-md5)))
 110
 111 (defcustom smtp-connection-type nil
 112   "*SMTP connection type."
 113   :type '(choice (const nil) (const :tag "TLS" starttls))
 114   :group 'smtp)
 115
 116 (defvar smtp-read-point nil)
 117
 118 (defun smtp-make-fqdn ()
 119   "Return user's fully qualified domain name."
 120   (let ((system-name (system-name)))
 121     (cond
 122      (smtp-local-domain
 123       (concat system-name "." smtp-local-domain))
 124      ((string-match "[^.]\\.[^.]" system-name)
 125       system-name)
 126      (t
 127       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 128
 129 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
 130   (let ((server (if (functionp smtp-server)
 131                     (funcall smtp-server sender recipients)
 132                   smtp-server))
 133         process response extensions)
 134     (save-excursion
 135       (set-buffer
 136        (get-buffer-create
 137         (format "*trace of SMTP session to %s*" server)))
 138       (erase-buffer)
 139       (make-local-variable 'smtp-read-point)
 140       (setq smtp-read-point (point-min))
 141
 142       (unwind-protect
 143           (catch 'done
 144             (setq process
 145                   (if smtp-connection-type
 146                       (as-binary-process
 147                        (starttls-open-stream
 148                         "SMTP" (current-buffer) server smtp-service))
 149                     (open-network-stream-as-binary
 150                      "SMTP" (current-buffer) server smtp-service)))
 151
 152             (set-process-filter process 'smtp-process-filter)
 153
 154             (if (eq smtp-connection-type 'force)
 155                 (starttls-negotiate process))
 156
 157             ;; Greeting
 158             (setq response (smtp-read-response process))
 159             (if (or (null (car response))
 160                     (not (integerp (car response)))
 161                     (>= (car response) 400))
 162                 (throw 'done (car (cdr response))))
 163
 164             ;; EHLO
 165             (smtp-send-command process
 166                                (format "EHLO %s" (smtp-make-fqdn)))
 167             (setq response (smtp-read-response process))
 168             (if (or (null (car response))
 169                     (not (integerp (car response)))
 170                     (>= (car response) 400))
 171                 (progn
 172                   ;; HELO
 173                   (smtp-send-command process
 174                                      (format "HELO %s" (smtp-make-fqdn)))
 175                   (setq response (smtp-read-response process))
 176                   (if (or (null (car response))
 177                           (not (integerp (car response)))
 178                           (>= (car response) 400))
 179                       (throw 'done (car (cdr response)))))
 180               (let ((extension-lines (cdr (cdr response)))
 181                     extension)
 182                 (while extension-lines
 183                   (if (string-match
 184                        "^auth "
 185                        (setq extension
 186                              (downcase (substring (car extension-lines) 4))))
 187                       (while (string-match "\\([^ ]+\\)" extension (match-end 1))
 188                         (push (intern (match-string 1 extension)) extensions))
 189                     (push (intern extension) extensions))
 190                   (setq extension-lines (cdr extension-lines)))))
 191
 192             ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 193             (when (and smtp-connection-type
 194                        (null (eq smtp-connection-type 'force))
 195                        (memq 'starttls extensions))
 196               (smtp-send-command process "STARTTLS")
 197               (setq response (smtp-read-response process))
 198               (if (or (null (car response))
 199                       (not (integerp (car response)))
 200                       (>= (car response) 400))
 201                   (throw 'done (car (cdr response))))
 202               (starttls-negotiate process))
 203
 204             ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
 205             (when smtp-authenticate-type
 206               (let ((auth smtp-authenticate-type) method)
 207                 (if (and
 208                      (memq auth extensions)
 209                      (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
 210                     (funcall method process)
 211                   (throw 'done
 212                          (format "AUTH mechanism %s not available" auth)))))
 213
 214             ;; ONEX --- One message transaction only (sendmail extension?)
 215 ;;;         (if (or (memq 'onex extensions)
 216 ;;;                 (memq 'xone extensions))
 217 ;;;             (progn
 218 ;;;               (smtp-send-command process "ONEX")
 219 ;;;               (setq response (smtp-read-response process))
 220 ;;;               (if (or (null (car response))
 221 ;;;                       (not (integerp (car response)))
 222 ;;;                       (>= (car response) 400))
 223 ;;;                   (throw 'done (car (cdr response))))))
 224
 225             ;; VERB --- Verbose (sendmail extension?)
 226 ;;;         (if (and smtp-debug-info
 227 ;;;                  (or (memq 'verb extensions)
 228 ;;;                      (memq 'xvrb extensions)))
 229 ;;;             (progn
 230 ;;;               (smtp-send-command process "VERB")
 231 ;;;               (setq response (smtp-read-response process))
 232 ;;;               (if (or (null (car response))
 233 ;;;                       (not (integerp (car response)))
 234 ;;;                       (>= (car response) 400))
 235 ;;;                   (throw 'done (car (cdr response))))))
 236
 237             ;; XUSR --- Initial (user) submission (sendmail extension?)
 238 ;;;         (if (memq 'xusr extensions)
 239 ;;;             (progn
 240 ;;;               (smtp-send-command process "XUSR")
 241 ;;;               (setq response (smtp-read-response process))
 242 ;;;               (if (or (null (car response))
 243 ;;;                       (not (integerp (car response)))
 244 ;;;                       (>= (car response) 400))
 245 ;;;                   (throw 'done (car (cdr response))))))
 246
 247             ;; MAIL FROM:<sender>
 248             (smtp-send-command
 249              process
 250              (format "MAIL FROM:<%s>%s%s"
 251                      sender
 252                      ;; SIZE --- Message Size Declaration (RFC1870)
 253                      (if (memq 'size extensions)
 254                          (format " SIZE=%d"
 255                                  (save-excursion
 256                                    (set-buffer smtp-text-buffer)
 257                                    (+ (- (point-max) (point-min))
 258                                       ;; Add one byte for each change-of-line
 259                                       ;; because or CR-LF representation:
 260                                       (count-lines (point-min) (point-max))
 261                                       ;; For some reason, an empty line is
 262                                       ;; added to the message.  Maybe this
 263                                       ;; is a bug, but it can't hurt to add
 264                                       ;; those two bytes anyway:
 265                                       2)))
 266                        "")
 267                      ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 268                      (if (and (memq '8bitmime extensions)
 269                               smtp-use-8bitmime)
 270                          " BODY=8BITMIME"
 271                        "")))
 272             (setq response (smtp-read-response process))
 273             (if (or (null (car response))
 274                     (not (integerp (car response)))
 275                     (>= (car response) 400))
 276                 (throw 'done (car (cdr response))))
 277
 278             ;; RCPT TO:<recipient>
 279             (while recipients
 280               (smtp-send-command process
 281                                  (format
 282                                   (if smtp-notify-success
 283                                       "RCPT TO:<%s> NOTIFY=SUCCESS"
 284                                     "RCPT TO:<%s>")
 285                                   (car recipients)))
 286               (setq recipients (cdr recipients))
 287               (setq response (smtp-read-response process))
 288               (if (or (null (car response))
 289                       (not (integerp (car response)))
 290                       (>= (car response) 400))
 291                   (throw 'done (car (cdr response)))))
 292
 293             ;; DATA
 294             (smtp-send-command process "DATA")
 295             (setq response (smtp-read-response process))
 296             (if (or (null (car response))
 297                     (not (integerp (car response)))
 298                     (>= (car response) 400))
 299                 (throw 'done (car (cdr response))))
 300
 301             ;; Mail contents
 302             (smtp-send-data process smtp-text-buffer)
 303
 304             ;; DATA end "."
 305             (smtp-send-command process ".")
 306             (setq response (smtp-read-response process))
 307             (if (or (null (car response))
 308                     (not (integerp (car response)))
 309                     (>= (car response) 400))
 310                 (throw 'done (car (cdr response))))
 311
 312             t)
 313
 314         (if (and process
 315                  (memq (process-status process) '(open run)))
 316         (progn
 317           ;; QUIT
 318           (smtp-send-command process "QUIT")
 319           (smtp-read-response process)
 320           (delete-process process)))))))
 321
 322 (defun smtp-process-filter (process output)
 323   (save-excursion
 324     (set-buffer (process-buffer process))
 325     (goto-char (point-max))
 326     (insert output)))
 327
 328 (defun smtp-read-response (process)
 329   (let ((case-fold-search nil)
 330         (response-strings nil)
 331         (response-continue t)
 332         (return-value '(nil ()))
 333         match-end)
 334
 335     (while response-continue
 336       (goto-char smtp-read-point)
 337       (while (not (search-forward "\r\n" nil t))
 338         (accept-process-output process)
 339         (goto-char smtp-read-point))
 340
 341       (setq match-end (point))
 342       (setq response-strings
 343             (cons (buffer-substring smtp-read-point (- match-end 2))
 344                   response-strings))
 345
 346       (goto-char smtp-read-point)
 347       (if (looking-at "[0-9]+ ")
 348           (let ((begin (match-beginning 0))
 349                 (end (match-end 0)))
 350             (if smtp-debug-info
 351                 (message "%s" (car response-strings)))
 352
 353             (setq smtp-read-point match-end)
 354
 355             ;; ignore lines that start with "0"
 356             (if (looking-at "0[0-9]+ ")
 357                 nil
 358               (setq response-continue nil)
 359               (setq return-value
 360                     (cons (string-to-int
 361                            (buffer-substring begin end))
 362                           (nreverse response-strings)))))
 363
 364         (if (looking-at "[0-9]+-")
 365             (progn (if smtp-debug-info
 366                      (message "%s" (car response-strings)))
 367                    (setq smtp-read-point match-end)
 368                    (setq response-continue t))
 369           (progn
 370             (setq smtp-read-point match-end)
 371             (setq response-continue nil)
 372             (setq return-value
 373                   (cons nil (nreverse response-strings)))))))
 374     (setq smtp-read-point match-end)
 375     return-value))
 376
 377 (defun smtp-send-command (process command &optional secure)
 378   (goto-char (point-max))
 379   (if secure
 380       (insert "Here is insecure words.\r\n")
 381     (insert command "\r\n"))
 382   (setq smtp-read-point (point))
 383   (process-send-string process command)
 384   (process-send-string process "\r\n"))
 385
 386 (defun smtp-send-data-1 (process data)
 387   (goto-char (point-max))
 388   (if smtp-debug-info
 389       (insert data "\r\n"))
 390   (setq smtp-read-point (point))
 391   ;; Escape "." at start of a line.
 392   (if (eq (string-to-char data) ?.)
 393       (process-send-string process "."))
 394   (process-send-string process data)
 395   (process-send-string process "\r\n"))
 396
 397 (defun smtp-send-data (process buffer)
 398   (let ((data-continue t)
 399         (sending-data nil)
 400         this-line
 401         this-line-end)
 402
 403     (save-excursion
 404       (set-buffer buffer)
 405       (goto-char (point-min)))
 406
 407     (while data-continue
 408       (save-excursion
 409         (set-buffer buffer)
 410         (beginning-of-line)
 411         (setq this-line (point))
 412         (end-of-line)
 413         (setq this-line-end (point))
 414         (setq sending-data nil)
 415         (setq sending-data (buffer-substring this-line this-line-end))
 416         (if (or (/= (forward-line 1) 0) (eobp))
 417             (setq data-continue nil)))
 418
 419       (smtp-send-data-1 process sending-data))))
 420
 421 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 422   "Get address list suitable for smtp RCPT TO:<address>."
 423   (let ((simple-address-list "")
 424         this-line
 425         this-line-end
 426         addr-regexp
 427         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 428     (unwind-protect
 429         (save-excursion
 430           ;;
 431           (set-buffer smtp-address-buffer)
 432           (setq case-fold-search t)
 433           (erase-buffer)
 434           (insert (save-excursion
 435                     (set-buffer smtp-text-buffer)
 436                     (buffer-substring-no-properties header-start header-end)))
 437           (goto-char (point-min))
 438           ;; RESENT-* fields should stop processing of regular fields.
 439           (save-excursion
 440             (if (re-search-forward "^RESENT-TO:" header-end t)
 441                 (setq addr-regexp
 442                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 443               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 444
 445           (while (re-search-forward addr-regexp header-end t)
 446             (replace-match "")
 447             (setq this-line (match-beginning 0))
 448             (forward-line 1)
 449             ;; get any continuation lines.
 450             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 451               (forward-line 1))
 452             (setq this-line-end (point-marker))
 453             (setq simple-address-list
 454                   (concat simple-address-list " "
 455                           (mail-strip-quoted-names
 456                            (buffer-substring this-line this-line-end)))))
 457           (erase-buffer)
 458           (insert-string " ")
 459           (insert-string simple-address-list)
 460           (insert-string "\n")
 461           ;; newline --> blank
 462           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 463           ;; comma   --> blank
 464           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 465           ;; tab     --> blank
 466           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 467
 468           (goto-char (point-min))
 469           ;; tidyness in case hook is not robust when it looks at this
 470           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 471
 472           (goto-char (point-min))
 473           (let (recipient-address-list)
 474             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 475               (backward-char 1)
 476               (setq recipient-address-list
 477                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 478                           recipient-address-list)))
 479             recipient-address-list))
 480       (kill-buffer smtp-address-buffer))))
 481
 482 (defun smtp-auth-cram-md5 (process)
 483   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 484         response)
 485     (smtp-send-command process "AUTH CRAM-MD5")
 486     (setq response (smtp-read-response process))
 487     (if (or (null (car response))
 488             (not (integerp (car response)))
 489             (>= (car response) 400))
 490         (throw 'done (car (cdr response))))
 491     (smtp-send-command
 492      process
 493      (setq secure-word (unwind-protect
 494                            (sasl-cram-md5
 495                             smtp-authenticate-user secure-word
 496                             (base64-decode-string
 497                              (substring (car (cdr response)) 4)))
 498                          (fillarray secure-word 0))
 499            secure-word (unwind-protect
 500                            (base64-encode-string secure-word)
 501                          (fillarray secure-word 0))) t)
 502     (fillarray secure-word 0)
 503     (setq response (smtp-read-response process))
 504     (if (or (null (car response))
 505             (not (integerp (car response)))
 506             (>= (car response) 400))
 507         (throw 'done (car (cdr response))))))
 508
 509 (defun smtp-auth-plain (process)
 510   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 511         response)
 512     (smtp-send-command
 513      process
 514      (setq secure-word (unwind-protect
 515                            (sasl-plain "" smtp-authenticate-user secure-word)
 516                          (fillarray secure-word 0))
 517            secure-word (unwind-protect
 518                            (base64-encode-string secure-word)
 519                          (fillarray secure-word 0))
 520            secure-word (unwind-protect
 521                            (concat "AUTH PLAIN " secure-word)
 522                          (fillarray secure-word 0))) t)
 523     (fillarray secure-word 0)
 524     (setq response (smtp-read-response process))
 525     (if (or (null (car response))
 526             (not (integerp (car response)))
 527             (>= (car response) 400))
 528         (throw 'done (car (cdr response))))))
 529
 530 (defun smtp-auth-login (process)
 531   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 532         response)
 533     (smtp-send-command process "AUTH LOGIN")
 534     (setq response (smtp-read-response process))
 535     (if (or (null (car response))
 536             (not (integerp (car response)))
 537             (>= (car response) 400))
 538         (throw 'done (car (cdr response))))
 539     (smtp-send-command
 540      process
 541      (base64-encode-string
 542       smtp-authenticate-user))
 543     (setq response (smtp-read-response process))
 544     (if (or (null (car response))
 545             (not (integerp (car response)))
 546             (>= (car response) 400))
 547         (throw 'done (car (cdr response))))
 548     (smtp-send-command
 549      process
 550      (setq secure-word (unwind-protect
 551                            (base64-encode-string secure-word)
 552                          (fillarray secure-word 0))) t)
 553     (fillarray secure-word 0)
 554     (setq response (smtp-read-response process))
 555     (if (or (null (car response))
 556             (not (integerp (car response)))
 557             (>= (car response) 400))
 558         (throw 'done (car (cdr response))))))
 559
 560 (defun smtp-auth-anonymous (process &optional token)
 561   (let (response)
 562     (smtp-send-command
 563      process "AUTH ANONYMOUS")
 564     (setq response (smtp-read-response process))
 565     (if (or (null (car response))
 566             (not (integerp (car response)))
 567             (>= (car response) 400))
 568         (throw 'done (car (cdr response))))
 569     (smtp-send-command process
 570                        (base64-encode-string
 571                         (or token
 572                             user-mail-address
 573                             "")))
 574     (setq response (smtp-read-response process))
 575     (if (or (null (car response))
 576             (not (integerp (car response)))
 577             (>= (car response) 400))
 578         (throw 'done (car (cdr response))))))
 579
 580 (defun smtp-auth-scram-md5 (process)
 581   ;; now tesing
 582   (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
 583                      response secure-word)
 584     (smtp-send-command process "AUTH SCRAM-MD5")
 585     (setq response (smtp-read-response process))
 586     (if (or (null (car response))
 587             (not (integerp (car response)))
 588             (>= (car response) 400))
 589         (throw 'done (car (cdr response))))
 590     (unwind-protect
 591         (smtp-send-command
 592          process
 593          (setq secure-word
 594                (base64-encode-string
 595                 (setq client-msg-1
 596                       (sasl-scram-md5-client-msg-1
 597                        smtp-authenticate-user)))) t)
 598       (fillarray secure-word 0))
 599     (setq response (smtp-read-response process))
 600     (if (or (null (car response))
 601             (not (integerp (car response)))
 602             (>= (car response) 400))
 603         (progn
 604           (fillarray client-msg-1 0)
 605           (throw 'done (car (cdr response)))))
 606     (setq secure-word
 607           (unwind-protect
 608               (substring (car (cdr response)) 4)
 609             (fillarray (car (cdr response)) 0)))
 610     (setq server-msg-1
 611           (unwind-protect
 612               (base64-decode-string secure-word)
 613             (fillarray secure-word 0)))
 614     (setq secure-word
 615           (sasl-scram-md5-client-msg-2
 616            server-msg-1 client-msg-1
 617            (setq salted-pass
 618                  (sasl-scram-md5-make-salted-pass
 619                   smtp-authenticate-passphrase server-msg-1))))
 620     (setq secure-word
 621           (unwind-protect
 622               (base64-encode-string secure-word)
 623             (fillarray secure-word 0)))
 624     (unwind-protect
 625         (smtp-send-command process secure-word t)
 626       (fillarray secure-word 0))
 627     (setq response (smtp-read-response process))
 628     (if (or (null (car response))
 629             (not (integerp (car response)))
 630             (>= (car response) 400))
 631         (progn
 632           (fillarray salted-pass 0)
 633           (fillarray server-msg-1 0)
 634           (fillarray client-msg-1 0)
 635           (throw 'done (car (cdr response)))))
 636     (setq server-msg-2
 637           (unwind-protect
 638               (base64-decode-string
 639                (setq secure-word
 640                      (substring (car (cdr response)) 4)))
 641             (fillarray secure-word 0)))
 642     (if (null
 643          (unwind-protect
 644              (sasl-scram-md5-authenticate-server
 645               server-msg-1
 646               server-msg-2
 647               client-msg-1
 648               salted-pass)
 649            (fillarray salted-pass 0)
 650            (fillarray server-msg-1 0)
 651            (fillarray server-msg-2 0)
 652            (fillarray client-msg-1 0)))
 653         (throw 'done nil))
 654     (smtp-send-command process "")
 655     (setq response (smtp-read-response process))
 656     (if (or (null (car response))
 657             (not (integerp (car response)))
 658             (>= (car response) 400))
 659         (throw 'done (car (cdr response)))) ))
 660
 661 (defun smtp-auth-digest-md5 (process)
 662   "Login to server using the AUTH DIGEST-MD5 method."
 663   (let (user realm response)
 664     (smtp-send-command process "AUTH DIGEST-MD5")
 665     (setq response (smtp-read-response process))
 666     (if (or (null (car response))
 667             (not (integerp (car response)))
 668             (>= (car response) 400))
 669         (throw 'done (car (cdr response))))
 670     (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 671                       smtp-authenticate-user)
 672         (setq user (match-string 1 smtp-authenticate-user)
 673               realm (match-string 2 smtp-authenticate-user))
 674       (setq user smtp-authenticate-user
 675             realm nil))
 676     (smtp-send-command process
 677                        (base64-encode-string
 678                         (sasl-digest-md5-digest-response
 679                          (base64-decode-string
 680                           (substring (car (cdr response)) 4))
 681                          user
 682                          smtp-authenticate-passphrase
 683                          "smtp" smtp-server realm)
 684                         'no-line-break) t)
 685     (setq response (smtp-read-response process))
 686     (if (or (null (car response))
 687             (not (integerp (car response)))
 688             (>= (car response) 400))
 689         (throw 'done (car (cdr response))))
 690     (smtp-send-command process "")))
 691
 692 (provide 'smtp)
 693
 694 ;;; smtp.el ends here