1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007,
4 ;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
6 ;; Keywords: comm, data, processes, hypermedia
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 (autoload 'url-warn
"url")
28 (autoload 'auth-source-user-or-password
"auth-source")
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)))
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 ;;; Basic authorization code
40 ;;; ------------------------
41 ;;; This implements the BASIC authorization type. See the online
43 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
44 ;;; for the complete documentation on this type.
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.
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
54 this is an assoc list based on the 'directory' specified by the URL we
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
63 instead of the filename inheritance method."
64 (let* ((href (if (stringp url
)
65 (url-generic-parse-url url
)
67 (server (url-host href
))
68 (type (url-type href
))
69 (port (url-port href
))
70 (file (url-filename href
))
71 (user (url-user href
))
72 (pass (url-password href
))
74 (setq server
(format "%s:%d" server port
)
77 ((string= "" file
) "/")
78 ((string-match "/$" file
) file
)
79 (t (url-file-directory file
)))
80 byserv
(cdr-safe (assoc server
81 (symbol-value url-basic-auth-storage
))))
83 ((and prompt
(not byserv
))
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))))
89 (auth-source-user-or-password "password" server type
)
90 (read-passwd "Password: " nil
(or pass
""))))
91 (set url-basic-auth-storage
97 (encode-coding-string pass
'utf-8
))))))
98 (symbol-value url-basic-auth-storage
))))
100 (setq retval
(cdr-safe (assoc file byserv
)))
101 (if (and (not retval
)
102 (string-match "/" file
))
103 (while (and byserv
(not retval
))
104 (setq data
(car (car byserv
)))
105 (if (or (not (string-match "/" data
)) ; It's a realm - take it!
107 (>= (length file
) (length data
))
108 (string= data
(substring file
0 (length data
)))))
109 (setq retval
(cdr (car byserv
))))
110 (setq byserv
(cdr byserv
))))
111 (if (or (and (not retval
) prompt
) overwrite
)
114 (auth-source-user-or-password "login" server type
)
115 (read-string (url-auth-user-prompt url realm
)
116 (user-real-login-name)))
118 (auth-source-user-or-password "password" server type
)
119 (read-passwd "Password: "))
120 retval
(base64-encode-string (format "%s:%s" user pass
))
121 byserv
(assoc server
(symbol-value url-basic-auth-storage
)))
123 (cons (cons file retval
) (cdr byserv
))))))
124 (t (setq retval nil
)))
125 (if retval
(setq retval
(concat "Basic " retval
)))
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.
135 ;;; This is very secure
136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137 (defvar url-digest-auth-storage nil
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.")
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
)
148 (a1 (md5 (concat username
":" realm
":" password
)))
149 (a2 (md5 (concat method
":" (url-filename info
)))))
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
155 to use for the URL and its descendants. If optional third argument
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."
160 (let* ((href (if (stringp url
)
161 (url-generic-parse-url url
)
163 (server (url-host href
))
164 (type (url-type href
))
165 (port (url-port href
))
166 (file (url-filename href
))
167 user pass byserv retval data
)
170 ((string-match "/$" file
) file
)
171 (t (url-file-directory file
)))
172 server
(format "%s:%d" server port
)
173 byserv
(cdr-safe (assoc server url-digest-auth-storage
)))
175 ((and prompt
(not byserv
))
177 (auth-source-user-or-password "login" server type
)
178 (read-string (url-auth-user-prompt url realm
)
179 (user-real-login-name)))
181 (auth-source-user-or-password "password" server type
)
182 (read-passwd "Password: "))
183 url-digest-auth-storage
188 (url-digest-auth-create-key
190 (or url-request-method
"GET")
192 url-digest-auth-storage
)))
194 (setq retval
(cdr-safe (assoc file byserv
)))
195 (if (and (not retval
) ; no exact match, check directories
196 (string-match "/" file
)) ; not looking for a realm
197 (while (and byserv
(not retval
))
198 (setq data
(car (car byserv
)))
199 (if (or (not (string-match "/" data
))
201 (>= (length file
) (length data
))
202 (string= data
(substring file
0 (length data
)))))
203 (setq retval
(cdr (car byserv
))))
204 (setq byserv
(cdr byserv
))))
206 (if (and (not retval
) prompt
)
208 (auth-source-user-or-password "login" server type
)
209 (read-string (url-auth-user-prompt url realm
)
210 (user-real-login-name)))
212 (auth-source-user-or-password "password" server type
)
213 (read-passwd "Password: "))
216 (url-digest-auth-create-key
218 (or url-request-method
"GET")
220 byserv
(assoc server url-digest-auth-storage
))
222 (cons (cons file retval
) (cdr byserv
))))))
223 (t (setq retval nil
)))
225 (if (cdr-safe (assoc "opaque" args
))
226 (let ((nonce (or (cdr-safe (assoc "nonce" args
)) "nonegiven"))
227 (opaque (cdr-safe (assoc "opaque" args
))))
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")))
237 (concat "Digest username=\"%s\", realm=\"%s\","
238 "nonce=\"%s\", uri=\"%s\","
240 (nth 0 retval
) realm nonce
(url-filename href
)
241 (md5 (concat (nth 1 retval
) ":" nonce
":"
242 (nth 2 retval
))))))))))
244 (defvar url-registered-auth-schemes nil
245 "A list of the registered authorization schemes and various and sundry
246 information associated with them.")
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.
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
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
264 wrong, it's no big deal, the error from the server will specify exactly
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"
269 (setq realm
(cdr-safe (assoc "realm" args
))))
271 (setq url
(url-generic-parse-url url
)))
272 (if (or (null type
) (eq type
'any
))
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
285 (if (fboundp (car (cdr scheme
)))
286 (cons (cdr (cdr scheme
))
287 (funcall (car (cdr scheme
)) url nil nil realm
))
289 url-registered-auth-schemes
)
294 ((and (cdr x
) (null (cdr y
))) t
)
295 ((and (cdr x
) (cdr y
))
296 (>= (car x
) (car y
)))
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
305 (funcall scheme url nil nil realm args
))
309 (defun url-register-auth-scheme (type &optional function rating
)
310 "Register an HTTP authentication method.
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.
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."
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"))))
327 ((stringp rating
) (string-to-number rating
))
329 (node (assoc type url-registered-auth-schemes
)))
330 (if (not (fboundp function
))
333 "Tried to register `%s' as an auth scheme"
334 ", but it is not a function!") function
)))
337 (setcdr node
(cons function rating
))
338 (setq url-registered-auth-schemes
339 (cons (cons type
(cons function rating
))
340 url-registered-auth-schemes
)))))
342 (defun url-auth-registered (scheme)
343 "Return non-nil if SCHEME is registered as an auth type."
344 (assoc scheme url-registered-auth-schemes
))
348 ;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
349 ;;; url-auth.el ends here