Update copyright year to 2016
[gnus] / lisp / sasl-digest.el
1 ;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
2
3 ;; Copyright (C) 2000, 2007-2016 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