|
14
|
1 ;;; urlauth.el --- Uniform Resource Locator authorization modules
|
|
|
2 ;; Author: wmperry
|
|
|
3 ;; Created: 1996/10/09 19:00:59
|
|
|
4 ;; Version: 1.2
|
|
|
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 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 (defun url-get-authentication (url realm type prompt &optional args)
|
|
|
203 "Return an authorization string suitable for use in the WWW-Authenticate
|
|
|
204 header in an HTTP/1.0 request.
|
|
|
205
|
|
|
206 URL is the url you are requesting authorization to. This can be either a
|
|
|
207 string representing the URL, or the parsed representation returned by
|
|
|
208 `url-generic-parse-url'
|
|
|
209 REALM is the realm at a specific site we are looking for. This should be a
|
|
|
210 string specifying the exact realm, or nil or the symbol 'any' to
|
|
|
211 specify that the filename portion of the URL should be used as the
|
|
|
212 realm
|
|
|
213 TYPE is the type of authentication to be returned. This is either a string
|
|
|
214 representing the type (basic, digest, etc), or nil or the symbol 'any'
|
|
|
215 to specify that any authentication is acceptable. If requesting 'any'
|
|
|
216 the strongest matching authentication will be returned. If this is
|
|
|
217 wrong, its no big deal, the error from the server will specify exactly
|
|
|
218 what type of auth to use
|
|
|
219 PROMPT is boolean - specifies whether to ask the user for a username/password
|
|
|
220 if one cannot be found in the cache"
|
|
|
221 (if (not realm)
|
|
|
222 (setq realm (cdr-safe (assoc "realm" args))))
|
|
|
223 (if (stringp url)
|
|
|
224 (setq url (url-generic-parse-url url)))
|
|
|
225 (if (or (null type) (eq type 'any))
|
|
|
226 ;; Whooo doogies!
|
|
|
227 ;; Go through and get _all_ the authorization strings that could apply
|
|
|
228 ;; to this URL, store them along with the 'rating' we have in the list
|
|
|
229 ;; of schemes, then sort them so that the 'best' is at the front of the
|
|
|
230 ;; list, then get the car, then get the cdr.
|
|
|
231 ;; Zooom zooom zoooooom
|
|
|
232 (cdr-safe
|
|
|
233 (car-safe
|
|
|
234 (sort
|
|
|
235 (mapcar
|
|
|
236 (function
|
|
|
237 (lambda (scheme)
|
|
|
238 (if (fboundp (car (cdr scheme)))
|
|
|
239 (cons (cdr (cdr scheme))
|
|
|
240 (funcall (car (cdr scheme)) url nil nil realm))
|
|
|
241 (cons 0 nil))))
|
|
|
242 url-registered-auth-schemes)
|
|
|
243 (function
|
|
|
244 (lambda (x y)
|
|
|
245 (cond
|
|
|
246 ((null (cdr x)) nil)
|
|
|
247 ((and (cdr x) (null (cdr y))) t)
|
|
|
248 ((and (cdr x) (cdr y))
|
|
|
249 (>= (car x) (car y)))
|
|
|
250 (t nil)))))))
|
|
|
251 (if (symbolp type) (setq type (symbol-name type)))
|
|
|
252 (let* ((scheme (car-safe
|
|
|
253 (cdr-safe (assoc (downcase type)
|
|
|
254 url-registered-auth-schemes)))))
|
|
|
255 (if (and scheme (fboundp scheme))
|
|
|
256 (funcall scheme url prompt
|
|
|
257 (and prompt
|
|
|
258 (funcall scheme url nil nil realm args))
|
|
|
259 realm args)))))
|
|
|
260
|
|
|
261 (defun url-register-auth-scheme (type &optional function rating)
|
|
|
262 "Register an HTTP authentication method.
|
|
|
263
|
|
|
264 TYPE is a string or symbol specifying the name of the method. This
|
|
|
265 should be the same thing you expect to get returned in an Authenticate
|
|
|
266 header in HTTP/1.0 - it will be downcased.
|
|
|
267 FUNCTION is the function to call to get the authorization information. This
|
|
|
268 defaults to `url-?-auth', where ? is TYPE
|
|
|
269 RATING a rating between 1 and 10 of the strength of the authentication.
|
|
|
270 This is used when asking for the best authentication for a specific
|
|
|
271 URL. The item with the highest rating is returned."
|
|
|
272 (let* ((type (cond
|
|
|
273 ((stringp type) (downcase type))
|
|
|
274 ((symbolp type) (downcase (symbol-name type)))
|
|
|
275 (t (error "Bad call to `url-register-auth-scheme'"))))
|
|
|
276 (function (or function (intern (concat "url-" type "-auth"))))
|
|
|
277 (rating (cond
|
|
|
278 ((null rating) 2)
|
|
|
279 ((stringp rating) (string-to-int rating))
|
|
|
280 (t rating)))
|
|
|
281 (node (assoc type url-registered-auth-schemes)))
|
|
|
282 (if (not (fboundp function))
|
|
|
283 (url-warn 'security
|
|
|
284 (format (eval-when-compile
|
|
|
285 "Tried to register `%s' as an auth scheme"
|
|
|
286 ", but it is not a function!") function)))
|
|
|
287
|
|
|
288 (if node
|
|
|
289 (progn
|
|
|
290 (setcdr node (cons function rating))
|
|
|
291 (url-warn 'security
|
|
|
292 (format
|
|
|
293 "Replacing authorization method `%s' - this could be bad."
|
|
|
294 type)))
|
|
|
295 (setq url-registered-auth-schemes
|
|
|
296 (cons (cons type (cons function rating))
|
|
|
297 url-registered-auth-schemes)))))
|
|
|
298
|
|
|
299 (defun url-auth-registered (scheme)
|
|
|
300 ;; Return non-nil iff SCHEME is registered as an auth type
|
|
|
301 (assoc scheme url-registered-auth-schemes))
|
|
|
302
|
|
|
303 (provide 'urlauth)
|
