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-and-compile
  38   (autoload 'starttls-open-stream "starttls")
  39   (autoload 'starttls-negotiate "starttls")
  40   (autoload 'sasl-cram-md5 "sasl")
  41   (autoload 'sasl-plain "sasl")
  42   (autoload 'sasl-scram-md5-client-msg-1 "sasl")
  43   (autoload 'sasl-scram-md5-client-msg-2 "sasl")
  44   (autoload 'sasl-scram-md5-authenticate-server "sasl"))
  45
  46 (eval-when-compile (require 'cl))       ; push
  47
  48 (defgroup smtp nil
  49   "SMTP protocol for sending mail."
  50   :group 'mail)
  51
  52 (defcustom smtp-default-server nil
  53   "*Specify default SMTP server."
  54   :type '(choice (const nil) string)
  55   :group 'smtp)
  56
  57 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  58   "*The name of the host running SMTP server.  It can also be a function
  59 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  60   :type '(choice (string :tag "Name")
  61                  (function :tag "Function"))
  62   :group 'smtp)
  63
  64 (defcustom smtp-service "smtp"
  65   "*SMTP service port number. \"smtp\" or 25."
  66   :type '(choice (integer :tag "25" 25)
  67                  (string :tag "smtp" "smtp"))
  68   :group 'smtp)
  69
  70 (defcustom smtp-use-8bitmime t
  71   "*If non-nil, use ESMTP 8BITMIME if available."
  72   :type 'boolean
  73   :group 'smtp)
  74
  75 (defcustom smtp-local-domain nil
  76   "*Local domain name without a host name.
  77 If the function (system-name) returns the full internet address,
  78 don't define this value."
  79   :type '(choice (const nil) string)
  80   :group 'smtp)
  81
  82 (defcustom smtp-debug-info nil
  83   "*smtp debug info printout. messages and process buffer."
  84   :type 'boolean
  85   :group 'smtp)
  86
  87 (defcustom smtp-notify-success nil
  88   "*If non-nil, notification for successful mail delivery is returned
  89  to user (RFC1891)."
  90   :type 'boolean
  91   :group 'smtp)
  92
  93 (defcustom smtp-authenticate-type nil
  94   "*SMTP authentication mechanism (RFC2554)."
  95   :type 'symbol
  96   :group 'smtp)
  97
  98 (defvar smtp-authenticate-user nil)
  99 (defvar smtp-authenticate-passphrase nil)
 100
 101 (defvar smtp-authenticate-method-alist
 102   '((cram-md5 smtp-auth-cram-md5)
 103     (plain smtp-auth-plain)
 104     (login smtp-auth-login)
 105     (anonymous smtp-auth-anonymous)
 106     (scram-md5 smtp-auth-scram-md5)
 107     (digest-md5 smtp-auth-digest-md5)))
 108
 109 (defcustom smtp-connection-type nil
 110   "*SMTP connection type."
 111   :type '(choice (const nil) (const :tag "TLS" starttls))
 112   :group 'smtp)
 113
 114 (defvar smtp-read-point nil)
 115
 116 (defun smtp-make-fqdn ()
 117   "Return user's fully qualified domain name."
 118   (let ((system-name (system-name)))
 119     (cond
 120      (smtp-local-domain
 121       (concat system-name "." smtp-local-domain))
 122      ((string-match "[^.]\\.[^.]" system-name)
 123       system-name)
 124      (t
 125       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 126
 127 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
 128   (let ((server (if (functionp smtp-server)
 129                     (funcall smtp-server sender recipients)
 130                   smtp-server))
 131         process response extensions)
 132     (save-excursion
 133       (set-buffer
 134        (get-buffer-create
 135         (format "*trace of SMTP session to %s*" server)))
 136       (erase-buffer)
 137       (make-local-variable 'smtp-read-point)
 138       (setq smtp-read-point (point-min))
 139
 140       (unwind-protect
 141           (catch 'done
 142             (setq process
 143                   (if smtp-connection-type
 144                       (as-binary-process
 145                        (starttls-open-stream
 146                         "SMTP" (current-buffer) server smtp-service))
 147                     (open-network-stream-as-binary
 148                      "SMTP" (current-buffer) server smtp-service)))
 149
 150             (set-process-filter process 'smtp-process-filter)
 151
 152             (if (eq smtp-connection-type 'force)
 153                 (starttls-negotiate process))
 154
 155             ;; Greeting
 156             (setq response (smtp-read-response process))
 157             (if (or (null (car response))
 158                     (not (integerp (car response)))
 159                     (>= (car response) 400))
 160                 (throw 'done (car (cdr response))))
 161
 162             ;; EHLO
 163             (smtp-send-command process
 164                                (format "EHLO %s" (smtp-make-fqdn)))
 165             (setq response (smtp-read-response process))
 166             (if (or (null (car response))
 167                     (not (integerp (car response)))
 168                     (>= (car response) 400))
 169                 (progn
 170                   ;; HELO
 171                   (smtp-send-command process
 172                                      (format "HELO %s" (smtp-make-fqdn)))
 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               (let ((extension-lines (cdr (cdr response)))
 179                     extension)
 180                 (while extension-lines
 181                   (if (string-match
 182                        "^auth "
 183                        (setq extension
 184                              (downcase (substring (car extension-lines) 4))))
 185                       (while (string-match "\\([^ ]+\\)" extension (match-end 1))
 186                         (push (intern (match-string 1 extension)) extensions))
 187                     (push (intern extension) extensions))
 188                   (setq extension-lines (cdr extension-lines)))))
 189
 190             ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 191             (when (and smtp-connection-type
 192                        (null (eq smtp-connection-type 'force))
 193                        (memq 'starttls extensions))
 194               (smtp-send-command process "STARTTLS")
 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               (starttls-negotiate process))
 201
 202             ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
 203             (when smtp-authenticate-type
 204               (let ((auth (intern smtp-authenticate-type)) method)
 205                 (if (and
 206                      (memq auth extensions)
 207                      (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
 208                     (funcall method process)
 209                   (throw 'smtp-error
 210                          (format "AUTH mechanism %s not available" auth)))))
 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 &optional secure)
 376   (goto-char (point-max))
 377   (if secure
 378       (insert "Here is insecure words.\r\n")
 379     (insert command "\r\n"))
 380   (setq smtp-read-point (point))
 381   (process-send-string process command)
 382   (process-send-string process "\r\n"))
 383
 384 (defun smtp-send-data-1 (process data)
 385   (goto-char (point-max))
 386   (if smtp-debug-info
 387       (insert data "\r\n"))
 388   (setq smtp-read-point (point))
 389   ;; Escape "." at start of a line.
 390   (if (eq (string-to-char data) ?.)
 391       (process-send-string process "."))
 392   (process-send-string process data)
 393   (process-send-string process "\r\n"))
 394
 395 (defun smtp-send-data (process buffer)
 396   (let ((data-continue t)
 397         (sending-data nil)
 398         this-line
 399         this-line-end)
 400
 401     (save-excursion
 402       (set-buffer buffer)
 403       (goto-char (point-min)))
 404
 405     (while data-continue
 406       (save-excursion
 407         (set-buffer buffer)
 408         (beginning-of-line)
 409         (setq this-line (point))
 410         (end-of-line)
 411         (setq this-line-end (point))
 412         (setq sending-data nil)
 413         (setq sending-data (buffer-substring this-line this-line-end))
 414         (if (or (/= (forward-line 1) 0) (eobp))
 415             (setq data-continue nil)))
 416
 417       (smtp-send-data-1 process sending-data))))
 418
 419 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 420   "Get address list suitable for smtp RCPT TO:<address>."
 421   (let ((case-fold-search t)
 422         (simple-address-list "")
 423         this-line
 424         this-line-end
 425         addr-regexp
 426         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 427     (unwind-protect
 428         (save-excursion
 429           ;;
 430           (set-buffer smtp-address-buffer)
 431           (erase-buffer)
 432           (insert (save-excursion
 433                     (set-buffer smtp-text-buffer)
 434                     (buffer-substring-no-properties header-start header-end)))
 435           (goto-char (point-min))
 436           ;; RESENT-* fields should stop processing of regular fields.
 437           (save-excursion
 438             (if (re-search-forward "^RESENT-TO:" header-end t)
 439                 (setq addr-regexp
 440                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 441               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 442
 443           (while (re-search-forward addr-regexp header-end t)
 444             (replace-match "")
 445             (setq this-line (match-beginning 0))
 446             (forward-line 1)
 447             ;; get any continuation lines.
 448             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 449               (forward-line 1))
 450             (setq this-line-end (point-marker))
 451             (setq simple-address-list
 452                   (concat simple-address-list " "
 453                           (mail-strip-quoted-names
 454                            (buffer-substring this-line this-line-end)))))
 455           (erase-buffer)
 456           (insert-string " ")
 457           (insert-string simple-address-list)
 458           (insert-string "\n")
 459           ;; newline --> blank
 460           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 461           ;; comma   --> blank
 462           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 463           ;; tab     --> blank
 464           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 465
 466           (goto-char (point-min))
 467           ;; tidyness in case hook is not robust when it looks at this
 468           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 469
 470           (goto-char (point-min))
 471           (let (recipient-address-list)
 472             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 473               (backward-char 1)
 474               (setq recipient-address-list
 475                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 476                           recipient-address-list)))
 477             recipient-address-list))
 478       (kill-buffer smtp-address-buffer))))
 479
 480 (defun smtp-auth-cram-md5 (process)
 481   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 482         response)
 483     (smtp-send-command process "AUTH CRAM-MD5")
 484     (setq response (smtp-read-response process))
 485     (if (or (null (car response))
 486             (not (integerp (car response)))
 487             (>= (car response) 400))
 488         (throw 'done (car (cdr response))))
 489     (smtp-send-command
 490      process
 491      (setq secure-word (unwind-protect
 492                            (sasl-cram-md5
 493                             smtp-authenticate-user secure-word
 494                             (base64-decode-string
 495                              (substring (car (cdr response)) 4)))
 496                          (fillarray secure-word 0))
 497            secure-word (unwind-protect
 498                            (base64-encode-string secure-word)
 499                          (fillarray secure-word 0))) t)
 500     (fillarray secure-word 0)
 501     (setq response (smtp-read-response process))
 502     (if (or (null (car response))
 503             (not (integerp (car response)))
 504             (>= (car response) 400))
 505         (throw 'done (car (cdr response))))))
 506
 507 (defun smtp-auth-plain (process)
 508   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 509         response)
 510     (smtp-send-command
 511      process
 512      (setq secure-word (unwind-protect
 513                            (sasl-plain "" smtp-authenticate-user secure-word)
 514                          (fillarray secure-word 0))
 515            secure-word (unwind-protect
 516                            (base64-encode-string secure-word)
 517                          (fillarray secure-word 0))
 518            secure-word (unwind-protect
 519                            (concat "AUTH PLAIN " secure-word)
 520                          (fillarray secure-word 0))) t)
 521     (fillarray secure-word 0)
 522     (setq response (smtp-read-response process))
 523     (if (or (null (car response))
 524             (not (integerp (car response)))
 525             (>= (car response) 400))
 526         (throw 'done (car (cdr response))))))
 527
 528 (defun smtp-auth-login (process)
 529   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 530         response)
 531     (smtp-send-command process "AUTH LOGIN")
 532     (setq response (smtp-read-response process))
 533     (if (or (null (car response))
 534             (not (integerp (car response)))
 535             (>= (car response) 400))
 536         (throw 'done (car (cdr response))))
 537     (smtp-send-command
 538      process
 539      (base64-encode-string
 540       smtp-authenticate-user))
 541     (setq response (smtp-read-response process))
 542     (if (or (null (car response))
 543             (not (integerp (car response)))
 544             (>= (car response) 400))
 545         (throw 'done (car (cdr response))))
 546     (smtp-send-command
 547      process
 548      (setq secure-word (unwind-protect
 549                            (base64-encode-string secure-word)
 550                          (fillarray secure-word 0))) t)
 551     (fillarray secure-word 0)
 552     (setq response (smtp-read-response process))
 553     (if (or (null (car response))
 554             (not (integerp (car response)))
 555             (>= (car response) 400))
 556         (throw 'done (car (cdr response))))))
 557
 558 (defun smtp-auth-anonymous (process &optional token)
 559   (let (response)
 560     (smtp-send-command
 561      process "AUTH ANONYMOUS")
 562     (setq response (smtp-read-response process))
 563     (if (or (null (car response))
 564             (not (integerp (car response)))
 565             (>= (car response) 400))
 566         (throw 'done (car (cdr response))))
 567     (smtp-send-command process
 568                        (base64-encode-string
 569                         (or token
 570                             user-mail-address
 571                             "")))
 572     (setq response (smtp-read-response process))
 573     (if (or (null (car response))
 574             (not (integerp (car response)))
 575             (>= (car response) 400))
 576         (throw 'done (car (cdr response))))))
 577
 578 (defun smtp-auth-scram-md5 (process)
 579   ;; now tesing
 580   (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
 581                      response secure-word)
 582     (smtp-send-command process "AUTH SCRAM-MD5")
 583     (setq response (smtp-read-response process))
 584     (if (or (null (car response))
 585             (not (integerp (car response)))
 586             (>= (car response) 400))
 587         (throw 'done (car (cdr response))))
 588     (unwind-protect
 589         (smtp-send-command
 590          process
 591          (setq secure-word
 592                (base64-encode-string
 593                 (setq client-msg-1
 594                       (sasl-scram-md5-client-msg-1
 595                        smtp-authenticate-user)))) t)
 596       (fillarray secure-word 0))
 597     (setq response (smtp-read-response process))
 598     (if (or (null (car response))
 599             (not (integerp (car response)))
 600             (>= (car response) 400))
 601         (progn
 602           (fillarray client-msg-1 0)
 603           (throw 'done (car (cdr response)))))
 604     (setq secure-word
 605           (unwind-protect
 606               (substring (car (cdr response)) 4)
 607             (fillarray (car (cdr response)) 0)))
 608     (setq server-msg-1
 609           (unwind-protect
 610               (base64-decode-string secure-word)
 611             (fillarray secure-word 0)))
 612     (setq secure-word
 613           (sasl-scram-md5-client-msg-2
 614            server-msg-1 client-msg-1
 615            (setq salted-pass
 616                  (sasl-scram-md5-make-salted-pass
 617                   smtp-authenticate-passphrase server-msg-1))))
 618     (setq secure-word
 619           (unwind-protect
 620               (base64-encode-string secure-word)
 621             (fillarray secure-word 0)))
 622     (unwind-protect
 623         (smtp-send-command process secure-word t)
 624       (fillarray secure-word 0))
 625     (setq response (smtp-read-response process))
 626     (if (or (null (car response))
 627             (not (integerp (car response)))
 628             (>= (car response) 400))
 629         (progn
 630           (fillarray salted-pass 0)
 631           (fillarray server-msg-1 0)
 632           (fillarray client-msg-1 0)
 633           (throw 'done (car (cdr response)))))
 634     (setq server-msg-2
 635           (unwind-protect
 636               (base64-decode-string
 637                (setq secure-word
 638                      (substring (car (cdr response)) 4)))
 639             (fillarray secure-word 0)))
 640     (if (null
 641          (unwind-protect
 642              (sasl-scram-md5-authenticate-server
 643               server-msg-1
 644               server-msg-2
 645               client-msg-1
 646               salted-pass)
 647            (fillarray salted-pass 0)
 648            (fillarray server-msg-1 0)
 649            (fillarray server-msg-2 0)
 650            (fillarray client-msg-1 0)))
 651         (throw 'done nil))
 652     (smtp-send-command process "")
 653     (setq response (smtp-read-response process))
 654     (if (or (null (car response))
 655             (not (integerp (car response)))
 656             (>= (car response) 400))
 657         (throw 'done (car (cdr response)))) ))
 658
 659 (defun smtp-auth-digest-md5 (process)
 660   "Login to server using the AUTH DIGEST-MD5 method."
 661   (let (user realm responce)
 662     (smtp-send-command process "AUTH DIGEST-MD5")
 663     (setq response (smtp-read-response process))
 664     (if (or (null (car response))
 665             (not (integerp (car response)))
 666             (>= (car response) 400))
 667         (throw 'done (car (cdr response))))
 668     (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 669                       smtp-authenticate-user)
 670         (setq user (match-string 1 smtp-authenticate-user)
 671               realm (match-string 2 smtp-authenticate-user))
 672       (setq user smtp-authenticate-user
 673             realm nil))
 674     (smtp-send-command process
 675                        (base64-encode-string
 676                         (sasl-digest-md5-digest-response
 677                          (base64-decode-string
 678                           (substring (car (cdr response)) 4))
 679                          user
 680                          smtp-authenticate-passphrase
 681                          "smtp" smtp-server realm)
 682                         'no-line-break))
 683     (setq response (smtp-read-response process))
 684     (if (or (null (car response))
 685             (not (integerp (car response)))
 686             (>= (car response) 400))
 687         (throw 'done (car (cdr response))))
 688     (smtp-send-command process "")))
 689
 690 (provide 'smtp)
 691
 692 ;;; smtp.el ends here