sasl-digest.el

   1 ;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
   2
   3 ;; Copyright (C) 2000 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 FLIM (Faithful Library about Internet Message).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  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 (eval-when-compile (require 'cl))
  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 (defconst sasl-digest-md5-signing-encode-magic
  83   "Digest session key to client-to-server signing key magic constant")
  84
  85 (defconst sasl-digest-md5-signing-decode-magic
  86   "Digest session key to server-to-client signing key magic constant")
  87
  88 (defun sasl-digest-md5-htonl-string (n)
  89   (car
  90    (read-from-string
  91     (format "\"\\x%02x\\x%02x\\x%02x\\x%02x\""
  92             (logand n 255)
  93             (logand (lsh n -8) 255)
  94             (logand (lsh n -16) 255)
  95             (logand (lsh n -24) 255)))))
  96
  97 (defun sasl-digest-md5-make-integrity-encoder (ha1)
  98   (lexical-let ((key (md5-binary (concat ha1 sasl-digest-md5-signing-encode-magic)))
  99                 (seqnum 0))
 100     (lambda (string)
 101       (let ((seqnum-string (sasl-digest-md5-htonl-string seqnum)))
 102         (prog1 (concat (sasl-digest-md5-htonl-string (+ (length string) 16))
 103                        string (hmac-md5 key (concat seqnum-string string))
 104                        "\x0\x1\x0\x0" seqnum-string)
 105           (setq seqnum (1+ seqnum)))))))
 106
 107 (defun sasl-digest-md5-make-integrity-decoder (ha1)
 108   (lexical-let ((key (md5-binary (concat ha1 sasl-digest-md5-signing-decode-magic)))
 109                 (seqnum 0))
 110     (lambda (string)
 111       (let ((seqnum-string (sasl-digest-md5-htonl-string seqnum))
 112             (mac (substring string (- (length string) 16))))
 113         (setq string (substring string 4 (- (length string) 20)))
 114         (or (string= (concat (hmac-md5 key (concat seqnum-string string))
 115                              "\x0\x1\x0\x0" seqnum-string)
 116                      mac)
 117             (sasl-error "MAC doesn't match"))
 118         (setq seqnum (1+ seqnum))
 119         string))))
 120
 121 (defun sasl-digest-md5-ha1 (username realm nonce cnonce authzid)
 122   (let ((passphrase
 123          (sasl-read-passphrase
 124           (format "DIGEST-MD5 passphrase for %s: "
 125                   username))))
 126     (unwind-protect
 127         (md5-binary
 128          (concat (md5-binary
 129                   (concat username ":" realm ":" passphrase))
 130                  ":" nonce ":" cnonce
 131                  (if authzid
 132                      (concat ":" authzid))))
 133       (fillarray passphrase 0))))
 134
 135 (defun sasl-digest-md5-response-value (ha1 nonce cnonce nonce-count qop digest-uri)
 136   (encode-hex-string
 137    (md5-binary
 138     (concat
 139      (encode-hex-string ha1)
 140      ":" nonce
 141      ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
 142      (encode-hex-string
 143       (md5-binary
 144        (concat "AUTHENTICATE:" digest-uri
 145                (if (member qop '("auth-int" "auth-conf"))
 146                    ":00000000000000000000000000000000"))))))))
 147
 148 (defun sasl-digest-md5-response (client step)
 149   (let* ((plist
 150           (sasl-digest-md5-parse-string (sasl-step-data step)))
 151          (realm
 152           (or (sasl-client-property client 'realm)
 153               (plist-get plist 'realm))) ;need to check
 154          (nonce (plist-get plist 'nonce))
 155          (cnonce
 156           (or (sasl-client-property client 'cnonce)
 157               (sasl-digest-md5-cnonce)))
 158          (nonce-count
 159           (or (sasl-client-property client 'nonce-count)
 160                sasl-digest-md5-nonce-count))
 161          (qop
 162           (or (sasl-client-property client 'qop)
 163               "auth"))
 164          (digest-uri
 165           (sasl-digest-md5-digest-uri
 166            (sasl-client-service client)(sasl-client-server client)))
 167          (ha1
 168           (sasl-digest-md5-ha1
 169            (sasl-client-name client) realm nonce cnonce (plist-get plist 'authzid))))
 170     (sasl-client-set-property client 'nonce-count (1+ nonce-count))
 171 ;;;    (when (member qop '("auth-int" "auth-conf"))
 172 ;;;      (sasl-client-set-encoder
 173 ;;;       client (sasl-digest-md5-make-integrity-encoder ha1))
 174 ;;;      (sasl-client-set-decoder
 175 ;;;       client (sasl-digest-md5-make-integrity-decoder ha1)))
 176     (concat
 177      "username=\"" (sasl-client-name client) "\","
 178      "realm=\"" realm "\","
 179      "nonce=\"" (plist-get plist 'nonce) "\","
 180      "cnonce=\"" cnonce "\","
 181      (format "nc=%08x," nonce-count)
 182      "digest-uri=\"" digest-uri "\","
 183      "qop=" qop ","
 184      "response="
 185      (sasl-digest-md5-response-value
 186       ha1 nonce cnonce nonce-count qop digest-uri))))
 187
 188 (put 'sasl-digest 'sasl-mechanism
 189      (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps))
 190
 191 (provide 'sasl-digest)
 192
 193 ;;; sasl-digest.el ends here