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