Mercurial > emacs
annotate lisp/url/url-auth.el @ 83556:07774e5c3ff5
Merged from emacs@sv.gnu.org
Patches applied:
* emacs@sv.gnu.org/emacs--devo--0--patch-619
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-620
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-621
Merge from gnus--rel--5.10
* emacs@sv.gnu.org/emacs--devo--0--patch-622
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-623
Remove RCS keywords
* emacs@sv.gnu.org/emacs--devo--0--patch-624
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-625
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-626
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-627
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-628
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-629
Merge from gnus--rel--5.10
* emacs@sv.gnu.org/emacs--devo--0--patch-630
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-631
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-632
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-633
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-634
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-635
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-636
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-637
Remove RCS keywords
* emacs@sv.gnu.org/emacs--devo--0--patch-638
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-639
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-640
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-641
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-642
Merge from gnus--rel--5.10
* emacs@sv.gnu.org/emacs--devo--0--patch-643
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-644
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-645
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-646
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-647
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-648
Update from CVS
* emacs@sv.gnu.org/emacs--devo--0--patch-649
Update from CVS
* emacs@sv.gnu.org/gnus--rel--5.10--patch-197
Merge from emacs--devo--0
* emacs@sv.gnu.org/gnus--rel--5.10--patch-198
Update from CVS
* emacs@sv.gnu.org/gnus--rel--5.10--patch-199
Update from CVS
* emacs@sv.gnu.org/gnus--rel--5.10--patch-200
Merge from emacs--devo--0
* emacs@sv.gnu.org/gnus--rel--5.10--patch-201
Update from CVS: lisp/nnweb.el (nnweb-google-parse-1): Update parser.
* emacs@sv.gnu.org/gnus--rel--5.10--patch-202
Update from CVS
git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-596
author | Karoly Lorentey <karoly@lorentey.hu> |
---|---|
date | Sat, 24 Feb 2007 19:26:54 +0000 |
parents | b8d9a391daf3 b271481fb8d2 |
children |
rev | line source |
---|---|
54695 | 1 ;;; url-auth.el --- Uniform Resource Locator authorization modules |
57612 | 2 |
64748
875dcc490074
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64084
diff
changeset
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, |
75347 | 4 ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
57612 | 5 |
54695 | 6 ;; Keywords: comm, data, processes, hypermedia |
7 | |
57612 | 8 ;; This file is part of GNU Emacs. |
9 | |
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 2, or (at your option) | |
13 ;; any later version. | |
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 | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
64084 | 22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02110-1301, USA. | |
57612 | 24 |
25 ;;; Code: | |
54695 | 26 |
27 (require 'url-vars) | |
28 (require 'url-parse) | |
29 (autoload 'url-warn "url") | |
30 | |
31 (defsubst url-auth-user-prompt (url realm) | |
32 "String to usefully prompt for a username." | |
33 (concat "Username [for " | |
34 (or realm (url-truncate-url-for-viewing | |
35 (url-recreate-url url) | |
36 (- (window-width) 10 20))) | |
37 "]: ")) | |
38 | |
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
40 ;;; Basic authorization code | |
41 ;;; ------------------------ | |
42 ;;; This implements the BASIC authorization type. See the online | |
43 ;;; documentation at | |
44 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html | |
45 ;;; for the complete documentation on this type. | |
46 ;;; | |
47 ;;; This is very insecure, but it works as a proof-of-concept | |
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
49 (defvar url-basic-auth-storage 'url-http-real-basic-auth-storage | |
50 "Where usernames and passwords are stored. | |
51 | |
52 Must be a symbol pointing to another variable that will actually store | |
53 the information. The value of this variable is an assoc list of assoc | |
54 lists. The first assoc list is keyed by the server name. The cdr of | |
55 this is an assoc list based on the 'directory' specified by the url we | |
56 are looking up.") | |
57 | |
58 (defun url-basic-auth (url &optional prompt overwrite realm args) | |
59 "Get the username/password for the specified URL. | |
60 If optional argument PROMPT is non-nil, ask for the username/password | |
61 to use for the url and its descendants. If optional third argument | |
62 OVERWRITE is non-nil, overwrite the old username/password pair if it | |
63 is found in the assoc list. If REALM is specified, use that as the realm | |
64 instead of the pathname inheritance method." | |
65 (let* ((href (if (stringp url) | |
66 (url-generic-parse-url url) | |
67 url)) | |
68 (server (url-host href)) | |
69 (port (url-port href)) | |
70 (path (url-filename href)) | |
71 user pass byserv retval data) | |
72 (setq server (format "%s:%d" server port) | |
73 path (cond | |
74 (realm realm) | |
75 ((string-match "/$" path) path) | |
76 (t (url-basepath path))) | |
77 byserv (cdr-safe (assoc server | |
78 (symbol-value url-basic-auth-storage)))) | |
79 (cond | |
80 ((and prompt (not byserv)) | |
81 (setq user (read-string (url-auth-user-prompt url realm) | |
82 (user-real-login-name)) | |
57509
e5a1e83cfb02
(url-basic-auth, url-digest-auth): Use read-passwd.
Richard M. Stallman <rms@gnu.org>
parents:
57427
diff
changeset
|
83 pass (read-passwd "Password: ")) |
54695 | 84 (set url-basic-auth-storage |
85 (cons (list server | |
86 (cons path | |
87 (setq retval | |
88 (base64-encode-string | |
89 (format "%s:%s" user pass))))) | |
90 (symbol-value url-basic-auth-storage)))) | |
91 (byserv | |
92 (setq retval (cdr-safe (assoc path byserv))) | |
93 (if (and (not retval) | |
94 (string-match "/" path)) | |
95 (while (and byserv (not retval)) | |
96 (setq data (car (car byserv))) | |
75519
b271481fb8d2
(url-get-authentication): Fix typo in docstring.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
97 (if (or (not (string-match "/" data)) ; It's a realm - take it! |
54695 | 98 (and |
99 (>= (length path) (length data)) | |
100 (string= data (substring path 0 (length data))))) | |
101 (setq retval (cdr (car byserv)))) | |
102 (setq byserv (cdr byserv)))) | |
103 (if (or (and (not retval) prompt) overwrite) | |
104 (progn | |
105 (setq user (read-string (url-auth-user-prompt url realm) | |
106 (user-real-login-name)) | |
57509
e5a1e83cfb02
(url-basic-auth, url-digest-auth): Use read-passwd.
Richard M. Stallman <rms@gnu.org>
parents:
57427
diff
changeset
|
107 pass (read-passwd "Password: ") |
54695 | 108 retval (base64-encode-string (format "%s:%s" user pass)) |
109 byserv (assoc server (symbol-value url-basic-auth-storage))) | |
110 (setcdr byserv | |
111 (cons (cons path retval) (cdr byserv)))))) | |
112 (t (setq retval nil))) | |
113 (if retval (setq retval (concat "Basic " retval))) | |
114 retval)) | |
115 | |
116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
117 ;;; Digest authorization code | |
118 ;;; ------------------------ | |
119 ;;; This implements the DIGEST authorization type. See the internet draft | |
120 ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt | |
121 ;;; for the complete documentation on this type. | |
122 ;;; | |
123 ;;; This is very secure | |
124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
125 (defvar url-digest-auth-storage nil | |
126 "Where usernames and passwords are stored. Its value is an assoc list of | |
127 assoc lists. The first assoc list is keyed by the server name. The cdr of | |
128 this is an assoc list based on the 'directory' specified by the url we are | |
129 looking up.") | |
130 | |
131 (defun url-digest-auth-create-key (username password realm method uri) | |
132 "Create a key for digest authentication method" | |
133 (let* ((info (if (stringp uri) | |
134 (url-generic-parse-url uri) | |
135 uri)) | |
136 (a1 (md5 (concat username ":" realm ":" password))) | |
137 (a2 (md5 (concat method ":" (url-filename info))))) | |
138 (list a1 a2))) | |
139 | |
140 (defun url-digest-auth (url &optional prompt overwrite realm args) | |
141 "Get the username/password for the specified URL. | |
142 If optional argument PROMPT is non-nil, ask for the username/password | |
143 to use for the url and its descendants. If optional third argument | |
144 OVERWRITE is non-nil, overwrite the old username/password pair if it | |
145 is found in the assoc list. If REALM is specified, use that as the realm | |
146 instead of hostname:portnum." | |
147 (if args | |
148 (let* ((href (if (stringp url) | |
149 (url-generic-parse-url url) | |
150 url)) | |
151 (server (url-host href)) | |
152 (port (url-port href)) | |
153 (path (url-filename href)) | |
154 user pass byserv retval data) | |
155 (setq path (cond | |
156 (realm realm) | |
157 ((string-match "/$" path) path) | |
158 (t (url-basepath path))) | |
159 server (format "%s:%d" server port) | |
160 byserv (cdr-safe (assoc server url-digest-auth-storage))) | |
161 (cond | |
162 ((and prompt (not byserv)) | |
163 (setq user (read-string (url-auth-user-prompt url realm) | |
164 (user-real-login-name)) | |
57509
e5a1e83cfb02
(url-basic-auth, url-digest-auth): Use read-passwd.
Richard M. Stallman <rms@gnu.org>
parents:
57427
diff
changeset
|
165 pass (read-passwd "Password: ") |
54695 | 166 url-digest-auth-storage |
167 (cons (list server | |
168 (cons path | |
169 (setq retval | |
170 (cons user | |
171 (url-digest-auth-create-key | |
172 user pass realm | |
173 (or url-request-method "GET") | |
174 url))))) | |
175 url-digest-auth-storage))) | |
176 (byserv | |
177 (setq retval (cdr-safe (assoc path byserv))) | |
178 (if (and (not retval) ; no exact match, check directories | |
179 (string-match "/" path)) ; not looking for a realm | |
180 (while (and byserv (not retval)) | |
181 (setq data (car (car byserv))) | |
182 (if (or (not (string-match "/" data)) | |
183 (and | |
184 (>= (length path) (length data)) | |
185 (string= data (substring path 0 (length data))))) | |
186 (setq retval (cdr (car byserv)))) | |
187 (setq byserv (cdr byserv)))) | |
188 (if (or (and (not retval) prompt) overwrite) | |
189 (progn | |
190 (setq user (read-string (url-auth-user-prompt url realm) | |
191 (user-real-login-name)) | |
57509
e5a1e83cfb02
(url-basic-auth, url-digest-auth): Use read-passwd.
Richard M. Stallman <rms@gnu.org>
parents:
57427
diff
changeset
|
192 pass (read-passwd "Password: ") |
54695 | 193 retval (setq retval |
194 (cons user | |
195 (url-digest-auth-create-key | |
196 user pass realm | |
197 (or url-request-method "GET") | |
198 url))) | |
199 byserv (assoc server url-digest-auth-storage)) | |
200 (setcdr byserv | |
201 (cons (cons path retval) (cdr byserv)))))) | |
202 (t (setq retval nil))) | |
203 (if retval | |
204 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) | |
205 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven"))) | |
206 (format | |
207 (concat "Digest username=\"%s\", realm=\"%s\"," | |
208 "nonce=\"%s\", uri=\"%s\"," | |
209 "response=\"%s\", opaque=\"%s\"") | |
210 (nth 0 retval) realm nonce (url-filename href) | |
211 (md5 (concat (nth 1 retval) ":" nonce ":" | |
212 (nth 2 retval))) opaque)))))) | |
213 | |
214 (defvar url-registered-auth-schemes nil | |
215 "A list of the registered authorization schemes and various and sundry | |
216 information associated with them.") | |
217 | |
218 ;;;###autoload | |
219 (defun url-get-authentication (url realm type prompt &optional args) | |
220 "Return an authorization string suitable for use in the WWW-Authenticate | |
221 header in an HTTP/1.0 request. | |
222 | |
223 URL is the url you are requesting authorization to. This can be either a | |
224 string representing the URL, or the parsed representation returned by | |
225 `url-generic-parse-url' | |
226 REALM is the realm at a specific site we are looking for. This should be a | |
227 string specifying the exact realm, or nil or the symbol 'any' to | |
228 specify that the filename portion of the URL should be used as the | |
229 realm | |
230 TYPE is the type of authentication to be returned. This is either a string | |
231 representing the type (basic, digest, etc), or nil or the symbol 'any' | |
232 to specify that any authentication is acceptable. If requesting 'any' | |
233 the strongest matching authentication will be returned. If this is | |
75519
b271481fb8d2
(url-get-authentication): Fix typo in docstring.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
234 wrong, it's no big deal, the error from the server will specify exactly |
54695 | 235 what type of auth to use |
236 PROMPT is boolean - specifies whether to ask the user for a username/password | |
237 if one cannot be found in the cache" | |
238 (if (not realm) | |
239 (setq realm (cdr-safe (assoc "realm" args)))) | |
240 (if (stringp url) | |
241 (setq url (url-generic-parse-url url))) | |
242 (if (or (null type) (eq type 'any)) | |
243 ;; Whooo doogies! | |
244 ;; Go through and get _all_ the authorization strings that could apply | |
245 ;; to this URL, store them along with the 'rating' we have in the list | |
246 ;; of schemes, then sort them so that the 'best' is at the front of the | |
247 ;; list, then get the car, then get the cdr. | |
248 ;; Zooom zooom zoooooom | |
249 (cdr-safe | |
250 (car-safe | |
251 (sort | |
252 (mapcar | |
253 (function | |
254 (lambda (scheme) | |
255 (if (fboundp (car (cdr scheme))) | |
256 (cons (cdr (cdr scheme)) | |
257 (funcall (car (cdr scheme)) url nil nil realm)) | |
258 (cons 0 nil)))) | |
259 url-registered-auth-schemes) | |
260 (function | |
261 (lambda (x y) | |
262 (cond | |
263 ((null (cdr x)) nil) | |
264 ((and (cdr x) (null (cdr y))) t) | |
265 ((and (cdr x) (cdr y)) | |
266 (>= (car x) (car y))) | |
267 (t nil))))))) | |
268 (if (symbolp type) (setq type (symbol-name type))) | |
269 (let* ((scheme (car-safe | |
270 (cdr-safe (assoc (downcase type) | |
271 url-registered-auth-schemes))))) | |
272 (if (and scheme (fboundp scheme)) | |
273 (funcall scheme url prompt | |
274 (and prompt | |
275 (funcall scheme url nil nil realm args)) | |
276 realm args))))) | |
277 | |
278 ;;;###autoload | |
279 (defun url-register-auth-scheme (type &optional function rating) | |
280 "Register an HTTP authentication method. | |
281 | |
282 TYPE is a string or symbol specifying the name of the method. This | |
283 should be the same thing you expect to get returned in an Authenticate | |
284 header in HTTP/1.0 - it will be downcased. | |
285 FUNCTION is the function to call to get the authorization information. This | |
286 defaults to `url-?-auth', where ? is TYPE | |
287 RATING a rating between 1 and 10 of the strength of the authentication. | |
288 This is used when asking for the best authentication for a specific | |
289 URL. The item with the highest rating is returned." | |
290 (let* ((type (cond | |
291 ((stringp type) (downcase type)) | |
292 ((symbolp type) (downcase (symbol-name type))) | |
293 (t (error "Bad call to `url-register-auth-scheme'")))) | |
294 (function (or function (intern (concat "url-" type "-auth")))) | |
295 (rating (cond | |
296 ((null rating) 2) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
57612
diff
changeset
|
297 ((stringp rating) (string-to-number rating)) |
54695 | 298 (t rating))) |
299 (node (assoc type url-registered-auth-schemes))) | |
300 (if (not (fboundp function)) | |
301 (url-warn 'security | |
54792
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
302 (format (concat |
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
303 "Tried to register `%s' as an auth scheme" |
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
304 ", but it is not a function!") function))) |
54695 | 305 |
306 (if node | |
307 (setcdr node (cons function rating)) | |
308 (setq url-registered-auth-schemes | |
309 (cons (cons type (cons function rating)) | |
310 url-registered-auth-schemes))))) | |
311 | |
312 (defun url-auth-registered (scheme) | |
313 ;; Return non-nil iff SCHEME is registered as an auth type | |
314 (assoc scheme url-registered-auth-schemes)) | |
315 | |
316 (provide 'url-auth) | |
54699 | 317 |
318 ;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91 | |
57612 | 319 ;;; url-auth.el ends here |