54695
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
2 ;; Keywords: comm, data, processes, hypermedia
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
3
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
5 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
6 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
7 ;;; This file is part of GNU Emacs.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
8 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
9 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
10 ;;; it under the terms of the GNU General Public License as published by
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
11 ;;; the Free Software Foundation; either version 2, or (at your option)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
12 ;;; any later version.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
13 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
14 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
17 ;;; GNU General Public License for more details.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
18 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
19 ;;; You should have received a copy of the GNU General Public License
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
20 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
22 ;;; Boston, MA 02111-1307, USA.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
24
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
25 (require 'url-vars)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
26 (require 'url-parse)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
27 (autoload 'url-warn "url")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
28
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
29 (defsubst url-auth-user-prompt (url realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
30 "String to usefully prompt for a username."
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
31 (concat "Username [for "
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
32 (or realm (url-truncate-url-for-viewing
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
33 (url-recreate-url url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
34 (- (window-width) 10 20)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
35 "]: "))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
36
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
38 ;;; Basic authorization code
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
39 ;;; ------------------------
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
40 ;;; This implements the BASIC authorization type. See the online
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
41 ;;; documentation at
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
42 ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
43 ;;; for the complete documentation on this type.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
44 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
45 ;;; This is very insecure, but it works as a proof-of-concept
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
47 (defvar url-basic-auth-storage 'url-http-real-basic-auth-storage
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
48 "Where usernames and passwords are stored.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
49
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
50 Must be a symbol pointing to another variable that will actually store
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
51 the information. The value of this variable is an assoc list of assoc
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
52 lists. The first assoc list is keyed by the server name. The cdr of
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
53 this is an assoc list based on the 'directory' specified by the url we
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
54 are looking up.")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
55
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
56 (defun url-basic-auth (url &optional prompt overwrite realm args)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
57 "Get the username/password for the specified URL.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
58 If optional argument PROMPT is non-nil, ask for the username/password
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
59 to use for the url and its descendants. If optional third argument
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
60 OVERWRITE is non-nil, overwrite the old username/password pair if it
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
61 is found in the assoc list. If REALM is specified, use that as the realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
62 instead of the pathname inheritance method."
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
63 (let* ((href (if (stringp url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
64 (url-generic-parse-url url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
65 url))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
66 (server (url-host href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
67 (port (url-port href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
68 (path (url-filename href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
69 user pass byserv retval data)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
70 (setq server (format "%s:%d" server port)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
71 path (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
72 (realm realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
73 ((string-match "/$" path) path)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
74 (t (url-basepath path)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
75 byserv (cdr-safe (assoc server
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
76 (symbol-value url-basic-auth-storage))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
77 (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
78 ((and prompt (not byserv))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
79 (setq user (read-string (url-auth-user-prompt url realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
80 (user-real-login-name))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
81 pass (funcall url-passwd-entry-func "Password: "))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
82 (set url-basic-auth-storage
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
83 (cons (list server
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
84 (cons path
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
85 (setq retval
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
86 (base64-encode-string
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
87 (format "%s:%s" user pass)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
88 (symbol-value url-basic-auth-storage))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
89 (byserv
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
90 (setq retval (cdr-safe (assoc path byserv)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
91 (if (and (not retval)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
92 (string-match "/" path))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
93 (while (and byserv (not retval))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
94 (setq data (car (car byserv)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
95 (if (or (not (string-match "/" data)) ; Its a realm - take it!
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
96 (and
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
97 (>= (length path) (length data))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
98 (string= data (substring path 0 (length data)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
99 (setq retval (cdr (car byserv))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
100 (setq byserv (cdr byserv))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
101 (if (or (and (not retval) prompt) overwrite)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
102 (progn
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
103 (setq user (read-string (url-auth-user-prompt url realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
104 (user-real-login-name))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
105 pass (funcall url-passwd-entry-func "Password: ")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
106 retval (base64-encode-string (format "%s:%s" user pass))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
107 byserv (assoc server (symbol-value url-basic-auth-storage)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
108 (setcdr byserv
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
109 (cons (cons path retval) (cdr byserv))))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
110 (t (setq retval nil)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
111 (if retval (setq retval (concat "Basic " retval)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
112 retval))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
113
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
115 ;;; Digest authorization code
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
116 ;;; ------------------------
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
117 ;;; This implements the DIGEST authorization type. See the internet draft
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
118 ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
119 ;;; for the complete documentation on this type.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
120 ;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
121 ;;; This is very secure
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
123 (defvar url-digest-auth-storage nil
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
124 "Where usernames and passwords are stored. Its value is an assoc list of
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
125 assoc lists. The first assoc list is keyed by the server name. The cdr of
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
126 this is an assoc list based on the 'directory' specified by the url we are
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
127 looking up.")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
128
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
129 (defun url-digest-auth-create-key (username password realm method uri)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
130 "Create a key for digest authentication method"
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
131 (let* ((info (if (stringp uri)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
132 (url-generic-parse-url uri)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
133 uri))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
134 (a1 (md5 (concat username ":" realm ":" password)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
135 (a2 (md5 (concat method ":" (url-filename info)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
136 (list a1 a2)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
137
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
138 (defun url-digest-auth (url &optional prompt overwrite realm args)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
139 "Get the username/password for the specified URL.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
140 If optional argument PROMPT is non-nil, ask for the username/password
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
141 to use for the url and its descendants. If optional third argument
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
142 OVERWRITE is non-nil, overwrite the old username/password pair if it
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
143 is found in the assoc list. If REALM is specified, use that as the realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
144 instead of hostname:portnum."
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
145 (if args
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
146 (let* ((href (if (stringp url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
147 (url-generic-parse-url url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
148 url))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
149 (server (url-host href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
150 (port (url-port href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
151 (path (url-filename href))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
152 user pass byserv retval data)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
153 (setq path (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
154 (realm realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
155 ((string-match "/$" path) path)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
156 (t (url-basepath path)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
157 server (format "%s:%d" server port)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
158 byserv (cdr-safe (assoc server url-digest-auth-storage)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
159 (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
160 ((and prompt (not byserv))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
161 (setq user (read-string (url-auth-user-prompt url realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
162 (user-real-login-name))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
163 pass (funcall url-passwd-entry-func "Password: ")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
164 url-digest-auth-storage
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
165 (cons (list server
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
166 (cons path
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
167 (setq retval
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
168 (cons user
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
169 (url-digest-auth-create-key
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
170 user pass realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
171 (or url-request-method "GET")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
172 url)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
173 url-digest-auth-storage)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
174 (byserv
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
175 (setq retval (cdr-safe (assoc path byserv)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
176 (if (and (not retval) ; no exact match, check directories
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
177 (string-match "/" path)) ; not looking for a realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
178 (while (and byserv (not retval))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
179 (setq data (car (car byserv)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
180 (if (or (not (string-match "/" data))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
181 (and
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
182 (>= (length path) (length data))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
183 (string= data (substring path 0 (length data)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
184 (setq retval (cdr (car byserv))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
185 (setq byserv (cdr byserv))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
186 (if (or (and (not retval) prompt) overwrite)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
187 (progn
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
188 (setq user (read-string (url-auth-user-prompt url realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
189 (user-real-login-name))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
190 pass (funcall url-passwd-entry-func "Password: ")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
191 retval (setq retval
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
192 (cons user
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
193 (url-digest-auth-create-key
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
194 user pass realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
195 (or url-request-method "GET")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
196 url)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
197 byserv (assoc server url-digest-auth-storage))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
198 (setcdr byserv
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
199 (cons (cons path retval) (cdr byserv))))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
200 (t (setq retval nil)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
201 (if retval
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
202 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
203 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
204 (format
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
205 (concat "Digest username=\"%s\", realm=\"%s\","
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
206 "nonce=\"%s\", uri=\"%s\","
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
207 "response=\"%s\", opaque=\"%s\"")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
208 (nth 0 retval) realm nonce (url-filename href)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
209 (md5 (concat (nth 1 retval) ":" nonce ":"
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
210 (nth 2 retval))) opaque))))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
211
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
212 (defvar url-registered-auth-schemes nil
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
213 "A list of the registered authorization schemes and various and sundry
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
214 information associated with them.")
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
215
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
216 ;;;###autoload
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
217 (defun url-get-authentication (url realm type prompt &optional args)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
218 "Return an authorization string suitable for use in the WWW-Authenticate
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
219 header in an HTTP/1.0 request.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
220
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
221 URL is the url you are requesting authorization to. This can be either a
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
222 string representing the URL, or the parsed representation returned by
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
223 `url-generic-parse-url'
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
224 REALM is the realm at a specific site we are looking for. This should be a
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
225 string specifying the exact realm, or nil or the symbol 'any' to
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
226 specify that the filename portion of the URL should be used as the
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
227 realm
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
228 TYPE is the type of authentication to be returned. This is either a string
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
229 representing the type (basic, digest, etc), or nil or the symbol 'any'
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
230 to specify that any authentication is acceptable. If requesting 'any'
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
231 the strongest matching authentication will be returned. If this is
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
232 wrong, its no big deal, the error from the server will specify exactly
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
233 what type of auth to use
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
234 PROMPT is boolean - specifies whether to ask the user for a username/password
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
235 if one cannot be found in the cache"
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
236 (if (not realm)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
237 (setq realm (cdr-safe (assoc "realm" args))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
238 (if (stringp url)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
239 (setq url (url-generic-parse-url url)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
240 (if (or (null type) (eq type 'any))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
241 ;; Whooo doogies!
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
242 ;; Go through and get _all_ the authorization strings that could apply
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
243 ;; to this URL, store them along with the 'rating' we have in the list
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
244 ;; of schemes, then sort them so that the 'best' is at the front of the
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
245 ;; list, then get the car, then get the cdr.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
246 ;; Zooom zooom zoooooom
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
247 (cdr-safe
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
248 (car-safe
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
249 (sort
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
250 (mapcar
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
251 (function
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
252 (lambda (scheme)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
253 (if (fboundp (car (cdr scheme)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
254 (cons (cdr (cdr scheme))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
255 (funcall (car (cdr scheme)) url nil nil realm))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
256 (cons 0 nil))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
257 url-registered-auth-schemes)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
258 (function
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
259 (lambda (x y)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
260 (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
261 ((null (cdr x)) nil)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
262 ((and (cdr x) (null (cdr y))) t)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
263 ((and (cdr x) (cdr y))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
264 (>= (car x) (car y)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
265 (t nil)))))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
266 (if (symbolp type) (setq type (symbol-name type)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
267 (let* ((scheme (car-safe
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
268 (cdr-safe (assoc (downcase type)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
269 url-registered-auth-schemes)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
270 (if (and scheme (fboundp scheme))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
271 (funcall scheme url prompt
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
272 (and prompt
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
273 (funcall scheme url nil nil realm args))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
274 realm args)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
275
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
276 ;;;###autoload
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
277 (defun url-register-auth-scheme (type &optional function rating)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
278 "Register an HTTP authentication method.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
279
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
280 TYPE is a string or symbol specifying the name of the method. This
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
281 should be the same thing you expect to get returned in an Authenticate
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
282 header in HTTP/1.0 - it will be downcased.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
283 FUNCTION is the function to call to get the authorization information. This
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
284 defaults to `url-?-auth', where ? is TYPE
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
285 RATING a rating between 1 and 10 of the strength of the authentication.
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
286 This is used when asking for the best authentication for a specific
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
287 URL. The item with the highest rating is returned."
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
288 (let* ((type (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
289 ((stringp type) (downcase type))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
290 ((symbolp type) (downcase (symbol-name type)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
291 (t (error "Bad call to `url-register-auth-scheme'"))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
292 (function (or function (intern (concat "url-" type "-auth"))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
293 (rating (cond
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
294 ((null rating) 2)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
295 ((stringp rating) (string-to-int rating))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
296 (t rating)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
297 (node (assoc type url-registered-auth-schemes)))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
298 (if (not (fboundp function))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
299 (url-warn 'security
|
54792
|
300 (format (concat
|
|
301 "Tried to register `%s' as an auth scheme"
|
|
302 ", but it is not a function!") function)))
|
54695
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
303
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
304 (if node
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
305 (setcdr node (cons function rating))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
306 (setq url-registered-auth-schemes
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
307 (cons (cons type (cons function rating))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
308 url-registered-auth-schemes)))))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
309
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
310 (defun url-auth-registered (scheme)
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
311 ;; Return non-nil iff SCHEME is registered as an auth type
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
312 (assoc scheme url-registered-auth-schemes))
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
313
|
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
diff
changeset
|
314 (provide 'url-auth)
|
54699
|
315
|
|
316 ;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
|