code.delx.au - gnu-emacs/blob - lisp/net/sasl-digest.el

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