Mercurial > hg > xemacs-beta

comparison lisp/url/urlauth.el @ 0:376386a54a3c r19-14

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