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, 2009, 2010, 2011  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 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This program is implemented from draft-leach-digest-sasl-05.txt.
  27 ;;
  28 ;; It is caller's responsibility to base64-decode challenges and
  29 ;; base64-encode responses in IMAP4 AUTHENTICATE command.
  30 ;;
  31 ;; Passphrase should be longer than 16 bytes. (See RFC 2195)
  32
  33 ;;; Commentary:
  34
  35 (require 'sasl)
  36 (require 'hmac-md5)
  37
  38 (defvar sasl-digest-md5-nonce-count 1)
  39 (defvar sasl-digest-md5-unique-id-function
  40   sasl-unique-id-function)
  41
  42 (defvar sasl-digest-md5-syntax-table
  43   (let ((table (make-syntax-table)))
  44     (modify-syntax-entry ?= "." table)
  45     (modify-syntax-entry ?, "." table)
  46     table)
  47   "A syntax table for parsing digest-challenge attributes.")
  48
  49 (defconst sasl-digest-md5-steps
  50   '(ignore                              ;no initial response
  51     sasl-digest-md5-response
  52     ignore))                            ;""
  53
  54 (defun sasl-digest-md5-parse-string (string)
  55   "Parse STRING and return a property list.
  56 The value is a cons cell of the form \(realm nonce qop-options stale maxbuf
  57 charset algorithm cipher-opts auth-param)."
  58   (with-temp-buffer
  59     (set-syntax-table sasl-digest-md5-syntax-table)
  60     (save-excursion
  61       (insert string)
  62       (goto-char (point-min))
  63       (insert "(")
  64       (while (progn (forward-sexp) (not (eobp)))
  65         (delete-char 1)
  66         (insert " "))
  67       (insert ")")
  68       (read (point-min-marker)))))
  69
  70 (defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name)
  71   (concat serv-type "/" host
  72           (if (and serv-name
  73                    (not (string= host serv-name)))
  74               (concat "/" serv-name))))
  75
  76 (defun sasl-digest-md5-cnonce ()
  77   (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function))
  78     (sasl-unique-id)))
  79
  80 (defun sasl-digest-md5-response-value (username
  81                                        realm
  82                                        nonce
  83                                        cnonce
  84                                        nonce-count
  85                                        qop
  86                                        digest-uri
  87                                        authzid)
  88   (let ((passphrase
  89          (sasl-read-passphrase
  90           (format "DIGEST-MD5 passphrase for %s: "
  91                   username))))
  92     (unwind-protect
  93         (encode-hex-string
  94          (md5-binary
  95           (concat
  96            (encode-hex-string
  97             (md5-binary (concat (md5-binary
  98                                  (concat username ":" realm ":" passphrase))
  99                                 ":" nonce ":" cnonce
 100                                 (if authzid
 101                                     (concat ":" authzid)))))
 102            ":" nonce
 103            ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
 104            (encode-hex-string
 105             (md5-binary
 106              (concat "AUTHENTICATE:" digest-uri
 107                      (if (member qop '("auth-int" "auth-conf"))
 108                          ":00000000000000000000000000000000")))))))
 109       (fillarray passphrase 0))))
 110
 111 (defun sasl-digest-md5-response (client step)
 112   (let* ((plist
 113           (sasl-digest-md5-parse-string (sasl-step-data step)))
 114          (realm
 115           (or (sasl-client-property client 'realm)
 116               (plist-get plist 'realm))) ;need to check
 117          (nonce-count
 118           (or (sasl-client-property client 'nonce-count)
 119                sasl-digest-md5-nonce-count))
 120          (qop
 121           (or (sasl-client-property client 'qop)
 122               "auth"))
 123          (digest-uri
 124           (sasl-digest-md5-digest-uri
 125            (sasl-client-service client)(sasl-client-server client)))
 126          (cnonce
 127           (or (sasl-client-property client 'cnonce)
 128               (sasl-digest-md5-cnonce))))
 129     (sasl-client-set-property client 'nonce-count (1+ nonce-count))
 130     (unless (string= qop "auth")
 131       (sasl-error (format "Unsupported \"qop-value\": %s" qop)))
 132     (concat
 133      "username=\"" (sasl-client-name client) "\","
 134      "realm=\"" realm "\","
 135      "nonce=\"" (plist-get plist 'nonce) "\","
 136      "cnonce=\"" cnonce "\","
 137      (format "nc=%08x," nonce-count)
 138      "digest-uri=\"" digest-uri "\","
 139      "qop=" qop ","
 140      "response="
 141      (sasl-digest-md5-response-value
 142       (sasl-client-name client)
 143       realm
 144       (plist-get plist 'nonce)
 145       cnonce
 146       nonce-count
 147       qop
 148       digest-uri
 149       (plist-get plist 'authzid)))))
 150
 151 (put 'sasl-digest 'sasl-mechanism
 152      (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps))
 153
 154 (provide 'sasl-digest)
 155
 156 ;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d
 157 ;;; sasl-digest.el ends here