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
46 ;;; Generic for SCRAM-*
48 (defun sasl-scram-client-first-message (client _step
)
49 (let ((c-nonce (sasl-unique-id)))
50 (sasl-client-set-property client
'c-nonce c-nonce
))
52 ;; n = client doesn't support channel binding
54 ;; TODO: where would we get authorization id from?
56 (sasl-scram--client-first-message-bare client
)))
58 (defun sasl-scram--client-first-message-bare (client)
59 (let ((c-nonce (sasl-client-property client
'c-nonce
)))
61 ;; TODO: saslprep username or disallow non-ASCII characters
62 "n=" (sasl-client-name client
) ","
65 (defun sasl-scram--client-final-message (hash-fun block-length hash-length client step
)
67 "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)"
68 (sasl-step-data step
))
69 (sasl-error "Unexpected server response"))
70 (let* ((hmac-fun (lambda (text key
)
72 (rfc2104-hash hash-fun block-length hash-length key text
))))
73 (step-data (sasl-step-data step
))
74 (nonce (match-string 1 step-data
))
75 (salt-base64 (match-string 2 step-data
))
76 (iteration-count (string-to-number (match-string 3 step-data
)))
78 (c-nonce (sasl-client-property client
'c-nonce
))
79 ;; no channel binding, no authorization id
81 (unless (string-prefix-p c-nonce nonce
)
82 (sasl-error "Invalid nonce from server"))
83 (let* ((client-final-message-without-proof
84 (concat "c=" (base64-encode-string cbind-input
) ","
87 ;; TODO: either apply saslprep or disallow non-ASCII characters
89 (format "%s passphrase for %s: "
90 (sasl-mechanism-name (sasl-client-mechanism client
))
91 (sasl-client-name client
))))
92 (salt (base64-decode-string salt-base64
))
95 (let ((digest (concat salt
(string 0 0 0 1)))
97 (dotimes (_i iteration-count xored
)
98 (setq digest
(funcall hmac-fun digest password
))
99 (setq xored
(if (null xored
)
101 (cl-map 'string
'logxor xored digest
))))))
103 (funcall hmac-fun
"Client Key" salted-password
))
104 (stored-key (decode-hex-string (funcall hash-fun client-key
)))
107 (sasl-scram--client-first-message-bare client
) ","
109 client-final-message-without-proof
))
110 (client-signature (funcall hmac-fun
(encode-coding-string auth-message
'utf-8
) stored-key
))
111 (client-proof (cl-map 'string
'logxor client-key client-signature
))
112 (client-final-message
113 (concat client-final-message-without-proof
","
114 "p=" (base64-encode-string client-proof
))))
115 (sasl-client-set-property client
'auth-message auth-message
)
116 (sasl-client-set-property client
'salted-password salted-password
)
117 client-final-message
)))
119 (defun sasl-scram--authenticate-server (hash-fun block-length hash-length client step
)
121 ((string-match "^e=\\([^,]+\\)" (sasl-step-data step
))
122 (sasl-error (format "Server error: %s" (match-string 1 (sasl-step-data step
)))))
123 ((string-match "^v=\\([^,]+\\)" (sasl-step-data step
))
124 (let* ((hmac-fun (lambda (text key
)
126 (rfc2104-hash hash-fun block-length hash-length key text
))))
127 (verifier (base64-decode-string (match-string 1 (sasl-step-data step
))))
128 (auth-message (sasl-client-property client
'auth-message
))
129 (salted-password (sasl-client-property client
'salted-password
))
130 (server-key (funcall hmac-fun
"Server Key" salted-password
))
131 (expected-server-signature
132 (funcall hmac-fun
(encode-coding-string auth-message
'utf-8
) server-key
)))
133 (unless (string= expected-server-signature verifier
)
134 (sasl-error "Server not authenticated"))))
136 (sasl-error "Invalid response from server"))))
140 (defconst sasl-scram-sha-1-steps
141 '(sasl-scram-client-first-message
142 sasl-scram-sha-1-client-final-message
143 sasl-scram-sha-1-authenticate-server
))
145 (defun sasl-scram-sha-1-client-final-message (client step
)
146 (sasl-scram--client-final-message
147 ;; HMAC-SHA1 uses block length 64 and hash length 20; see RFC 2104.
148 'sha1
64 20 client step
))
150 (defun sasl-scram-sha-1-authenticate-server (client step
)
151 (sasl-scram--authenticate-server
152 'sha1
64 20 client step
))
154 ;; This needs to be at the end, because of how `sasl-make-mechanism'
155 ;; handles step function names.
156 (put 'sasl-scram-sha-1
'sasl-mechanism
157 (sasl-make-mechanism "SCRAM-SHA-1" sasl-scram-sha-1-steps
))
159 (put 'sasl-scram-rfc
'sasl-mechanism
(get 'sasl-scram-sha-1
'sasl-mechanism
))
161 (provide 'sasl-scram-sha-1
)
163 (provide 'sasl-scram-rfc
)
164 ;;; sasl-scram-rfc.el ends here