Be more tolerant to fonts named "Foobar-12"
[emacs.git] / lisp / url / url-auth.el
blob58bf45b022648fb3fc1380e76e3fae21f80a62dd
1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
3 ;; Copyright (C) 1996-1999, 2004-2015 Free Software Foundation, Inc.
5 ;; Keywords: comm, data, processes, hypermedia
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 ;;; Code:
24 (require 'url-vars)
25 (require 'url-parse)
26 (autoload 'url-warn "url")
27 (autoload 'auth-source-search "auth-source")
29 (defsubst url-auth-user-prompt (url realm)
30 "String to usefully prompt for a username."
31 (concat "Username [for "
32 (or realm (url-truncate-url-for-viewing
33 (url-recreate-url url)
34 (- (window-width) 10 20)))
35 "]: "))
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 ;;; Basic authorization code
39 ;;; ------------------------
40 ;;; This implements the BASIC authorization type. See the online
41 ;;; documentation at
42 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
43 ;;; for the complete documentation on this type.
44 ;;;
45 ;;; This is very insecure, but it works as a proof-of-concept
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 (defvar url-basic-auth-storage 'url-http-real-basic-auth-storage
48 "Where usernames and passwords are stored.
50 Must be a symbol pointing to another variable that will actually store
51 the information. The value of this variable is an assoc list of assoc
52 lists. The first assoc list is keyed by the server name. The cdr of
53 this is an assoc list based on the 'directory' specified by the URL we
54 are looking up.")
56 (defun url-basic-auth (url &optional prompt overwrite realm args)
57 "Get the username/password for the specified URL.
58 If optional argument PROMPT is non-nil, ask for the username/password
59 to use for the url and its descendants. If optional third argument
60 OVERWRITE is non-nil, overwrite the old username/password pair if it
61 is found in the assoc list. If REALM is specified, use that as the realm
62 instead of the filename inheritance method."
63 (let* ((href (if (stringp url)
64 (url-generic-parse-url url)
65 url))
66 (server (url-host href))
67 (type (url-type href))
68 (port (url-port href))
69 (file (url-filename href))
70 (user (url-user href))
71 (pass (url-password href))
72 (enable-recursive-minibuffers t) ; for url-handler-mode (bug#10298)
73 byserv retval data)
74 (setq server (format "%s:%d" server port)
75 file (cond
76 (realm realm)
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))))
82 (cond
83 ((and prompt (not byserv))
84 (setq user (or
85 (url-do-auth-source-search server type :user)
86 (read-string (url-auth-user-prompt url realm)
87 (or user (user-real-login-name))))
88 pass (or
89 (url-do-auth-source-search server type :secret)
90 (read-passwd "Password: " nil (or pass ""))))
91 (set url-basic-auth-storage
92 (cons (list server
93 (cons file
94 (setq retval
95 (base64-encode-string
96 (format "%s:%s" user
97 (encode-coding-string pass 'utf-8))))))
98 (symbol-value url-basic-auth-storage))))
99 (byserv
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!
106 (and
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)
112 (progn
113 (setq user (or
114 (url-do-auth-source-search server type :user)
115 (read-string (url-auth-user-prompt url realm)
116 (user-real-login-name)))
117 pass (or
118 (url-do-auth-source-search server type :secret)
119 (read-passwd "Password: "))
120 retval (base64-encode-string (format "%s:%s" user pass))
121 byserv (assoc server (symbol-value url-basic-auth-storage)))
122 (setcdr byserv
123 (cons (cons file retval) (cdr byserv))))))
124 (t (setq retval nil)))
125 (if retval (setq retval (concat "Basic " retval)))
126 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)
147 uri))
148 (a1 (md5 (concat username ":" realm ":" password)))
149 (a2 (md5 (concat method ":" (url-filename info)))))
150 (list a1 a2)))
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."
159 (if args
160 (let* ((href (if (stringp url)
161 (url-generic-parse-url url)
162 url))
163 (server (url-host href))
164 (type (url-type href))
165 (port (url-port href))
166 (file (url-filename href))
167 (enable-recursive-minibuffers t)
168 user pass byserv retval data)
169 (setq file (cond
170 (realm realm)
171 ((string-match "/$" file) file)
172 (t (url-file-directory file)))
173 server (format "%s:%d" server port)
174 byserv (cdr-safe (assoc server url-digest-auth-storage)))
175 (cond
176 ((and prompt (not byserv))
177 (setq user (or
178 (url-do-auth-source-search server type :user)
179 (read-string (url-auth-user-prompt url realm)
180 (user-real-login-name)))
181 pass (or
182 (url-do-auth-source-search server type :secret)
183 (read-passwd "Password: "))
184 url-digest-auth-storage
185 (cons (list server
186 (cons file
187 (setq retval
188 (cons user
189 (url-digest-auth-create-key
190 user pass realm
191 (or url-request-method "GET")
192 url)))))
193 url-digest-auth-storage)))
194 (byserv
195 (setq retval (cdr-safe (assoc file byserv)))
196 (if (and (not retval) ; no exact match, check directories
197 (string-match "/" file)) ; not looking for a realm
198 (while (and byserv (not retval))
199 (setq data (car (car byserv)))
200 (if (or (not (string-match "/" data))
201 (and
202 (>= (length file) (length data))
203 (string= data (substring file 0 (length data)))))
204 (setq retval (cdr (car byserv))))
205 (setq byserv (cdr byserv))))
206 (if overwrite
207 (if (and (not retval) prompt)
208 (setq user (or
209 (url-do-auth-source-search server type :user)
210 (read-string (url-auth-user-prompt url realm)
211 (user-real-login-name)))
212 pass (or
213 (url-do-auth-source-search server type :secret)
214 (read-passwd "Password: "))
215 retval (setq retval
216 (cons user
217 (url-digest-auth-create-key
218 user pass realm
219 (or url-request-method "GET")
220 url)))
221 byserv (assoc server url-digest-auth-storage))
222 (setcdr byserv
223 (cons (cons file retval) (cdr byserv))))))
224 (t (setq retval nil)))
225 (if retval
226 (if (cdr-safe (assoc "opaque" args))
227 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
228 (opaque (cdr-safe (assoc "opaque" args))))
229 (format
230 (concat "Digest username=\"%s\", realm=\"%s\","
231 "nonce=\"%s\", uri=\"%s\","
232 "response=\"%s\", opaque=\"%s\"")
233 (nth 0 retval) realm nonce (url-filename href)
234 (md5 (concat (nth 1 retval) ":" nonce ":"
235 (nth 2 retval))) opaque))
236 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")))
237 (format
238 (concat "Digest username=\"%s\", realm=\"%s\","
239 "nonce=\"%s\", uri=\"%s\","
240 "response=\"%s\"")
241 (nth 0 retval) realm nonce (url-filename href)
242 (md5 (concat (nth 1 retval) ":" nonce ":"
243 (nth 2 retval))))))))))
245 (defvar url-registered-auth-schemes nil
246 "A list of the registered authorization schemes and various and sundry
247 information associated with them.")
249 (defun url-do-auth-source-search (server type parameter)
250 (let* ((auth-info (auth-source-search :max 1 :host server :port type))
251 (auth-info (nth 0 auth-info))
252 (token (plist-get auth-info parameter))
253 (token (if (functionp token) (funcall token) token)))
254 token))
256 ;;;###autoload
257 (defun url-get-authentication (url realm type prompt &optional args)
258 "Return an authorization string suitable for use in the WWW-Authenticate
259 header in an HTTP/1.0 request.
261 URL is the url you are requesting authorization to. This can be either a
262 string representing the URL, or the parsed representation returned by
263 `url-generic-parse-url'
264 REALM is the realm at a specific site we are looking for. This should be a
265 string specifying the exact realm, or nil or the symbol 'any' to
266 specify that the filename portion of the URL should be used as the
267 realm
268 TYPE is the type of authentication to be returned. This is either a string
269 representing the type (basic, digest, etc), or nil or the symbol 'any'
270 to specify that any authentication is acceptable. If requesting 'any'
271 the strongest matching authentication will be returned. If this is
272 wrong, it's no big deal, the error from the server will specify exactly
273 what type of auth to use
274 PROMPT is boolean - specifies whether to ask the user for a username/password
275 if one cannot be found in the cache"
276 (if (not realm)
277 (setq realm (cdr-safe (assoc "realm" args))))
278 (if (stringp url)
279 (setq url (url-generic-parse-url url)))
280 (if (or (null type) (eq type 'any))
281 ;; Whooo doogies!
282 ;; Go through and get _all_ the authorization strings that could apply
283 ;; to this URL, store them along with the 'rating' we have in the list
284 ;; of schemes, then sort them so that the 'best' is at the front of the
285 ;; list, then get the car, then get the cdr.
286 ;; Zooom zooom zoooooom
287 (cdr-safe
288 (car-safe
289 (sort
290 (mapcar
291 (function
292 (lambda (scheme)
293 (if (fboundp (car (cdr scheme)))
294 (cons (cdr (cdr scheme))
295 (funcall (car (cdr scheme)) url nil nil realm))
296 (cons 0 nil))))
297 url-registered-auth-schemes)
298 (function
299 (lambda (x y)
300 (cond
301 ((null (cdr x)) nil)
302 ((and (cdr x) (null (cdr y))) t)
303 ((and (cdr x) (cdr y))
304 (>= (car x) (car y)))
305 (t nil)))))))
306 (if (symbolp type) (setq type (symbol-name type)))
307 (let* ((scheme (car-safe
308 (cdr-safe (assoc (downcase type)
309 url-registered-auth-schemes)))))
310 (if (and scheme (fboundp scheme))
311 (funcall scheme url prompt
312 (and prompt
313 (funcall scheme url nil nil realm args))
314 realm args)))))
316 ;;;###autoload
317 (defun url-register-auth-scheme (type &optional function rating)
318 "Register an HTTP authentication method.
320 TYPE is a string or symbol specifying the name of the method.
321 This should be the same thing you expect to get returned in
322 an Authenticate header in HTTP/1.0 - it will be downcased.
323 FUNCTION is the function to call to get the authorization information.
324 This defaults to `url-?-auth', where ? is TYPE.
325 RATING a rating between 1 and 10 of the strength of the authentication.
326 This is used when asking for the best authentication for a specific
327 URL. The item with the highest rating is returned."
328 (let* ((type (cond
329 ((stringp type) (downcase type))
330 ((symbolp type) (downcase (symbol-name type)))
331 (t (error "Bad call to `url-register-auth-scheme'"))))
332 (function (or function (intern (concat "url-" type "-auth"))))
333 (rating (cond
334 ((null rating) 2)
335 ((stringp rating) (string-to-number rating))
336 (t rating)))
337 (node (assoc type url-registered-auth-schemes)))
338 (if (not (fboundp function))
339 (url-warn 'security
340 (format (concat
341 "Tried to register `%s' as an auth scheme"
342 ", but it is not a function!") function)))
344 (if node
345 (setcdr node (cons function rating))
346 (setq url-registered-auth-schemes
347 (cons (cons type (cons function rating))
348 url-registered-auth-schemes)))))
350 (defun url-auth-registered (scheme)
351 "Return non-nil if SCHEME is registered as an auth type."
352 (assoc scheme url-registered-auth-schemes))
354 (provide 'url-auth)
356 ;;; url-auth.el ends here