Mercurial > emacs
annotate lisp/net/sasl.el @ 95392:838b2bca5a6f
*** empty log message ***
author | Juanma Barranquero <lekktu@gmail.com> |
---|---|
date | Thu, 29 May 2008 20:05:36 +0000 |
parents | 91e5880a36c1 |
children | ce3cca778d10 |
rev | line source |
---|---|
86997 | 1 ;;; sasl.el --- SASL client framework |
2 | |
87665 | 3 ;; Copyright (C) 2000, 2007, 2008 Free Software Foundation, Inc. |
86997 | 4 |
5 ;; Author: Daiki Ueno <ueno@unixuser.org> | |
6 ;; Keywords: SASL | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
86997 | 11 ;; it under the terms of the GNU General Public License as published by |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; (at your option) any later version. |
86997 | 14 |
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. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
86997 | 22 |
23 ;;; Commentary: | |
24 | |
25 ;; This module provides common interface functions to share several | |
26 ;; SASL mechanism drivers. The toplevel is designed to be mostly | |
27 ;; compatible with [Java-SASL]. | |
28 ;; | |
29 ;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", | |
30 ;; RFC 2222, October 1997. | |
31 ;; | |
32 ;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program | |
33 ;; Interface", draft-weltman-java-sasl-03.txt, March 2000. | |
34 | |
35 ;;; Code: | |
36 | |
37 (defvar sasl-mechanisms | |
38 '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" | |
39 "NTLM" "SCRAM-MD5")) | |
40 | |
41 (defvar sasl-mechanism-alist | |
42 '(("CRAM-MD5" sasl-cram) | |
43 ("DIGEST-MD5" sasl-digest) | |
44 ("PLAIN" sasl-plain) | |
45 ("LOGIN" sasl-login) | |
46 ("ANONYMOUS" sasl-anonymous) | |
47 ("NTLM" sasl-ntlm) | |
48 ("SCRAM-MD5" sasl-scram))) | |
49 | |
50 (defvar sasl-unique-id-function #'sasl-unique-id-function) | |
51 | |
52 (put 'sasl-error 'error-message "SASL error") | |
53 (put 'sasl-error 'error-conditions '(sasl-error error)) | |
54 | |
55 (defun sasl-error (datum) | |
56 (signal 'sasl-error (list datum))) | |
57 | |
58 ;;; @ SASL client | |
59 ;;; | |
60 | |
61 (defun sasl-make-client (mechanism name service server) | |
62 "Return a newly allocated SASL client. | |
63 NAME is name of the authorization. SERVICE is name of the service desired. | |
64 SERVER is the fully qualified host name of the server to authenticate to." | |
65 (vector mechanism name service server (make-symbol "sasl-client-properties"))) | |
66 | |
67 (defun sasl-client-mechanism (client) | |
68 "Return the authentication mechanism driver of CLIENT." | |
69 (aref client 0)) | |
70 | |
71 (defun sasl-client-name (client) | |
72 "Return the authorization name of CLIENT, a string." | |
73 (aref client 1)) | |
74 | |
75 (defun sasl-client-service (client) | |
76 "Return the service name of CLIENT, a string." | |
77 (aref client 2)) | |
78 | |
79 (defun sasl-client-server (client) | |
80 "Return the server name of CLIENT, a string." | |
81 (aref client 3)) | |
82 | |
83 (defun sasl-client-set-properties (client plist) | |
84 "Destructively set the properties of CLIENT. | |
85 The second argument PLIST is the new property list." | |
86 (setplist (aref client 4) plist)) | |
87 | |
88 (defun sasl-client-set-property (client property value) | |
89 "Add the given property/value to CLIENT." | |
90 (put (aref client 4) property value)) | |
91 | |
92 (defun sasl-client-property (client property) | |
93 "Return the value of the PROPERTY of CLIENT." | |
94 (get (aref client 4) property)) | |
95 | |
96 (defun sasl-client-properties (client) | |
97 "Return the properties of CLIENT." | |
98 (symbol-plist (aref client 4))) | |
99 | |
100 ;;; @ SASL mechanism | |
101 ;;; | |
102 | |
103 (defun sasl-make-mechanism (name steps) | |
104 "Make an authentication mechanism. | |
105 NAME is a IANA registered SASL mechanism name. | |
106 STEPS is list of continuation function." | |
107 (vector name | |
108 (mapcar | |
109 (lambda (step) | |
110 (let ((symbol (make-symbol (symbol-name step)))) | |
111 (fset symbol (symbol-function step)) | |
112 symbol)) | |
113 steps))) | |
114 | |
115 (defun sasl-mechanism-name (mechanism) | |
116 "Return name of MECHANISM, a string." | |
117 (aref mechanism 0)) | |
118 | |
119 (defun sasl-mechanism-steps (mechanism) | |
120 "Return the authentication steps of MECHANISM, a list of functions." | |
121 (aref mechanism 1)) | |
122 | |
123 (defun sasl-find-mechanism (mechanisms) | |
124 "Retrieve an apropriate mechanism object from MECHANISMS hints." | |
125 (let* ((sasl-mechanisms sasl-mechanisms) | |
126 (mechanism | |
127 (catch 'done | |
128 (while sasl-mechanisms | |
129 (if (member (car sasl-mechanisms) mechanisms) | |
130 (throw 'done (nth 1 (assoc (car sasl-mechanisms) | |
131 sasl-mechanism-alist)))) | |
132 (setq sasl-mechanisms (cdr sasl-mechanisms)))))) | |
133 (if mechanism | |
134 (require mechanism)) | |
135 (get mechanism 'sasl-mechanism))) | |
136 | |
137 ;;; @ SASL authentication step | |
138 ;;; | |
139 | |
140 (defun sasl-step-data (step) | |
141 "Return the data which STEP holds, a string." | |
142 (aref step 1)) | |
143 | |
144 (defun sasl-step-set-data (step data) | |
145 "Store DATA string to STEP." | |
146 (aset step 1 data)) | |
147 | |
148 (defun sasl-next-step (client step) | |
149 "Evaluate the challenge and prepare an appropriate next response. | |
150 The data type of the value and optional 2nd argument STEP is nil or | |
151 opaque authentication step which holds the reference to the next action | |
152 and the current challenge. At the first time STEP should be set to nil." | |
153 (let* ((steps | |
154 (sasl-mechanism-steps | |
155 (sasl-client-mechanism client))) | |
156 (function | |
157 (if (vectorp step) | |
158 (nth 1 (memq (aref step 0) steps)) | |
159 (car steps)))) | |
160 (if function | |
161 (vector function (funcall function client step))))) | |
162 | |
163 (defvar sasl-read-passphrase nil) | |
164 (defun sasl-read-passphrase (prompt) | |
165 (if (not sasl-read-passphrase) | |
166 (if (functionp 'read-passwd) | |
167 (setq sasl-read-passphrase 'read-passwd) | |
168 (if (load "passwd" t) | |
169 (setq sasl-read-passphrase 'read-passwd) | |
170 (autoload 'ange-ftp-read-passwd "ange-ftp") | |
171 (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) | |
172 (funcall sasl-read-passphrase prompt)) | |
173 | |
174 (defun sasl-unique-id () | |
175 "Compute a data string which must be different each time. | |
176 It contain at least 64 bits of entropy." | |
177 (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) | |
178 | |
179 (defvar sasl-unique-id-char nil) | |
180 | |
181 ;; stolen (and renamed) from message.el | |
182 (defun sasl-unique-id-function () | |
183 ;; Don't use microseconds from (current-time), they may be unsupported. | |
184 ;; Instead we use this randomly inited counter. | |
185 (setq sasl-unique-id-char | |
186 (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) | |
187 ;; (current-time) returns 16-bit ints, | |
188 ;; and 2^16*25 just fits into 4 digits i base 36. | |
189 (* 25 25))) | |
190 (let ((tm (current-time))) | |
191 (concat | |
192 (sasl-unique-id-number-base36 | |
193 (+ (car tm) | |
194 (lsh (% sasl-unique-id-char 25) 16)) 4) | |
195 (sasl-unique-id-number-base36 | |
196 (+ (nth 1 tm) | |
197 (lsh (/ sasl-unique-id-char 25) 16)) 4)))) | |
198 | |
199 (defun sasl-unique-id-number-base36 (num len) | |
200 (if (if (< len 0) | |
201 (<= num 0) | |
202 (= len 0)) | |
203 "" | |
204 (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) | |
205 (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" | |
206 (% num 36)))))) | |
207 | |
208 ;;; PLAIN (RFC2595 Section 6) | |
209 (defconst sasl-plain-steps | |
210 '(sasl-plain-response)) | |
211 | |
212 (defun sasl-plain-response (client step) | |
213 (let ((passphrase | |
214 (sasl-read-passphrase | |
215 (format "PLAIN passphrase for %s: " (sasl-client-name client)))) | |
216 (authenticator-name | |
217 (sasl-client-property | |
218 client 'authenticator-name)) | |
219 (name (sasl-client-name client))) | |
220 (unwind-protect | |
221 (if (and authenticator-name | |
222 (not (string= authenticator-name name))) | |
223 (concat authenticator-name "\0" name "\0" passphrase) | |
224 (concat "\0" name "\0" passphrase)) | |
225 (fillarray passphrase 0)))) | |
226 | |
227 (put 'sasl-plain 'sasl-mechanism | |
228 (sasl-make-mechanism "PLAIN" sasl-plain-steps)) | |
229 | |
230 (provide 'sasl-plain) | |
231 | |
232 ;;; LOGIN (No specification exists) | |
233 (defconst sasl-login-steps | |
234 '(ignore ;no initial response | |
235 sasl-login-response-1 | |
236 sasl-login-response-2)) | |
237 | |
238 (defun sasl-login-response-1 (client step) | |
239 ;;; (unless (string-match "^Username:" (sasl-step-data step)) | |
240 ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) | |
241 (sasl-client-name client)) | |
242 | |
243 (defun sasl-login-response-2 (client step) | |
244 ;;; (unless (string-match "^Password:" (sasl-step-data step)) | |
245 ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) | |
246 (sasl-read-passphrase | |
247 (format "LOGIN passphrase for %s: " (sasl-client-name client)))) | |
248 | |
249 (put 'sasl-login 'sasl-mechanism | |
250 (sasl-make-mechanism "LOGIN" sasl-login-steps)) | |
251 | |
252 (provide 'sasl-login) | |
253 | |
254 ;;; ANONYMOUS (RFC2245) | |
255 (defconst sasl-anonymous-steps | |
256 '(ignore ;no initial response | |
257 sasl-anonymous-response)) | |
258 | |
259 (defun sasl-anonymous-response (client step) | |
260 (or (sasl-client-property client 'trace) | |
261 (sasl-client-name client))) | |
262 | |
263 (put 'sasl-anonymous 'sasl-mechanism | |
264 (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) | |
265 | |
266 (provide 'sasl-anonymous) | |
267 | |
268 (provide 'sasl) | |
269 | |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87665
diff
changeset
|
270 ;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 |
86997 | 271 ;;; sasl.el ends here |