|
0
|
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)
|
