Mercurial > emacs
annotate lisp/url/url-auth.el @ 105415:6ae619b44d73
Martin Rudalics <rudalics at gmx.at>
(window-full-height-p): New function. (Bug#4543)
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Sun, 04 Oct 2009 00:40:16 +0000 |
parents | a9dc0e7c3f2b |
children | 1d1d5d9bd884 |
rev | line source |
---|---|
54695 | 1 ;;; url-auth.el --- Uniform Resource Locator authorization modules |
57612 | 2 |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, |
100908 | 4 ;; 2008, 2009 Free Software Foundation, Inc. |
57612 | 5 |
54695 | 6 ;; Keywords: comm, data, processes, hypermedia |
7 | |
57612 | 8 ;; This file is part of GNU Emacs. |
9 | |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
88054
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
57612 | 11 ;; it under the terms of the GNU General Public License as published by |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
88054
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
88054
diff
changeset
|
13 ;; (at your option) any later version. |
57612 | 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 | |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
88054
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
57612 | 22 |
23 ;;; Code: | |
54695 | 24 |
25 (require 'url-vars) | |
26 (require 'url-parse) | |
27 (autoload 'url-warn "url") | |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
28 (autoload 'auth-source-user-or-password "auth-source") |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
29 |
54695 | 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 | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
54 this is an assoc list based on the 'directory' specified by the URL we |
54695 | 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 | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
63 instead of the filename inheritance method." |
54695 | 64 (let* ((href (if (stringp url) |
65 (url-generic-parse-url url) | |
66 url)) | |
67 (server (url-host href)) | |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
68 (type (url-type href)) |
54695 | 69 (port (url-port href)) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
70 (file (url-filename href)) |
78514
364329b928dc
username and password default
Vinicius Jose Latorre <viniciusjl@ig.com.br>
parents:
78481
diff
changeset
|
71 (user (url-user href)) |
364329b928dc
username and password default
Vinicius Jose Latorre <viniciusjl@ig.com.br>
parents:
78481
diff
changeset
|
72 (pass (url-password href)) |
364329b928dc
username and password default
Vinicius Jose Latorre <viniciusjl@ig.com.br>
parents:
78481
diff
changeset
|
73 byserv retval data) |
54695 | 74 (setq server (format "%s:%d" server port) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
75 file (cond |
54695 | 76 (realm realm) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
77 ((string= "" file) "/") |
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
78 ((string-match "/$" file) file) |
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
79 (t (url-file-directory file))) |
54695 | 80 byserv (cdr-safe (assoc server |
81 (symbol-value url-basic-auth-storage)))) | |
82 (cond | |
83 ((and prompt (not byserv)) | |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
84 (setq user (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
85 (auth-source-user-or-password "login" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
86 (read-string (url-auth-user-prompt url realm) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
87 (or user (user-real-login-name)))) |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
88 pass (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
89 (auth-source-user-or-password "password" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
90 (read-passwd "Password: " nil (or pass "")))) |
54695 | 91 (set url-basic-auth-storage |
92 (cons (list server | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
93 (cons file |
54695 | 94 (setq retval |
95 (base64-encode-string | |
98938
1fa392febf9a
(url-basic-auth): Encode password string.
Chong Yidong <cyd@stupidchicken.com>
parents:
96486
diff
changeset
|
96 (format "%s:%s" user |
1fa392febf9a
(url-basic-auth): Encode password string.
Chong Yidong <cyd@stupidchicken.com>
parents:
96486
diff
changeset
|
97 (encode-coding-string pass 'utf-8)))))) |
54695 | 98 (symbol-value url-basic-auth-storage)))) |
99 (byserv | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
100 (setq retval (cdr-safe (assoc file byserv))) |
54695 | 101 (if (and (not retval) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
102 (string-match "/" file)) |
54695 | 103 (while (and byserv (not retval)) |
104 (setq data (car (car byserv))) | |
75519
b271481fb8d2
(url-get-authentication): Fix typo in docstring.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
105 (if (or (not (string-match "/" data)) ; It's a realm - take it! |
54695 | 106 (and |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
107 (>= (length file) (length data)) |
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
108 (string= data (substring file 0 (length data))))) |
54695 | 109 (setq retval (cdr (car byserv)))) |
110 (setq byserv (cdr byserv)))) | |
111 (if (or (and (not retval) prompt) overwrite) | |
112 (progn | |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
113 (setq user (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
114 (auth-source-user-or-password "login" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
115 (read-string (url-auth-user-prompt url realm) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
116 (user-real-login-name))) |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
117 pass (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
118 (auth-source-user-or-password "password" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
119 (read-passwd "Password: ")) |
54695 | 120 retval (base64-encode-string (format "%s:%s" user pass)) |
121 byserv (assoc server (symbol-value url-basic-auth-storage))) | |
122 (setcdr byserv | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
123 (cons (cons file retval) (cdr byserv)))))) |
54695 | 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 | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
138 "Where usernames and passwords are stored. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
139 Its value is an assoc list of assoc lists. The first assoc list is |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
140 keyed by the server name. The cdr of this is an assoc list based |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
141 on the 'directory' specified by the url we are looking up.") |
54695 | 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 | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
155 to use for the URL and its descendants. If optional third argument |
54695 | 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)) | |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
164 (type (url-type href)) |
54695 | 165 (port (url-port href)) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
166 (file (url-filename href)) |
54695 | 167 user pass byserv retval data) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
168 (setq file (cond |
54695 | 169 (realm realm) |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
170 ((string-match "/$" file) file) |
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
171 (t (url-file-directory file))) |
54695 | 172 server (format "%s:%d" server port) |
173 byserv (cdr-safe (assoc server url-digest-auth-storage))) | |
174 (cond | |
175 ((and prompt (not byserv)) | |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
176 (setq user (or |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
177 (auth-source-user-or-password "login" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
178 (read-string (url-auth-user-prompt url realm) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
179 (user-real-login-name))) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
180 pass (or |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
181 (auth-source-user-or-password "password" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
182 (read-passwd "Password: ")) |
54695 | 183 url-digest-auth-storage |
184 (cons (list server | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
185 (cons file |
54695 | 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 | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
194 (setq retval (cdr-safe (assoc file byserv))) |
54695 | 195 (if (and (not retval) ; no exact match, check directories |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
196 (string-match "/" file)) ; not looking for a realm |
54695 | 197 (while (and byserv (not retval)) |
198 (setq data (car (car byserv))) | |
199 (if (or (not (string-match "/" data)) | |
200 (and | |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
201 (>= (length file) (length data)) |
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
202 (string= data (substring file 0 (length data))))) |
54695 | 203 (setq retval (cdr (car byserv)))) |
204 (setq byserv (cdr byserv)))) | |
88054
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
205 (if overwrite |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
206 (if (and (not retval) prompt) |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
207 (setq user (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
208 (auth-source-user-or-password "login" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
209 (read-string (url-auth-user-prompt url realm) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
210 (user-real-login-name))) |
95612
26c59cfcaeff
(auth-source-user-or-password): Remove unnecessary eval-and-compile.
Glenn Morris <rgm@gnu.org>
parents:
94879
diff
changeset
|
211 pass (or |
94879
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
212 (auth-source-user-or-password "password" server type) |
fc66ed3d9938
Add autoload cookie for
Teodor Zlatanov <tzz@lifelogs.com>
parents:
94668
diff
changeset
|
213 (read-passwd "Password: ")) |
88054
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
214 retval (setq retval |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
215 (cons user |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
216 (url-digest-auth-create-key |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
217 user pass realm |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
218 (or url-request-method "GET") |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
219 url))) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
220 byserv (assoc server url-digest-auth-storage)) |
54695 | 221 (setcdr byserv |
79065
de62e8014967
(url-digest-auth, url-basic-auth):
Richard M. Stallman <rms@gnu.org>
parents:
79056
diff
changeset
|
222 (cons (cons file retval) (cdr byserv)))))) |
54695 | 223 (t (setq retval nil))) |
224 (if retval | |
88054
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
225 (if (cdr-safe (assoc "opaque" args)) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
226 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
227 (opaque (cdr-safe (assoc "opaque" args)))) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
228 (format |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
229 (concat "Digest username=\"%s\", realm=\"%s\"," |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
230 "nonce=\"%s\", uri=\"%s\"," |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
231 "response=\"%s\", opaque=\"%s\"") |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
232 (nth 0 retval) realm nonce (url-filename href) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
233 (md5 (concat (nth 1 retval) ":" nonce ":" |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
234 (nth 2 retval))) opaque)) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
235 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
236 (format |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
237 (concat "Digest username=\"%s\", realm=\"%s\"," |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
238 "nonce=\"%s\", uri=\"%s\"," |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
239 "response=\"%s\"") |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
240 (nth 0 retval) realm nonce (url-filename href) |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
241 (md5 (concat (nth 1 retval) ":" nonce ":" |
eae3aec0f807
2008-01-29 John Wiegley <johnw@newartisans.com>
John Wiegley <johnw@newartisans.com>
parents:
87649
diff
changeset
|
242 (nth 2 retval)))))))))) |
54695 | 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 | |
75519
b271481fb8d2
(url-get-authentication): Fix typo in docstring.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
264 wrong, it's no big deal, the error from the server will specify exactly |
54695 | 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 | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
312 TYPE is a string or symbol specifying the name of the method. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
313 This should be the same thing you expect to get returned in |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
314 an Authenticate header in HTTP/1.0 - it will be downcased. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
315 FUNCTION is the function to call to get the authorization information. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
95612
diff
changeset
|
316 This defaults to `url-?-auth', where ? is TYPE. |
54695 | 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) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
57612
diff
changeset
|
327 ((stringp rating) (string-to-number rating)) |
54695 | 328 (t rating))) |
329 (node (assoc type url-registered-auth-schemes))) | |
330 (if (not (fboundp function)) | |
331 (url-warn 'security | |
54792
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
332 (format (concat |
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
333 "Tried to register `%s' as an auth scheme" |
369ef3f04d8e
(url-register-auth-scheme): Fix `format' call.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
334 ", but it is not a function!") function))) |
54695 | 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) | |
78481
bc53aa750f3b
Replace `iff' in doc-strings and comments.
Glenn Morris <rgm@gnu.org>
parents:
78222
diff
changeset
|
343 "Return non-nil if SCHEME is registered as an auth type." |
54695 | 344 (assoc scheme url-registered-auth-schemes)) |
345 | |
346 (provide 'url-auth) | |
54699 | 347 |
84378 | 348 ;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91 |
57612 | 349 ;;; url-auth.el ends here |