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               ;; for sendmail warning XXX
 204               (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
 205               (setq response (smtp-read-response process)))
 206
 207             ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
 208             (when smtp-authenticate-type
 209               (let ((auth smtp-authenticate-type) method)
 210                 (if (and
 211                      (memq auth extensions)
 212                      (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
 213                     (funcall method process)
 214                   (throw 'done
 215                          (format "AUTH mechanism %s not available" auth)))))
 216
 217             ;; ONEX --- One message transaction only (sendmail extension?)
 218 ;;;         (if (or (memq 'onex extensions)
 219 ;;;                 (memq 'xone extensions))
 220 ;;;             (progn
 221 ;;;               (smtp-send-command process "ONEX")
 222 ;;;               (setq response (smtp-read-response process))
 223 ;;;               (if (or (null (car response))
 224 ;;;                       (not (integerp (car response)))
 225 ;;;                       (>= (car response) 400))
 226 ;;;                   (throw 'done (car (cdr response))))))
 227
 228             ;; VERB --- Verbose (sendmail extension?)
 229 ;;;         (if (and smtp-debug-info
 230 ;;;                  (or (memq 'verb extensions)
 231 ;;;                      (memq 'xvrb extensions)))
 232 ;;;             (progn
 233 ;;;               (smtp-send-command process "VERB")
 234 ;;;               (setq response (smtp-read-response process))
 235 ;;;               (if (or (null (car response))
 236 ;;;                       (not (integerp (car response)))
 237 ;;;                       (>= (car response) 400))
 238 ;;;                   (throw 'done (car (cdr response))))))
 239
 240             ;; XUSR --- Initial (user) submission (sendmail extension?)
 241 ;;;         (if (memq 'xusr extensions)
 242 ;;;             (progn
 243 ;;;               (smtp-send-command process "XUSR")
 244 ;;;               (setq response (smtp-read-response process))
 245 ;;;               (if (or (null (car response))
 246 ;;;                       (not (integerp (car response)))
 247 ;;;                       (>= (car response) 400))
 248 ;;;                   (throw 'done (car (cdr response))))))
 249
 250             ;; MAIL FROM:<sender>
 251             (smtp-send-command
 252              process
 253              (format "MAIL FROM:<%s>%s%s"
 254                      sender
 255                      ;; SIZE --- Message Size Declaration (RFC1870)
 256                      (if (memq 'size extensions)
 257                          (format " SIZE=%d"
 258                                  (save-excursion
 259                                    (set-buffer smtp-text-buffer)
 260                                    (+ (- (point-max) (point-min))
 261                                       ;; Add one byte for each change-of-line
 262                                       ;; because or CR-LF representation:
 263                                       (count-lines (point-min) (point-max))
 264                                       ;; For some reason, an empty line is
 265                                       ;; added to the message.  Maybe this
 266                                       ;; is a bug, but it can't hurt to add
 267                                       ;; those two bytes anyway:
 268                                       2)))
 269                        "")
 270                      ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 271                      (if (and (memq '8bitmime extensions)
 272                               smtp-use-8bitmime)
 273                          " BODY=8BITMIME"
 274                        "")))
 275             (setq response (smtp-read-response process))
 276             (if (or (null (car response))
 277                     (not (integerp (car response)))
 278                     (>= (car response) 400))
 279                 (throw 'done (car (cdr response))))
 280
 281             ;; RCPT TO:<recipient>
 282             (while recipients
 283               (smtp-send-command process
 284                                  (format
 285                                   (if smtp-notify-success
 286                                       "RCPT TO:<%s> NOTIFY=SUCCESS"
 287                                     "RCPT TO:<%s>")
 288                                   (car recipients)))
 289               (setq recipients (cdr recipients))
 290               (setq response (smtp-read-response process))
 291               (if (or (null (car response))
 292                       (not (integerp (car response)))
 293                       (>= (car response) 400))
 294                   (throw 'done (car (cdr response)))))
 295
 296             ;; DATA
 297             (smtp-send-command process "DATA")
 298             (setq response (smtp-read-response process))
 299             (if (or (null (car response))
 300                     (not (integerp (car response)))
 301                     (>= (car response) 400))
 302                 (throw 'done (car (cdr response))))
 303
 304             ;; Mail contents
 305             (smtp-send-data process smtp-text-buffer)
 306
 307             ;; DATA end "."
 308             (smtp-send-command process ".")
 309             (setq response (smtp-read-response process))
 310             (if (or (null (car response))
 311                     (not (integerp (car response)))
 312                     (>= (car response) 400))
 313                 (throw 'done (car (cdr response))))
 314
 315             t)
 316
 317         (if (and process
 318                  (memq (process-status process) '(open run)))
 319         (progn
 320           ;; QUIT
 321           (smtp-send-command process "QUIT")
 322           (smtp-read-response process)
 323           (delete-process process)))))))
 324
 325 (defun smtp-process-filter (process output)
 326   (save-excursion
 327     (set-buffer (process-buffer process))
 328     (goto-char (point-max))
 329     (insert output)))
 330
 331 (defun smtp-read-response (process)
 332   (let ((case-fold-search nil)
 333         (response-strings nil)
 334         (response-continue t)
 335         (return-value '(nil ()))
 336         match-end)
 337
 338     (while response-continue
 339       (goto-char smtp-read-point)
 340       (while (not (search-forward "\r\n" nil t))
 341         (accept-process-output process)
 342         (goto-char smtp-read-point))
 343
 344       (setq match-end (point))
 345       (setq response-strings
 346             (cons (buffer-substring smtp-read-point (- match-end 2))
 347                   response-strings))
 348
 349       (goto-char smtp-read-point)
 350       (if (looking-at "[0-9]+ ")
 351           (let ((begin (match-beginning 0))
 352                 (end (match-end 0)))
 353             (if smtp-debug-info
 354                 (message "%s" (car response-strings)))
 355
 356             (setq smtp-read-point match-end)
 357
 358             ;; ignore lines that start with "0"
 359             (if (looking-at "0[0-9]+ ")
 360                 nil
 361               (setq response-continue nil)
 362               (setq return-value
 363                     (cons (string-to-int
 364                            (buffer-substring begin end))
 365                           (nreverse response-strings)))))
 366
 367         (if (looking-at "[0-9]+-")
 368             (progn (if smtp-debug-info
 369                      (message "%s" (car response-strings)))
 370                    (setq smtp-read-point match-end)
 371                    (setq response-continue t))
 372           (progn
 373             (setq smtp-read-point match-end)
 374             (setq response-continue nil)
 375             (setq return-value
 376                   (cons nil (nreverse response-strings)))))))
 377     (setq smtp-read-point match-end)
 378     return-value))
 379
 380 (defun smtp-send-command (process command &optional secure)
 381   (goto-char (point-max))
 382   (if secure
 383       (insert "Here is insecure words.\r\n")
 384     (insert command "\r\n"))
 385   (setq smtp-read-point (point))
 386   (process-send-string process command)
 387   (process-send-string process "\r\n"))
 388
 389 (defun smtp-send-data-1 (process data)
 390   (goto-char (point-max))
 391   (if smtp-debug-info
 392       (insert data "\r\n"))
 393   (setq smtp-read-point (point))
 394   ;; Escape "." at start of a line.
 395   (if (eq (string-to-char data) ?.)
 396       (process-send-string process "."))
 397   (process-send-string process data)
 398   (process-send-string process "\r\n"))
 399
 400 (defun smtp-send-data (process buffer)
 401   (let ((data-continue t)
 402         (sending-data nil)
 403         this-line
 404         this-line-end)
 405
 406     (save-excursion
 407       (set-buffer buffer)
 408       (goto-char (point-min)))
 409
 410     (while data-continue
 411       (save-excursion
 412         (set-buffer buffer)
 413         (beginning-of-line)
 414         (setq this-line (point))
 415         (end-of-line)
 416         (setq this-line-end (point))
 417         (setq sending-data nil)
 418         (setq sending-data (buffer-substring this-line this-line-end))
 419         (if (or (/= (forward-line 1) 0) (eobp))
 420             (setq data-continue nil)))
 421
 422       (smtp-send-data-1 process sending-data))))
 423
 424 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 425   "Get address list suitable for smtp RCPT TO:<address>."
 426   (let ((simple-address-list "")
 427         this-line
 428         this-line-end
 429         addr-regexp
 430         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 431     (unwind-protect
 432         (save-excursion
 433           ;;
 434           (set-buffer smtp-address-buffer)
 435           (setq case-fold-search t)
 436           (erase-buffer)
 437           (insert (save-excursion
 438                     (set-buffer smtp-text-buffer)
 439                     (buffer-substring-no-properties header-start header-end)))
 440           (goto-char (point-min))
 441           ;; RESENT-* fields should stop processing of regular fields.
 442           (save-excursion
 443             (if (re-search-forward "^RESENT-TO:" header-end t)
 444                 (setq addr-regexp
 445                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 446               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 447
 448           (while (re-search-forward addr-regexp header-end t)
 449             (replace-match "")
 450             (setq this-line (match-beginning 0))
 451             (forward-line 1)
 452             ;; get any continuation lines.
 453             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 454               (forward-line 1))
 455             (setq this-line-end (point-marker))
 456             (setq simple-address-list
 457                   (concat simple-address-list " "
 458                           (mail-strip-quoted-names
 459                            (buffer-substring this-line this-line-end)))))
 460           (erase-buffer)
 461           (insert-string " ")
 462           (insert-string simple-address-list)
 463           (insert-string "\n")
 464           ;; newline --> blank
 465           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 466           ;; comma   --> blank
 467           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 468           ;; tab     --> blank
 469           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 470
 471           (goto-char (point-min))
 472           ;; tidyness in case hook is not robust when it looks at this
 473           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 474
 475           (goto-char (point-min))
 476           (let (recipient-address-list)
 477             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 478               (backward-char 1)
 479               (setq recipient-address-list
 480                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 481                           recipient-address-list)))
 482             recipient-address-list))
 483       (kill-buffer smtp-address-buffer))))
 484
 485 (defun smtp-auth-cram-md5 (process)
 486   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 487         response)
 488     (smtp-send-command process "AUTH CRAM-MD5")
 489     (setq response (smtp-read-response process))
 490     (if (or (null (car response))
 491             (not (integerp (car response)))
 492             (>= (car response) 400))
 493         (throw 'done (car (cdr response))))
 494     (smtp-send-command
 495      process
 496      (setq secure-word (unwind-protect
 497                            (sasl-cram-md5
 498                             smtp-authenticate-user secure-word
 499                             (base64-decode-string
 500                              (substring (car (cdr response)) 4)))
 501                          (fillarray secure-word 0))
 502            secure-word (unwind-protect
 503                            (base64-encode-string secure-word)
 504                          (fillarray secure-word 0))) t)
 505     (fillarray secure-word 0)
 506     (setq response (smtp-read-response process))
 507     (if (or (null (car response))
 508             (not (integerp (car response)))
 509             (>= (car response) 400))
 510         (throw 'done (car (cdr response))))))
 511
 512 (defun smtp-auth-plain (process)
 513   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 514         response)
 515     (smtp-send-command
 516      process
 517      (setq secure-word (unwind-protect
 518                            (sasl-plain "" smtp-authenticate-user secure-word)
 519                          (fillarray secure-word 0))
 520            secure-word (unwind-protect
 521                            (base64-encode-string secure-word)
 522                          (fillarray secure-word 0))
 523            secure-word (unwind-protect
 524                            (concat "AUTH PLAIN " secure-word)
 525                          (fillarray secure-word 0))) t)
 526     (fillarray secure-word 0)
 527     (setq response (smtp-read-response process))
 528     (if (or (null (car response))
 529             (not (integerp (car response)))
 530             (>= (car response) 400))
 531         (throw 'done (car (cdr response))))))
 532
 533 (defun smtp-auth-login (process)
 534   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 535         response)
 536     (smtp-send-command process "AUTH LOGIN")
 537     (setq response (smtp-read-response process))
 538     (if (or (null (car response))
 539             (not (integerp (car response)))
 540             (>= (car response) 400))
 541         (throw 'done (car (cdr response))))
 542     (smtp-send-command
 543      process
 544      (base64-encode-string
 545       smtp-authenticate-user))
 546     (setq response (smtp-read-response process))
 547     (if (or (null (car response))
 548             (not (integerp (car response)))
 549             (>= (car response) 400))
 550         (throw 'done (car (cdr response))))
 551     (smtp-send-command
 552      process
 553      (setq secure-word (unwind-protect
 554                            (base64-encode-string secure-word)
 555                          (fillarray secure-word 0))) t)
 556     (fillarray secure-word 0)
 557     (setq response (smtp-read-response process))
 558     (if (or (null (car response))
 559             (not (integerp (car response)))
 560             (>= (car response) 400))
 561         (throw 'done (car (cdr response))))))
 562
 563 (defun smtp-auth-anonymous (process &optional token)
 564   (let (response)
 565     (smtp-send-command
 566      process "AUTH ANONYMOUS")
 567     (setq response (smtp-read-response process))
 568     (if (or (null (car response))
 569             (not (integerp (car response)))
 570             (>= (car response) 400))
 571         (throw 'done (car (cdr response))))
 572     (smtp-send-command process
 573                        (base64-encode-string
 574                         (or token
 575                             user-mail-address
 576                             "")))
 577     (setq response (smtp-read-response process))
 578     (if (or (null (car response))
 579             (not (integerp (car response)))
 580             (>= (car response) 400))
 581         (throw 'done (car (cdr response))))))
 582
 583 (defun smtp-auth-scram-md5 (process)
 584   ;; now tesing
 585   (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
 586                      response secure-word)
 587     (smtp-send-command process "AUTH SCRAM-MD5")
 588     (setq response (smtp-read-response process))
 589     (if (or (null (car response))
 590             (not (integerp (car response)))
 591             (>= (car response) 400))
 592         (throw 'done (car (cdr response))))
 593     (unwind-protect
 594         (smtp-send-command
 595          process
 596          (setq secure-word
 597                (base64-encode-string
 598                 (setq client-msg-1
 599                       (sasl-scram-md5-client-msg-1
 600                        smtp-authenticate-user)))) t)
 601       (fillarray secure-word 0))
 602     (setq response (smtp-read-response process))
 603     (if (or (null (car response))
 604             (not (integerp (car response)))
 605             (>= (car response) 400))
 606         (progn
 607           (fillarray client-msg-1 0)
 608           (throw 'done (car (cdr response)))))
 609     (setq secure-word
 610           (unwind-protect
 611               (substring (car (cdr response)) 4)
 612             (fillarray (car (cdr response)) 0)))
 613     (setq server-msg-1
 614           (unwind-protect
 615               (base64-decode-string secure-word)
 616             (fillarray secure-word 0)))
 617     (setq secure-word
 618           (sasl-scram-md5-client-msg-2
 619            server-msg-1 client-msg-1
 620            (setq salted-pass
 621                  (sasl-scram-md5-make-salted-pass
 622                   smtp-authenticate-passphrase server-msg-1))))
 623     (setq secure-word
 624           (unwind-protect
 625               (base64-encode-string secure-word)
 626             (fillarray secure-word 0)))
 627     (unwind-protect
 628         (smtp-send-command process secure-word t)
 629       (fillarray secure-word 0))
 630     (setq response (smtp-read-response process))
 631     (if (or (null (car response))
 632             (not (integerp (car response)))
 633             (>= (car response) 400))
 634         (progn
 635           (fillarray salted-pass 0)
 636           (fillarray server-msg-1 0)
 637           (fillarray client-msg-1 0)
 638           (throw 'done (car (cdr response)))))
 639     (setq server-msg-2
 640           (unwind-protect
 641               (base64-decode-string
 642                (setq secure-word
 643                      (substring (car (cdr response)) 4)))
 644             (fillarray secure-word 0)))
 645     (if (null
 646          (unwind-protect
 647              (sasl-scram-md5-authenticate-server
 648               server-msg-1
 649               server-msg-2
 650               client-msg-1
 651               salted-pass)
 652            (fillarray salted-pass 0)
 653            (fillarray server-msg-1 0)
 654            (fillarray server-msg-2 0)
 655            (fillarray client-msg-1 0)))
 656         (throw 'done nil))
 657     (smtp-send-command process "")
 658     (setq response (smtp-read-response process))
 659     (if (or (null (car response))
 660             (not (integerp (car response)))
 661             (>= (car response) 400))
 662         (throw 'done (car (cdr response)))) ))
 663
 664 (defun smtp-auth-digest-md5 (process)
 665   "Login to server using the AUTH DIGEST-MD5 method."
 666   (let (user realm response)
 667     (smtp-send-command process "AUTH DIGEST-MD5")
 668     (setq response (smtp-read-response process))
 669     (if (or (null (car response))
 670             (not (integerp (car response)))
 671             (>= (car response) 400))
 672         (throw 'done (car (cdr response))))
 673     (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 674                       smtp-authenticate-user)
 675         (setq user (match-string 1 smtp-authenticate-user)
 676               realm (match-string 2 smtp-authenticate-user))
 677       (setq user smtp-authenticate-user
 678             realm nil))
 679     (smtp-send-command process
 680                        (base64-encode-string
 681                         (sasl-digest-md5-digest-response
 682                          (base64-decode-string
 683                           (substring (car (cdr response)) 4))
 684                          user
 685                          smtp-authenticate-passphrase
 686                          "smtp" smtp-server realm)
 687                         'no-line-break) t)
 688     (setq response (smtp-read-response process))
 689     (if (or (null (car response))
 690             (not (integerp (car response)))
 691             (>= (car response) 400))
 692         (throw 'done (car (cdr response))))
 693     (smtp-send-command process "")))
 694
 695 (provide 'smtp)
 696
 697 ;;; smtp.el ends here