1 ;;; sasl-scram-rfc.el --- SCRAM-SHA-1 module for the SASL client framework -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
5 ;; Author: Magnus Henoch <magnus.henoch@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This program is implemented from RFC 5802. It implements the
26 ;; SCRAM-SHA-1 SASL mechanism.
28 ;; RFC 5802 foresees "hash agility", i.e. new mechanisms based on the
29 ;; same protocol but using a different hash function. Likewise, this
30 ;; module attempts to separate generic and specific functions, which
31 ;; should make it easy to implement any future SCRAM-* SASL mechanism.
32 ;; It should be as simple as copying the SCRAM-SHA-1 section below and
33 ;; replacing all SHA-1 references.
35 ;; This module does not yet implement the variants with channel
36 ;; binding, i.e. SCRAM-*-PLUS. That would require cooperation from
41 (ignore-errors (require 'cl-lib
))
47 ;;; Generic for SCRAM-*
49 (defun sasl-scram-client-first-message (client _step
)
50 (let ((c-nonce (sasl-unique-id)))
51 (sasl-client-set-property client
'c-nonce c-nonce
))
53 ;; n = client doesn't support channel binding
55 ;; TODO: where would we get authorization id from?
57 (sasl-scram--client-first-message-bare client
)))
59 (defun sasl-scram--client-first-message-bare (client)
60 (let ((c-nonce (sasl-client-property client
'c-nonce
)))
62 ;; TODO: saslprep username or disallow non-ASCII characters
63 "n=" (sasl-client-name client
) ","
67 (declare-function sasl-cl-coerce
"sasl-scram-rfc")
68 (declare-function sasl-cl-mapcar-many
"sasl-scram-rfc")
70 (defalias 'sasl-cl-map
'cl-map
)
71 (defun sasl-cl-mapcar-many (func seqs
)
74 (n (apply 'min
(mapcar 'length seqs
)))
76 (args (copy-sequence seqs
))
78 (setq seqs
(copy-sequence seqs
))
80 (setq p1 seqs p2 args
)
85 (setcar p1
(cdr (car p1
))))
87 (setq p1
(cdr p1
) p2
(cdr p2
)))
88 (push (apply func args
) res
)
94 (let ((n (min (length x
) (length y
)))
96 (while (< (setq i
(1+ i
)) n
)
98 (if (consp x
) (pop x
) (aref x i
))
99 (if (consp y
) (pop y
) (aref y i
)))
103 (defun sasl-cl-coerce (x type
)
104 "Coerce OBJECT to type TYPE.
105 TYPE is a Common Lisp type specifier.
107 (cond ((eq type
'list
) (if (listp x
) x
(append x nil
)))
108 ((eq type
'vector
) (if (vectorp x
) x
(vconcat x
)))
109 ((eq type
'string
) (if (stringp x
) x
(concat x
)))
110 ((eq type
'array
) (if (arrayp x
) x
(vconcat x
)))
111 ((and (eq type
'character
) (stringp x
) (= (length x
) 1)) (aref x
0))
112 ((and (eq type
'character
) (symbolp x
))
113 (sasl-cl-coerce (symbol-name x
) type
))
114 ((eq type
'float
) (float x
))
115 ;;((cl-typep x type) x)
116 (t (error "Can't coerce %s to type %s" x type
))))
118 (defun sasl-cl-map (type func seq
&rest rest
)
119 "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
120 TYPE is the sequence type to return.
121 \n(fn TYPE FUNCTION SEQUENCE...)"
124 (if (or (cdr rest
) (nlistp seq
) (nlistp (car rest
)))
125 (setq res
(sasl-cl-mapcar-many func
(cons seq rest
)))
128 (push (funcall func
(pop seq
) (pop y
)) res
))
129 (setq res
(nreverse res
)))
130 (setq res
(mapcar func seq
)))
131 (and type
(sasl-cl-coerce res type
)))))
133 (if (fboundp 'string-prefix-p
)
134 (defalias 'sasl-string-prefix-p
'string-prefix-p
)
135 (defun sasl-string-prefix-p (prefix string
&optional ignore-case
)
136 "Return non-nil if PREFIX is a prefix of STRING.
137 If IGNORE-CASE is non-nil, the comparison is done without paying attention
138 to case differences."
139 (let ((prefix-length (length prefix
)))
140 (cond ((> prefix-length
(length string
)) nil
)
142 (string-equal (downcase prefix
)
143 (downcase (substring string
0 prefix-length
))))
145 (string-equal prefix
(substring string
0 prefix-length
))))))))
147 (defun sasl-scram--client-final-message (hash-fun block-length hash-length client step
)
148 (unless (string-match
149 "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)"
150 (sasl-step-data step
))
151 (sasl-error "Unexpected server response"))
152 (let* ((hmac-fun (lambda (text key
)
154 (rfc2104-hash hash-fun block-length hash-length key text
))))
155 (step-data (sasl-step-data step
))
156 (nonce (match-string 1 step-data
))
157 (salt-base64 (match-string 2 step-data
))
158 (iteration-count (string-to-number (match-string 3 step-data
)))
160 (c-nonce (sasl-client-property client
'c-nonce
))
161 ;; no channel binding, no authorization id
163 (unless (sasl-string-prefix-p c-nonce nonce
)
164 (sasl-error "Invalid nonce from server"))
165 (let* ((client-final-message-without-proof
166 (concat "c=" (base64-encode-string cbind-input
) ","
169 ;; TODO: either apply saslprep or disallow non-ASCII characters
170 (sasl-read-passphrase
171 (format "%s passphrase for %s: "
172 (sasl-mechanism-name (sasl-client-mechanism client
))
173 (sasl-client-name client
))))
174 (salt (base64-decode-string salt-base64
))
177 (let ((digest (concat salt
(string 0 0 0 1)))
179 (dotimes (_i iteration-count xored
)
180 (setq digest
(funcall hmac-fun digest password
))
181 (setq xored
(if (null xored
)
183 (sasl-cl-map 'string
'logxor xored digest
))))))
185 (funcall hmac-fun
"Client Key" salted-password
))
186 (stored-key (decode-hex-string (funcall hash-fun client-key
)))
189 (sasl-scram--client-first-message-bare client
) ","
191 client-final-message-without-proof
))
192 (client-signature (funcall hmac-fun
(encode-coding-string auth-message
'utf-8
) stored-key
))
193 (client-proof (sasl-cl-map 'string
'logxor client-key client-signature
))
194 (client-final-message
195 (concat client-final-message-without-proof
","
196 "p=" (base64-encode-string client-proof
))))
197 (sasl-client-set-property client
'auth-message auth-message
)
198 (sasl-client-set-property client
'salted-password salted-password
)
199 client-final-message
)))
201 (defun sasl-scram--authenticate-server (hash-fun block-length hash-length client step
)
203 ((string-match "^e=\\([^,]+\\)" (sasl-step-data step
))
204 (sasl-error (format "Server error: %s" (match-string 1 (sasl-step-data step
)))))
205 ((string-match "^v=\\([^,]+\\)" (sasl-step-data step
))
206 (let* ((hmac-fun (lambda (text key
)
208 (rfc2104-hash hash-fun block-length hash-length key text
))))
209 (verifier (base64-decode-string (match-string 1 (sasl-step-data step
))))
210 (auth-message (sasl-client-property client
'auth-message
))
211 (salted-password (sasl-client-property client
'salted-password
))
212 (server-key (funcall hmac-fun
"Server Key" salted-password
))
213 (expected-server-signature
214 (funcall hmac-fun
(encode-coding-string auth-message
'utf-8
) server-key
)))
215 (unless (string= expected-server-signature verifier
)
216 (sasl-error "Server not authenticated"))))
218 (sasl-error "Invalid response from server"))))
222 (defconst sasl-scram-sha-1-steps
223 '(sasl-scram-client-first-message
224 sasl-scram-sha-1-client-final-message
225 sasl-scram-sha-1-authenticate-server
))
227 (defun sasl-scram-sha-1-client-final-message (client step
)
228 (sasl-scram--client-final-message
229 ;; HMAC-SHA1 uses block length 64 and hash length 20; see RFC 2104.
230 'sha1
64 20 client step
))
232 (defun sasl-scram-sha-1-authenticate-server (client step
)
233 (sasl-scram--authenticate-server
234 'sha1
64 20 client step
))
236 ;; This needs to be at the end, because of how `sasl-make-mechanism'
237 ;; handles step function names.
238 (put 'sasl-scram-sha-1
'sasl-mechanism
239 (sasl-make-mechanism "SCRAM-SHA-1" sasl-scram-sha-1-steps
))
241 (put 'sasl-scram-rfc
'sasl-mechanism
(get 'sasl-scram-sha-1
'sasl-mechanism
))
243 (provide 'sasl-scram-sha-1
)
245 (provide 'sasl-scram-rfc
)
246 ;;; sasl-scram-rfc.el ends here