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