Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-auth.el --- Uniform Resource Locator authorization modules |
00eef4de | 2 | |
8705576e | 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, |
ae940284 | 4 | ;; 2008, 2009 Free Software Foundation, Inc. |
00eef4de | 5 | |
8c8b8430 SM |
6 | ;; Keywords: comm, data, processes, hypermedia |
7 | ||
00eef4de LH |
8 | ;; This file is part of GNU Emacs. |
9 | ||
4936186e | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
00eef4de | 11 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
00eef4de LH |
14 | |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
4936186e | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
00eef4de LH |
22 | |
23 | ;;; Code: | |
8c8b8430 SM |
24 | |
25 | (require 'url-vars) | |
26 | (require 'url-parse) | |
27 | (autoload 'url-warn "url") | |
8705576e | 28 | (autoload 'auth-source-user-or-password "auth-source") |
97d1c236 | 29 | |
8c8b8430 SM |
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 | |
d1ce47b0 | 54 | this is an assoc list based on the 'directory' specified by the URL we |
8c8b8430 SM |
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 | |
ff51e86d | 63 | instead of the filename inheritance method." |
8c8b8430 SM |
64 | (let* ((href (if (stringp url) |
65 | (url-generic-parse-url url) | |
66 | url)) | |
67 | (server (url-host href)) | |
97d1c236 | 68 | (type (url-type href)) |
8c8b8430 | 69 | (port (url-port href)) |
ff51e86d | 70 | (file (url-filename href)) |
2540a3ab VJL |
71 | (user (url-user href)) |
72 | (pass (url-password href)) | |
73 | byserv retval data) | |
8c8b8430 | 74 | (setq server (format "%s:%d" server port) |
ff51e86d | 75 | file (cond |
8c8b8430 | 76 | (realm realm) |
ff51e86d RS |
77 | ((string= "" file) "/") |
78 | ((string-match "/$" file) file) | |
79 | (t (url-file-directory file))) | |
8c8b8430 SM |
80 | byserv (cdr-safe (assoc server |
81 | (symbol-value url-basic-auth-storage)))) | |
82 | (cond | |
83 | ((and prompt (not byserv)) | |
8705576e | 84 | (setq user (or |
97d1c236 TZ |
85 | (auth-source-user-or-password "login" server type) |
86 | (read-string (url-auth-user-prompt url realm) | |
87 | (or user (user-real-login-name)))) | |
8705576e | 88 | pass (or |
97d1c236 TZ |
89 | (auth-source-user-or-password "password" server type) |
90 | (read-passwd "Password: " nil (or pass "")))) | |
8c8b8430 SM |
91 | (set url-basic-auth-storage |
92 | (cons (list server | |
ff51e86d | 93 | (cons file |
8c8b8430 SM |
94 | (setq retval |
95 | (base64-encode-string | |
ab8dad36 CY |
96 | (format "%s:%s" user |
97 | (encode-coding-string pass 'utf-8)))))) | |
8c8b8430 SM |
98 | (symbol-value url-basic-auth-storage)))) |
99 | (byserv | |
ff51e86d | 100 | (setq retval (cdr-safe (assoc file byserv))) |
8c8b8430 | 101 | (if (and (not retval) |
ff51e86d | 102 | (string-match "/" file)) |
8c8b8430 SM |
103 | (while (and byserv (not retval)) |
104 | (setq data (car (car byserv))) | |
d7c2974d | 105 | (if (or (not (string-match "/" data)) ; It's a realm - take it! |
8c8b8430 | 106 | (and |
ff51e86d RS |
107 | (>= (length file) (length data)) |
108 | (string= data (substring file 0 (length data))))) | |
8c8b8430 SM |
109 | (setq retval (cdr (car byserv)))) |
110 | (setq byserv (cdr byserv)))) | |
111 | (if (or (and (not retval) prompt) overwrite) | |
112 | (progn | |
8705576e | 113 | (setq user (or |
97d1c236 TZ |
114 | (auth-source-user-or-password "login" server type) |
115 | (read-string (url-auth-user-prompt url realm) | |
116 | (user-real-login-name))) | |
8705576e | 117 | pass (or |
97d1c236 TZ |
118 | (auth-source-user-or-password "password" server type) |
119 | (read-passwd "Password: ")) | |
8c8b8430 SM |
120 | retval (base64-encode-string (format "%s:%s" user pass)) |
121 | byserv (assoc server (symbol-value url-basic-auth-storage))) | |
122 | (setcdr byserv | |
ff51e86d | 123 | (cons (cons file retval) (cdr byserv)))))) |
8c8b8430 SM |
124 | (t (setq retval nil))) |
125 | (if retval (setq retval (concat "Basic " retval))) | |
126 | retval)) | |
127 | ||
128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
129 | ;;; Digest authorization code | |
130 | ;;; ------------------------ | |
131 | ;;; This implements the DIGEST authorization type. See the internet draft | |
132 | ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt | |
133 | ;;; for the complete documentation on this type. | |
134 | ;;; | |
135 | ;;; This is very secure | |
136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
137 | (defvar url-digest-auth-storage nil | |
d1ce47b0 JB |
138 | "Where usernames and passwords are stored. |
139 | Its value is an assoc list of assoc lists. The first assoc list is | |
140 | keyed by the server name. The cdr of this is an assoc list based | |
141 | on the 'directory' specified by the url we are looking up.") | |
8c8b8430 SM |
142 | |
143 | (defun url-digest-auth-create-key (username password realm method uri) | |
144 | "Create a key for digest authentication method" | |
145 | (let* ((info (if (stringp uri) | |
146 | (url-generic-parse-url uri) | |
147 | uri)) | |
148 | (a1 (md5 (concat username ":" realm ":" password))) | |
149 | (a2 (md5 (concat method ":" (url-filename info))))) | |
150 | (list a1 a2))) | |
151 | ||
152 | (defun url-digest-auth (url &optional prompt overwrite realm args) | |
153 | "Get the username/password for the specified URL. | |
154 | If optional argument PROMPT is non-nil, ask for the username/password | |
d1ce47b0 | 155 | to use for the URL and its descendants. If optional third argument |
8c8b8430 SM |
156 | OVERWRITE is non-nil, overwrite the old username/password pair if it |
157 | is found in the assoc list. If REALM is specified, use that as the realm | |
158 | instead of hostname:portnum." | |
159 | (if args | |
160 | (let* ((href (if (stringp url) | |
161 | (url-generic-parse-url url) | |
162 | url)) | |
163 | (server (url-host href)) | |
97d1c236 | 164 | (type (url-type href)) |
8c8b8430 | 165 | (port (url-port href)) |
ff51e86d | 166 | (file (url-filename href)) |
8c8b8430 | 167 | user pass byserv retval data) |
ff51e86d | 168 | (setq file (cond |
8c8b8430 | 169 | (realm realm) |
ff51e86d RS |
170 | ((string-match "/$" file) file) |
171 | (t (url-file-directory file))) | |
8c8b8430 SM |
172 | server (format "%s:%d" server port) |
173 | byserv (cdr-safe (assoc server url-digest-auth-storage))) | |
174 | (cond | |
175 | ((and prompt (not byserv)) | |
97d1c236 TZ |
176 | (setq user (or |
177 | (auth-source-user-or-password "login" server type) | |
178 | (read-string (url-auth-user-prompt url realm) | |
179 | (user-real-login-name))) | |
180 | pass (or | |
181 | (auth-source-user-or-password "password" server type) | |
182 | (read-passwd "Password: ")) | |
8c8b8430 SM |
183 | url-digest-auth-storage |
184 | (cons (list server | |
ff51e86d | 185 | (cons file |
8c8b8430 SM |
186 | (setq retval |
187 | (cons user | |
188 | (url-digest-auth-create-key | |
189 | user pass realm | |
190 | (or url-request-method "GET") | |
191 | url))))) | |
192 | url-digest-auth-storage))) | |
193 | (byserv | |
ff51e86d | 194 | (setq retval (cdr-safe (assoc file byserv))) |
8c8b8430 | 195 | (if (and (not retval) ; no exact match, check directories |
ff51e86d | 196 | (string-match "/" file)) ; not looking for a realm |
8c8b8430 SM |
197 | (while (and byserv (not retval)) |
198 | (setq data (car (car byserv))) | |
199 | (if (or (not (string-match "/" data)) | |
200 | (and | |
ff51e86d RS |
201 | (>= (length file) (length data)) |
202 | (string= data (substring file 0 (length data))))) | |
8c8b8430 SM |
203 | (setq retval (cdr (car byserv)))) |
204 | (setq byserv (cdr byserv)))) | |
e652840b JW |
205 | (if overwrite |
206 | (if (and (not retval) prompt) | |
8705576e | 207 | (setq user (or |
97d1c236 TZ |
208 | (auth-source-user-or-password "login" server type) |
209 | (read-string (url-auth-user-prompt url realm) | |
210 | (user-real-login-name))) | |
8705576e | 211 | pass (or |
97d1c236 TZ |
212 | (auth-source-user-or-password "password" server type) |
213 | (read-passwd "Password: ")) | |
e652840b JW |
214 | retval (setq retval |
215 | (cons user | |
216 | (url-digest-auth-create-key | |
217 | user pass realm | |
218 | (or url-request-method "GET") | |
219 | url))) | |
220 | byserv (assoc server url-digest-auth-storage)) | |
8c8b8430 | 221 | (setcdr byserv |
ff51e86d | 222 | (cons (cons file retval) (cdr byserv)))))) |
8c8b8430 SM |
223 | (t (setq retval nil))) |
224 | (if retval | |
e652840b JW |
225 | (if (cdr-safe (assoc "opaque" args)) |
226 | (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) | |
227 | (opaque (cdr-safe (assoc "opaque" args)))) | |
228 | (format | |
229 | (concat "Digest username=\"%s\", realm=\"%s\"," | |
230 | "nonce=\"%s\", uri=\"%s\"," | |
231 | "response=\"%s\", opaque=\"%s\"") | |
232 | (nth 0 retval) realm nonce (url-filename href) | |
233 | (md5 (concat (nth 1 retval) ":" nonce ":" | |
234 | (nth 2 retval))) opaque)) | |
235 | (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))) | |
236 | (format | |
237 | (concat "Digest username=\"%s\", realm=\"%s\"," | |
238 | "nonce=\"%s\", uri=\"%s\"," | |
239 | "response=\"%s\"") | |
240 | (nth 0 retval) realm nonce (url-filename href) | |
241 | (md5 (concat (nth 1 retval) ":" nonce ":" | |
242 | (nth 2 retval)))))))))) | |
8c8b8430 SM |
243 | |
244 | (defvar url-registered-auth-schemes nil | |
245 | "A list of the registered authorization schemes and various and sundry | |
246 | information associated with them.") | |
247 | ||
248 | ;;;###autoload | |
249 | (defun url-get-authentication (url realm type prompt &optional args) | |
250 | "Return an authorization string suitable for use in the WWW-Authenticate | |
251 | header in an HTTP/1.0 request. | |
252 | ||
253 | URL is the url you are requesting authorization to. This can be either a | |
254 | string representing the URL, or the parsed representation returned by | |
255 | `url-generic-parse-url' | |
256 | REALM is the realm at a specific site we are looking for. This should be a | |
257 | string specifying the exact realm, or nil or the symbol 'any' to | |
258 | specify that the filename portion of the URL should be used as the | |
259 | realm | |
260 | TYPE is the type of authentication to be returned. This is either a string | |
261 | representing the type (basic, digest, etc), or nil or the symbol 'any' | |
262 | to specify that any authentication is acceptable. If requesting 'any' | |
263 | the strongest matching authentication will be returned. If this is | |
d7c2974d | 264 | wrong, it's no big deal, the error from the server will specify exactly |
8c8b8430 SM |
265 | what type of auth to use |
266 | PROMPT is boolean - specifies whether to ask the user for a username/password | |
267 | if one cannot be found in the cache" | |
268 | (if (not realm) | |
269 | (setq realm (cdr-safe (assoc "realm" args)))) | |
270 | (if (stringp url) | |
271 | (setq url (url-generic-parse-url url))) | |
272 | (if (or (null type) (eq type 'any)) | |
273 | ;; Whooo doogies! | |
274 | ;; Go through and get _all_ the authorization strings that could apply | |
275 | ;; to this URL, store them along with the 'rating' we have in the list | |
276 | ;; of schemes, then sort them so that the 'best' is at the front of the | |
277 | ;; list, then get the car, then get the cdr. | |
278 | ;; Zooom zooom zoooooom | |
279 | (cdr-safe | |
280 | (car-safe | |
281 | (sort | |
282 | (mapcar | |
283 | (function | |
284 | (lambda (scheme) | |
285 | (if (fboundp (car (cdr scheme))) | |
286 | (cons (cdr (cdr scheme)) | |
287 | (funcall (car (cdr scheme)) url nil nil realm)) | |
288 | (cons 0 nil)))) | |
289 | url-registered-auth-schemes) | |
290 | (function | |
291 | (lambda (x y) | |
292 | (cond | |
293 | ((null (cdr x)) nil) | |
294 | ((and (cdr x) (null (cdr y))) t) | |
295 | ((and (cdr x) (cdr y)) | |
296 | (>= (car x) (car y))) | |
297 | (t nil))))))) | |
298 | (if (symbolp type) (setq type (symbol-name type))) | |
299 | (let* ((scheme (car-safe | |
300 | (cdr-safe (assoc (downcase type) | |
301 | url-registered-auth-schemes))))) | |
302 | (if (and scheme (fboundp scheme)) | |
303 | (funcall scheme url prompt | |
304 | (and prompt | |
305 | (funcall scheme url nil nil realm args)) | |
306 | realm args))))) | |
307 | ||
308 | ;;;###autoload | |
309 | (defun url-register-auth-scheme (type &optional function rating) | |
310 | "Register an HTTP authentication method. | |
311 | ||
d1ce47b0 JB |
312 | TYPE is a string or symbol specifying the name of the method. |
313 | This should be the same thing you expect to get returned in | |
314 | an Authenticate header in HTTP/1.0 - it will be downcased. | |
315 | FUNCTION is the function to call to get the authorization information. | |
316 | This defaults to `url-?-auth', where ? is TYPE. | |
8c8b8430 SM |
317 | RATING a rating between 1 and 10 of the strength of the authentication. |
318 | This is used when asking for the best authentication for a specific | |
319 | URL. The item with the highest rating is returned." | |
320 | (let* ((type (cond | |
321 | ((stringp type) (downcase type)) | |
322 | ((symbolp type) (downcase (symbol-name type))) | |
323 | (t (error "Bad call to `url-register-auth-scheme'")))) | |
324 | (function (or function (intern (concat "url-" type "-auth")))) | |
325 | (rating (cond | |
326 | ((null rating) 2) | |
216d3806 | 327 | ((stringp rating) (string-to-number rating)) |
8c8b8430 SM |
328 | (t rating))) |
329 | (node (assoc type url-registered-auth-schemes))) | |
330 | (if (not (fboundp function)) | |
331 | (url-warn 'security | |
caae2fd8 SM |
332 | (format (concat |
333 | "Tried to register `%s' as an auth scheme" | |
334 | ", but it is not a function!") function))) | |
8c8b8430 SM |
335 | |
336 | (if node | |
337 | (setcdr node (cons function rating)) | |
338 | (setq url-registered-auth-schemes | |
339 | (cons (cons type (cons function rating)) | |
340 | url-registered-auth-schemes))))) | |
341 | ||
342 | (defun url-auth-registered (scheme) | |
3ecd3a56 | 343 | "Return non-nil if SCHEME is registered as an auth type." |
8c8b8430 SM |
344 | (assoc scheme url-registered-auth-schemes)) |
345 | ||
346 | (provide 'url-auth) | |
e5566bd5 | 347 | |
ba76db87 | 348 | ;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91 |
00eef4de | 349 | ;;; url-auth.el ends here |