Mercurial > hg > xemacs-beta

comparison lisp/w3/url-auth.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 0293115a14e9
children 441bb1e64a06
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
2 ;; Author: wmperry
3 ;; Created: 1997/01/19 01:17:29
4 ;; Version: 1.5
5 ;; Keywords: comm, data, processes, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
17 ;;;
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29 (require 'url-vars)
30 (require 'url-parse)
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 ;;; Basic authorization code
33 ;;; ------------------------
34 ;;; This implements the BASIC authorization type. See the online
35 ;;; documentation at
36 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
37 ;;; for the complete documentation on this type.
38 ;;;
39 ;;; This is very insecure, but it works as a proof-of-concept
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 (defvar url-basic-auth-storage nil
42 "Where usernames and passwords are stored. Its value is an assoc list of
43 assoc lists. The first assoc list is keyed by the server name. The cdr of
44 this is an assoc list based on the 'directory' specified by the url we are
45 looking up.")
46
47 (defun url-basic-auth (url &optional prompt overwrite realm args)
48 "Get the username/password for the specified URL.
49 If optional argument PROMPT is non-nil, ask for the username/password
50 to use for the url and its descendants. If optional third argument
51 OVERWRITE is non-nil, overwrite the old username/password pair if it
52 is found in the assoc list. If REALM is specified, use that as the realm
53 instead of the pathname inheritance method."
54 (let* ((href (if (stringp url)
55 (url-generic-parse-url url)
56 url))
57 (server (or (url-host href) url-current-server))
58 (port (or (url-port href) "80"))
59 (path (url-filename href))
60 user pass byserv retval data)
61 (setq server (concat server ":" port)
62 path (cond
63 (realm realm)
64 ((string-match "/$" path) path)
65 (t (url-basepath path)))
66 byserv (cdr-safe (assoc server url-basic-auth-storage)))
67 (cond
68 ((and prompt (not byserv))
69 (setq user (read-string "Username: " (user-real-login-name))
70 pass (funcall url-passwd-entry-func "Password: ")
71 url-basic-auth-storage
72 (cons (list server
73 (cons path
74 (setq retval
75 (base64-encode
76 (format "%s:%s" user pass)))))
77 url-basic-auth-storage)))
78 (byserv
79 (setq retval (cdr-safe (assoc path byserv)))
80 (if (and (not retval)
81 (string-match "/" path))
82 (while (and byserv (not retval))
83 (setq data (car (car byserv)))
84 (if (or (not (string-match "/" data)) ; Its a realm - take it!
85 (and
86 (>= (length path) (length data))
87 (string= data (substring path 0 (length data)))))
88 (setq retval (cdr (car byserv))))
89 (setq byserv (cdr byserv))))
90 (if (or (and (not retval) prompt) overwrite)
91 (progn
92 (setq user (read-string "Username: " (user-real-login-name))
93 pass (funcall url-passwd-entry-func "Password: ")
94 retval (base64-encode (format "%s:%s" user pass))
95 byserv (assoc server url-basic-auth-storage))
96 (setcdr byserv
97 (cons (cons path retval) (cdr byserv))))))
98 (t (setq retval nil)))
99 (if retval (setq retval (concat "Basic " retval)))
100 retval))
101
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103 ;;; Digest authorization code
104 ;;; ------------------------
105 ;;; This implements the DIGEST authorization type. See the internet draft
106 ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
107 ;;; for the complete documentation on this type.
108 ;;;
109 ;;; This is very secure
110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 (defvar url-digest-auth-storage nil
112 "Where usernames and passwords are stored. Its value is an assoc list of
113 assoc lists. The first assoc list is keyed by the server name. The cdr of
114 this is an assoc list based on the 'directory' specified by the url we are
115 looking up.")
116
117 (defun url-digest-auth-create-key (username password realm method uri)
118 "Create a key for digest authentication method"
119 (let* ((info (if (stringp uri)
120 (url-generic-parse-url uri)
121 uri))
122 (a1 (md5 (concat username ":" realm ":" password)))
123 (a2 (md5 (concat method ":" (url-filename info)))))
124 (list a1 a2)))
125
126 (defun url-digest-auth (url &optional prompt overwrite realm args)
127 "Get the username/password for the specified URL.
128 If optional argument PROMPT is non-nil, ask for the username/password
129 to use for the url and its descendants. If optional third argument
130 OVERWRITE is non-nil, overwrite the old username/password pair if it
131 is found in the assoc list. If REALM is specified, use that as the realm
132 instead of hostname:portnum."
133 (if args
134 (let* ((href (if (stringp url)
135 (url-generic-parse-url url)
136 url))
137 (server (or (url-host href) url-current-server))
138 (port (or (url-port href) "80"))
139 (path (url-filename href))
140 user pass byserv retval data)
141 (setq path (cond
142 (realm realm)
143 ((string-match "/$" path) path)
144 (t (url-basepath path)))
145 server (concat server ":" port)
146 byserv (cdr-safe (assoc server url-digest-auth-storage)))
147 (cond
148 ((and prompt (not byserv))
149 (setq user (read-string "Username: " (user-real-login-name))
150 pass (funcall url-passwd-entry-func "Password: ")
151 url-digest-auth-storage
152 (cons (list server
153 (cons path
154 (setq retval
155 (cons user
156 (url-digest-auth-create-key
157 user pass realm
158 (or url-request-method "GET")
159 url)))))
160 url-digest-auth-storage)))
161 (byserv
162 (setq retval (cdr-safe (assoc path byserv)))
163 (if (and (not retval) ; no exact match, check directories
164 (string-match "/" path)) ; not looking for a realm
165 (while (and byserv (not retval))
166 (setq data (car (car byserv)))
167 (if (or (not (string-match "/" data))
168 (and
169 (>= (length path) (length data))
170 (string= data (substring path 0 (length data)))))
171 (setq retval (cdr (car byserv))))
172 (setq byserv (cdr byserv))))
173 (if (or (and (not retval) prompt) overwrite)
174 (progn
175 (setq user (read-string "Username: " (user-real-login-name))
176 pass (funcall url-passwd-entry-func "Password: ")
177 retval (setq retval
178 (cons user
179 (url-digest-auth-create-key
180 user pass realm
181 (or url-request-method "GET")
182 url)))
183 byserv (assoc server url-digest-auth-storage))
184 (setcdr byserv
185 (cons (cons path retval) (cdr byserv))))))
186 (t (setq retval nil)))
187 (if retval
188 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
189 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
190 (format
191 (concat "Digest username=\"%s\", realm=\"%s\","
192 "nonce=\"%s\", uri=\"%s\","
193 "response=\"%s\", opaque=\"%s\"")
194 (nth 0 retval) realm nonce (url-filename href)
195 (md5 (concat (nth 1 retval) ":" nonce ":"
196 (nth 2 retval))) opaque))))))
197
198 (defvar url-registered-auth-schemes nil
199 "A list of the registered authorization schemes and various and sundry
200 information associated with them.")
201
202 ;;###autoload
203 (defun url-get-authentication (url realm type prompt &optional args)
204 "Return an authorization string suitable for use in the WWW-Authenticate
205 header in an HTTP/1.0 request.
206
207 URL is the url you are requesting authorization to. This can be either a
208 string representing the URL, or the parsed representation returned by
209 `url-generic-parse-url'
210 REALM is the realm at a specific site we are looking for. This should be a
211 string specifying the exact realm, or nil or the symbol 'any' to
212 specify that the filename portion of the URL should be used as the
213 realm
214 TYPE is the type of authentication to be returned. This is either a string
215 representing the type (basic, digest, etc), or nil or the symbol 'any'
216 to specify that any authentication is acceptable. If requesting 'any'
217 the strongest matching authentication will be returned. If this is
218 wrong, its no big deal, the error from the server will specify exactly
219 what type of auth to use
220 PROMPT is boolean - specifies whether to ask the user for a username/password
221 if one cannot be found in the cache"
222 (if (not realm)
223 (setq realm (cdr-safe (assoc "realm" args))))
224 (if (stringp url)
225 (setq url (url-generic-parse-url url)))
226 (if (or (null type) (eq type 'any))
227 ;; Whooo doogies!
228 ;; Go through and get _all_ the authorization strings that could apply
229 ;; to this URL, store them along with the 'rating' we have in the list
230 ;; of schemes, then sort them so that the 'best' is at the front of the
231 ;; list, then get the car, then get the cdr.
232 ;; Zooom zooom zoooooom
233 (cdr-safe
234 (car-safe
235 (sort
236 (mapcar
237 (function
238 (lambda (scheme)
239 (if (fboundp (car (cdr scheme)))
240 (cons (cdr (cdr scheme))
241 (funcall (car (cdr scheme)) url nil nil realm))
242 (cons 0 nil))))
243 url-registered-auth-schemes)
244 (function
245 (lambda (x y)
246 (cond
247 ((null (cdr x)) nil)
248 ((and (cdr x) (null (cdr y))) t)
249 ((and (cdr x) (cdr y))
250 (>= (car x) (car y)))
251 (t nil)))))))
252 (if (symbolp type) (setq type (symbol-name type)))
253 (let* ((scheme (car-safe
254 (cdr-safe (assoc (downcase type)
255 url-registered-auth-schemes)))))
256 (if (and scheme (fboundp scheme))
257 (funcall scheme url prompt
258 (and prompt
259 (funcall scheme url nil nil realm args))
260 realm args)))))
261
262 ;;###autoload
263 (defun url-register-auth-scheme (type &optional function rating)
264 "Register an HTTP authentication method.
265
266 TYPE is a string or symbol specifying the name of the method. This
267 should be the same thing you expect to get returned in an Authenticate
268 header in HTTP/1.0 - it will be downcased.
269 FUNCTION is the function to call to get the authorization information. This
270 defaults to `url-?-auth', where ? is TYPE
271 RATING a rating between 1 and 10 of the strength of the authentication.
272 This is used when asking for the best authentication for a specific
273 URL. The item with the highest rating is returned."
274 (let* ((type (cond
275 ((stringp type) (downcase type))
276 ((symbolp type) (downcase (symbol-name type)))
277 (t (error "Bad call to `url-register-auth-scheme'"))))
278 (function (or function (intern (concat "url-" type "-auth"))))
279 (rating (cond
280 ((null rating) 2)
281 ((stringp rating) (string-to-int rating))
282 (t rating)))
283 (node (assoc type url-registered-auth-schemes)))
284 (if (not (fboundp function))
285 (url-warn 'security
286 (format (eval-when-compile
287 "Tried to register `%s' as an auth scheme"
288 ", but it is not a function!") function)))
289
290 (if node
291 (progn
292 (setcdr node (cons function rating))
293 (url-warn 'security
294 (format
295 "Replacing authorization method `%s' - this could be bad."
296 type)))
297 (setq url-registered-auth-schemes
298 (cons (cons type (cons function rating))
299 url-registered-auth-schemes)))))
300
301 (defun url-auth-registered (scheme)
302 ;; Return non-nil iff SCHEME is registered as an auth type
303 (assoc scheme url-registered-auth-schemes))
304
305 (provide 'urlauth)