Mercurial > emacs
annotate lisp/url/url-auth.el @ 60092:04686828d0da
2004-11-08 Benjamin Riefenstahl <Benjamin.Riefenstahl@epost.de>
* w32select.c: Summary: Thorough rework to implement Unicode
clipboard operations and delayed rendering.
Drop last_clipboard_text and related code, keep track of
ownership via clipboard_owner instead. Drop old #if0
sections.
(DEFAULT_LCID, ANSICP, OEMCP, QUNICODE, QANSICP, QOEMCP)
(clipboard_owner, modifying_clipboard, cfg_coding_system)
(cfg_codepage, cfg_lcid, cfg_clipboard_type, current_text)
(current_coding_system, current_requires_encoding)
(current_num_nls, current_clipboard_type, current_lcid): New
static variables.
(convert_to_handle_as_ascii, convert_to_handle_as_coded)
(render, render_all, run_protected, lisp_error_handler)
(owner_callback, create_owner, setup_config)
(enum_locale_callback, cp_from_locale, coding_from_cp): New
local functions.
(term_w32select, globals_of_w32select): New global functions.
(Fw32_set_clipboard_data): Ignore parameter FRAME, use
clipboard_owner instead. Use delayed rendering and provide
all text formats. Provide CF_LOCALE if necessary.
(Fw32_get_clipboard_data): Handle CF_UNICODETEXT and
CF_LOCALE. Fall back to CF_TEXT, if CF_UNICODETEXT is not
available. Force DOS line-ends for decoding.
(Fx_selection_exists_p): Handle CF_UNICODETEXT.
(syms_of_w32select): Init and register new variables.
* w32.h: Add prototypes for globals_of_w32select and
term_w32select. Make the neighboring K&R declarations into
prototypes, too.
* emacs.c: Include w32.h to get function prototypes.
(main): Call globals_of_w32select.
* w32.c (term_ntproc): Call term_w32select.
* mule-cmds.el (set-locale-environment): Remove call to
set-selection-coding-system on Windows.
* s/ms-w32.h: Guard MSC-specific #pragmas with an #ifdef.
author | Jason Rumney <jasonr@gnu.org> |
---|---|
date | Tue, 15 Feb 2005 23:19:26 +0000 |
parents | 2954cb243379 |
children | e30c08177a3b ae7fab96922c |
rev | line source |
---|---|
54695 | 1 ;;; url-auth.el --- Uniform Resource Locator authorization modules |
57612 | 2 |
3 ;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc. | |
4 | |
54695 | 5 ;; Keywords: comm, data, processes, hypermedia |
6 | |
57612 | 7 ;; This file is part of GNU Emacs. |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
23 | |
24 ;;; Code: | |
54695 | 25 |
26 (require 'url-vars) | |
27 (require 'url-parse) | |
28 (autoload 'url-warn "url") | |
29 | |
30 (defsubst url-auth-user-prompt (url realm) | |
31 "String to usefully prompt for a username." | |
32 (concat "Username [for " | |
33 (or realm (url-truncate-url-for-viewing | |
34 (url-recreate-url url) | |
35 (- (window-width) 10 20))) | |
36 "]: ")) | |
37 | |
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
39 ;;; Basic authorization code | |
40 ;;; ------------------------ | |
41 ;;; This implements the BASIC authorization type. See the online | |
42 ;;; documentation at | |
43 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html | |
44 ;;; for the complete documentation on this type. | |
45 ;;; | |
46 ;;; This is very insecure, but it works as a proof-of-concept | |
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
48 (defvar url-basic-auth-storage 'url-http-real-basic-auth-storage | |
49 "Where usernames and passwords are stored. | |
50 | |
51 Must be a symbol pointing to another variable that will actually store | |
52 the information. The value of this variable is an assoc list of assoc | |
53 lists. The first assoc list is keyed by the server name. The cdr of | |
54 this is an assoc list based on the 'directory' specified by the url we | |
55 are looking up.") | |
56 | |
57 (defun url-basic-auth (url &optional prompt overwrite realm args) | |
58 "Get the username/password for the specified URL. | |
59 If optional argument PROMPT is non-nil, ask for the username/password | |
60 to use for the url and its descendants. If optional third argument | |
61 OVERWRITE is non-nil, overwrite the old username/password pair if it | |
62 is found in the assoc list. If REALM is specified, use that as the realm | |
63 instead of the pathname inheritance method." | |
64 (let* ((href (if (stringp url) | |
65 (url-generic-parse-url url) | |
66 url)) | |
67 (server (url-host href)) | |
68 (port (url-port href)) | |
69 (path (url-filename href)) | |
70 user pass byserv retval data) | |
71 (setq server (format "%s:%d" server port) | |
72 path (cond | |
73 (realm realm) | |
74 ((string-match "/$" path) path) | |
75 (t (url-basepath path))) | |
76 byserv (cdr-safe (assoc server | |
77 (symbol-value url-basic-auth-storage)))) | |
78 (cond | |
79 ((and prompt (not byserv)) | |
80 (setq user (read-string (url-auth-user-prompt url realm) | |
81 (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
|
82 pass (read-passwd "Password: ")) |
54695 | 83 (set url-basic-auth-storage |
84 (cons (list server | |
85 (cons path | |
86 (setq retval | |
87 (base64-encode-string | |
88 (format "%s:%s" user pass))))) | |
89 (symbol-value url-basic-auth-storage)))) | |
90 (byserv | |
91 (setq retval (cdr-safe (assoc path byserv))) | |
92 (if (and (not retval) | |
93 (string-match "/" path)) | |
94 (while (and byserv (not retval)) | |
95 (setq data (car (car byserv))) | |
96 (if (or (not (string-match "/" data)) ; Its a realm - take it! | |
97 (and | |
98 (>= (length path) (length data)) | |
99 (string= data (substring path 0 (length data))))) | |
100 (setq retval (cdr (car byserv)))) | |
101 (setq byserv (cdr byserv)))) | |
102 (if (or (and (not retval) prompt) overwrite) | |
103 (progn | |
104 (setq user (read-string (url-auth-user-prompt url realm) | |
105 (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
|
106 pass (read-passwd "Password: ") |
54695 | 107 retval (base64-encode-string (format "%s:%s" user pass)) |
108 byserv (assoc server (symbol-value url-basic-auth-storage))) | |
109 (setcdr byserv | |
110 (cons (cons path retval) (cdr byserv)))))) | |
111 (t (setq retval nil))) | |
112 (if retval (setq retval (concat "Basic " retval))) | |
113 retval)) | |
114 | |
115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
116 ;;; Digest authorization code | |
117 ;;; ------------------------ | |
118 ;;; This implements the DIGEST authorization type. See the internet draft | |
119 ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt | |
120 ;;; for the complete documentation on this type. | |
121 ;;; | |
122 ;;; This is very secure | |
123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
124 (defvar url-digest-auth-storage nil | |
125 "Where usernames and passwords are stored. Its value is an assoc list of | |
126 assoc lists. The first assoc list is keyed by the server name. The cdr of | |
127 this is an assoc list based on the 'directory' specified by the url we are | |
128 looking up.") | |
129 | |
130 (defun url-digest-auth-create-key (username password realm method uri) | |
131 "Create a key for digest authentication method" | |
132 (let* ((info (if (stringp uri) | |
133 (url-generic-parse-url uri) | |
134 uri)) | |
135 (a1 (md5 (concat username ":" realm ":" password))) | |
136 (a2 (md5 (concat method ":" (url-filename info))))) | |
137 (list a1 a2))) | |
138 | |
139 (defun url-digest-auth (url &optional prompt overwrite realm args) | |
140 "Get the username/password for the specified URL. | |
141 If optional argument PROMPT is non-nil, ask for the username/password | |
142 to use for the url and its descendants. If optional third argument | |
143 OVERWRITE is non-nil, overwrite the old username/password pair if it | |
144 is found in the assoc list. If REALM is specified, use that as the realm | |
145 instead of hostname:portnum." | |
146 (if args | |
147 (let* ((href (if (stringp url) | |
148 (url-generic-parse-url url) | |
149 url)) | |
150 (server (url-host href)) | |
151 (port (url-port href)) | |
152 (path (url-filename href)) | |
153 user pass byserv retval data) | |
154 (setq path (cond | |
155 (realm realm) | |
156 ((string-match "/$" path) path) | |
157 (t (url-basepath path))) | |
158 server (format "%s:%d" server port) | |
159 byserv (cdr-safe (assoc server url-digest-auth-storage))) | |
160 (cond | |
161 ((and prompt (not byserv)) | |
162 (setq user (read-string (url-auth-user-prompt url realm) | |
163 (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
|
164 pass (read-passwd "Password: ") |
54695 | 165 url-digest-auth-storage |
166 (cons (list server | |
167 (cons path | |
168 (setq retval | |
169 (cons user | |
170 (url-digest-auth-create-key | |
171 user pass realm | |
172 (or url-request-method "GET") | |
173 url))))) | |
174 url-digest-auth-storage))) | |
175 (byserv | |
176 (setq retval (cdr-safe (assoc path byserv))) | |
177 (if (and (not retval) ; no exact match, check directories | |
178 (string-match "/" path)) ; not looking for a realm | |
179 (while (and byserv (not retval)) | |
180 (setq data (car (car byserv))) | |
181 (if (or (not (string-match "/" data)) | |
182 (and | |
183 (>= (length path) (length data)) | |
184 (string= data (substring path 0 (length data))))) | |
185 (setq retval (cdr (car byserv)))) | |
186 (setq byserv (cdr byserv)))) | |
187 (if (or (and (not retval) prompt) overwrite) | |
188 (progn | |
189 (setq user (read-string (url-auth-user-prompt url realm) | |
190 (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
|
191 pass (read-passwd "Password: ") |
54695 | 192 retval (setq retval |
193 (cons user | |
194 (url-digest-auth-create-key | |
195 user pass realm | |
196 (or url-request-method "GET") | |
197 url))) | |
198 byserv (assoc server url-digest-auth-storage)) | |
199 (setcdr byserv | |
200 (cons (cons path retval) (cdr byserv)))))) | |
201 (t (setq retval nil))) | |
202 (if retval | |
203 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) | |
204 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven"))) | |
205 (format | |
206 (concat "Digest username=\"%s\", realm=\"%s\"," | |
207 "nonce=\"%s\", uri=\"%s\"," | |
208 "response=\"%s\", opaque=\"%s\"") | |
209 (nth 0 retval) realm nonce (url-filename href) | |
210 (md5 (concat (nth 1 retval) ":" nonce ":" | |
211 (nth 2 retval))) opaque)))))) | |
212 | |
213 (defvar url-registered-auth-schemes nil | |
214 "A list of the registered authorization schemes and various and sundry | |
215 information associated with them.") | |
216 | |
217 ;;;###autoload | |
218 (defun url-get-authentication (url realm type prompt &optional args) | |
219 "Return an authorization string suitable for use in the WWW-Authenticate | |
220 header in an HTTP/1.0 request. | |
221 | |
222 URL is the url you are requesting authorization to. This can be either a | |
223 string representing the URL, or the parsed representation returned by | |
224 `url-generic-parse-url' | |
225 REALM is the realm at a specific site we are looking for. This should be a | |
226 string specifying the exact realm, or nil or the symbol 'any' to | |
227 specify that the filename portion of the URL should be used as the | |
228 realm | |
229 TYPE is the type of authentication to be returned. This is either a string | |
230 representing the type (basic, digest, etc), or nil or the symbol 'any' | |
231 to specify that any authentication is acceptable. If requesting 'any' | |
232 the strongest matching authentication will be returned. If this is | |
233 wrong, its no big deal, the error from the server will specify exactly | |
234 what type of auth to use | |
235 PROMPT is boolean - specifies whether to ask the user for a username/password | |
236 if one cannot be found in the cache" | |
237 (if (not realm) | |
238 (setq realm (cdr-safe (assoc "realm" args)))) | |
239 (if (stringp url) | |
240 (setq url (url-generic-parse-url url))) | |
241 (if (or (null type) (eq type 'any)) | |
242 ;; Whooo doogies! | |
243 ;; Go through and get _all_ the authorization strings that could apply | |
244 ;; to this URL, store them along with the 'rating' we have in the list | |
245 ;; of schemes, then sort them so that the 'best' is at the front of the | |
246 ;; list, then get the car, then get the cdr. | |
247 ;; Zooom zooom zoooooom | |
248 (cdr-safe | |
249 (car-safe | |
250 (sort | |
251 (mapcar | |
252 (function | |
253 (lambda (scheme) | |
254 (if (fboundp (car (cdr scheme))) | |
255 (cons (cdr (cdr scheme)) | |
256 (funcall (car (cdr scheme)) url nil nil realm)) | |
257 (cons 0 nil)))) | |
258 url-registered-auth-schemes) | |
259 (function | |
260 (lambda (x y) | |
261 (cond | |
262 ((null (cdr x)) nil) | |
263 ((and (cdr x) (null (cdr y))) t) | |
264 ((and (cdr x) (cdr y)) | |
265 (>= (car x) (car y))) | |
266 (t nil))))))) | |
267 (if (symbolp type) (setq type (symbol-name type))) | |
268 (let* ((scheme (car-safe | |
269 (cdr-safe (assoc (downcase type) | |
270 url-registered-auth-schemes))))) | |
271 (if (and scheme (fboundp scheme)) | |
272 (funcall scheme url prompt | |
273 (and prompt | |
274 (funcall scheme url nil nil realm args)) | |
275 realm args))))) | |
276 | |
277 ;;;###autoload | |
278 (defun url-register-auth-scheme (type &optional function rating) | |
279 "Register an HTTP authentication method. | |
280 | |
281 TYPE is a string or symbol specifying the name of the method. This | |
282 should be the same thing you expect to get returned in an Authenticate | |
283 header in HTTP/1.0 - it will be downcased. | |
284 FUNCTION is the function to call to get the authorization information. This | |
285 defaults to `url-?-auth', where ? is TYPE | |
286 RATING a rating between 1 and 10 of the strength of the authentication. | |
287 This is used when asking for the best authentication for a specific | |
288 URL. The item with the highest rating is returned." | |
289 (let* ((type (cond | |
290 ((stringp type) (downcase type)) | |
291 ((symbolp type) (downcase (symbol-name type))) | |
292 (t (error "Bad call to `url-register-auth-scheme'")))) | |
293 (function (or function (intern (concat "url-" type "-auth")))) | |
294 (rating (cond | |
295 ((null rating) 2) | |
296 ((stringp rating) (string-to-int rating)) | |
297 (t rating))) | |
298 (node (assoc type url-registered-auth-schemes))) | |
299 (if (not (fboundp function)) | |
300 (url-warn 'security | |
54792
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
301 (format (concat |
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
302 "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
|
303 ", but it is not a function!") function))) |
54695 | 304 |
305 (if node | |
306 (setcdr node (cons function rating)) | |
307 (setq url-registered-auth-schemes | |
308 (cons (cons type (cons function rating)) | |
309 url-registered-auth-schemes))))) | |
310 | |
311 (defun url-auth-registered (scheme) | |
312 ;; Return non-nil iff SCHEME is registered as an auth type | |
313 (assoc scheme url-registered-auth-schemes)) | |
314 | |
315 (provide 'url-auth) | |
54699 | 316 |
317 ;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91 | |
57612 | 318 ;;; url-auth.el ends here |