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