cgit.sxemacs.org Git - gnus/blob - lisp/sasl-digest.el

   1 ;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
   2
   3 ;; Copyright (C) 2000, 2007-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Daiki Ueno <ueno@unixuser.org>
   6 ;;      Kenichi OKADA <okada@opaopa.org>
   7 ;; Keywords: SASL, DIGEST-MD5
   8 ;; Package: sasl
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This program is implemented from draft-leach-digest-sasl-05.txt.
  28 ;;
  29 ;; It is caller's responsibility to base64-decode challenges and
  30 ;; base64-encode responses in IMAP4 AUTHENTICATE command.
  31 ;;
  32 ;; Passphrase should be longer than 16 bytes. (See RFC 2195)
  33
  34 ;;; Commentary:
  35
  36 (require 'sasl)
  37 (require 'hmac-md5)
  38
  39 (defvar sasl-digest-md5-nonce-count 1)
  40 (defvar sasl-digest-md5-unique-id-function
  41   sasl-unique-id-function)
  42
  43 (defvar sasl-digest-md5-syntax-table
  44   (let ((table (make-syntax-table)))
  45     (modify-syntax-entry ?= "." table)
  46     (modify-syntax-entry ?, "." table)
  47     table)
  48   "A syntax table for parsing digest-challenge attributes.")
  49
  50 (defconst sasl-digest-md5-steps
  51   '(ignore                              ;no initial response
  52     sasl-digest-md5-response
  53     ignore))                            ;""
  54
  55 (defun sasl-digest-md5-parse-string (string)
  56   "Parse STRING and return a property list.
  57 The value is a cons cell of the form \(realm nonce qop-options stale maxbuf
  58 charset algorithm cipher-opts auth-param)."
  59   (with-temp-buffer
  60     (set-syntax-table sasl-digest-md5-syntax-table)
  61     (save-excursion
  62       (insert string)
  63       (goto-char (point-min))
  64       (insert "(")
  65       (while (progn (forward-sexp) (not (eobp)))
  66         (delete-char 1)
  67         (insert " "))
  68       (insert ")")
  69       (read (point-min-marker)))))
  70
  71 (defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name)
  72   (concat serv-type "/" host
  73           (if (and serv-name
  74                    (not (string= host serv-name)))
  75               (concat "/" serv-name))))
  76
  77 (defun sasl-digest-md5-cnonce ()
  78   (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function))
  79     (sasl-unique-id)))
  80
  81 (defun sasl-digest-md5-response-value (username
  82                                        realm
  83                                        nonce
  84                                        cnonce
  85                                        nonce-count
  86                                        qop
  87                                        digest-uri
  88                                        authzid)
  89   (let ((passphrase
  90          (sasl-read-passphrase
  91           (format "DIGEST-MD5 passphrase for %s: "
  92                   username))))
  93     (unwind-protect
  94         (encode-hex-string
  95          (md5-binary
  96           (concat
  97            (encode-hex-string
  98             (md5-binary (concat (md5-binary
  99                                  (concat username ":" realm ":" passphrase))
 100                                 ":" nonce ":" cnonce
 101                                 (if authzid
 102                                     (concat ":" authzid)))))
 103            ":" nonce
 104            ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
 105            (encode-hex-string
 106             (md5-binary
 107              (concat "AUTHENTICATE:" digest-uri
 108                      (if (member qop '("auth-int" "auth-conf"))
 109                          ":00000000000000000000000000000000")))))))
 110       (fillarray passphrase 0))))
 111
 112 (defun sasl-digest-md5-response (client step)
 113   (let* ((plist
 114           (sasl-digest-md5-parse-string (sasl-step-data step)))
 115          (realm
 116           (or (sasl-client-property client 'realm)
 117               (plist-get plist 'realm))) ;need to check
 118          (nonce-count
 119           (or (sasl-client-property client 'nonce-count)
 120                sasl-digest-md5-nonce-count))
 121          (qop
 122           (or (sasl-client-property client 'qop)
 123               "auth"))
 124          (digest-uri
 125           (sasl-digest-md5-digest-uri
 126            (sasl-client-service client)(sasl-client-server client)))
 127          (cnonce
 128           (or (sasl-client-property client 'cnonce)
 129               (sasl-digest-md5-cnonce))))
 130     (sasl-client-set-property client 'nonce-count (1+ nonce-count))
 131     (unless (string= qop "auth")
 132       (sasl-error (format "Unsupported \"qop-value\": %s" qop)))
 133     (concat
 134      "username=\"" (sasl-client-name client) "\","
 135      "realm=\"" realm "\","
 136      "nonce=\"" (plist-get plist 'nonce) "\","
 137      "cnonce=\"" cnonce "\","
 138      (format "nc=%08x," nonce-count)
 139      "digest-uri=\"" digest-uri "\","
 140      "qop=" qop ","
 141      "response="
 142      (sasl-digest-md5-response-value
 143       (sasl-client-name client)
 144       realm
 145       (plist-get plist 'nonce)
 146       cnonce
 147       nonce-count
 148       qop
 149       digest-uri
 150       (plist-get plist 'authzid)))))
 151
 152 (put 'sasl-digest 'sasl-mechanism
 153      (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps))
 154
 155 (provide 'sasl-digest)
 156
 157 ;;; sasl-digest.el ends here