--- a/lisp/w3/urlauth.el	Mon Aug 13 09:06:45 2007 +0200
+++ b/lisp/w3/urlauth.el	Mon Aug 13 09:07:36 2007 +0200
@@ -1,303 +0,0 @@
-;;; urlauth.el --- Uniform Resource Locator authorization modules
-;; Author: wmperry
-;; Created: 1996/10/09 19:00:59
-;; Version: 1.2
-;; Keywords: comm, data, processes, hypermedia
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
-;;; Copyright (c) 1996 Free Software Foundation, Inc.
-;;;
-;;; This file is not part of GNU Emacs, but the same permissions apply.
-;;;
-;;; GNU Emacs is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2, or (at your option)
-;;; any later version.
-;;;
-;;; GNU Emacs is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307, USA.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(require 'url-vars)
-(require 'url-parse)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Basic authorization code
-;;; ------------------------
-;;; This implements the BASIC authorization type.  See the online
-;;; documentation at
-;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
-;;; for the complete documentation on this type.
-;;;
-;;; This is very insecure, but it works as a proof-of-concept
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar url-basic-auth-storage nil
-  "Where usernames and passwords are stored.  Its value is an assoc list of
-assoc lists.  The first assoc list is keyed by the server name.  The cdr of
-this is an assoc list based on the 'directory' specified by the url we are
-looking up.")
-
-(defun url-basic-auth (url &optional prompt overwrite realm args)
-  "Get the username/password for the specified URL.
-If optional argument PROMPT is non-nil, ask for the username/password
-to use for the url and its descendants.  If optional third argument
-OVERWRITE is non-nil, overwrite the old username/password pair if it
-is found in the assoc list.  If REALM is specified, use that as the realm
-instead of the pathname inheritance method."
-  (let* ((href (if (stringp url)
-		   (url-generic-parse-url url)
-		 url))
-	 (server (or (url-host href) url-current-server))
-	 (port (or (url-port href) "80"))
-	 (path (url-filename href))
-	 user pass byserv retval data)
-    (setq server (concat server ":" port)
-	  path (cond
-		(realm realm)
-		((string-match "/$" path) path)
-		(t (url-basepath path)))
-	  byserv (cdr-safe (assoc server url-basic-auth-storage)))
-    (cond
-     ((and prompt (not byserv))
-      (setq user (read-string "Username: " (user-real-login-name))
-	    pass (funcall url-passwd-entry-func "Password: ")
-	    url-basic-auth-storage
-	    (cons (list server
-			(cons path
-			      (setq retval
-				    (base64-encode
-				     (format "%s:%s" user pass)))))
-		  url-basic-auth-storage)))
-     (byserv
-      (setq retval (cdr-safe (assoc path byserv)))
-      (if (and (not retval)
-	       (string-match "/" path))
- 	  (while (and byserv (not retval))
-	    (setq data (car (car byserv)))
-	    (if (or (not (string-match "/" data)) ; Its a realm - take it!
-		    (and
-		     (>= (length path) (length data))
-		     (string= data (substring path 0 (length data)))))
-		(setq retval (cdr (car byserv))))
-	    (setq byserv (cdr byserv))))
-      (if (or (and (not retval) prompt) overwrite)
-	  (progn
-	    (setq user (read-string "Username: " (user-real-login-name))
-		  pass (funcall url-passwd-entry-func "Password: ")
-		  retval (base64-encode (format "%s:%s" user pass))
-		  byserv (assoc server url-basic-auth-storage))
-	    (setcdr byserv
-		    (cons (cons path retval) (cdr byserv))))))
-     (t (setq retval nil)))
-    (if retval (setq retval (concat "Basic " retval)))
-    retval))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Digest authorization code
-;;; ------------------------
-;;; This implements the DIGEST authorization type.  See the internet draft
-;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
-;;; for the complete documentation on this type.
-;;;
-;;; This is very secure
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar url-digest-auth-storage nil
-  "Where usernames and passwords are stored.  Its value is an assoc list of
-assoc lists.  The first assoc list is keyed by the server name.  The cdr of
-this is an assoc list based on the 'directory' specified by the url we are
-looking up.")
-
-(defun url-digest-auth-create-key (username password realm method uri)
-  "Create a key for digest authentication method"
-  (let* ((info (if (stringp uri)
-		   (url-generic-parse-url uri)
-		 uri))
-	 (a1 (md5 (concat username ":" realm ":" password)))
-	 (a2 (md5 (concat method ":" (url-filename info)))))
-    (list a1 a2)))
-
-(defun url-digest-auth (url &optional prompt overwrite realm args)
-  "Get the username/password for the specified URL.
-If optional argument PROMPT is non-nil, ask for the username/password
-to use for the url and its descendants.  If optional third argument
-OVERWRITE is non-nil, overwrite the old username/password pair if it
-is found in the assoc list.  If REALM is specified, use that as the realm
-instead of hostname:portnum."
-  (if args
-      (let* ((href (if (stringp url)
-		       (url-generic-parse-url url)
-		     url))
-	     (server (or (url-host href) url-current-server))
-	     (port (or (url-port href) "80"))
-	     (path (url-filename href))
-	     user pass byserv retval data)
-	(setq path (cond
-		    (realm realm)
-		    ((string-match "/$" path) path)
-		    (t (url-basepath path)))
-	      server (concat server ":" port)
-	      byserv (cdr-safe (assoc server url-digest-auth-storage)))
-	(cond
-	 ((and prompt (not byserv))
-	  (setq user (read-string "Username: " (user-real-login-name))
-		pass (funcall url-passwd-entry-func "Password: ")
-		url-digest-auth-storage
-		(cons (list server
-			    (cons path
-				  (setq retval
-					(cons user
-					      (url-digest-auth-create-key
-					       user pass realm
-					       (or url-request-method "GET")
-					       url)))))
-		      url-digest-auth-storage)))
-	 (byserv
-	  (setq retval (cdr-safe (assoc path byserv)))
-	  (if (and (not retval)		; no exact match, check directories
-		   (string-match "/" path)) ; not looking for a realm
-	      (while (and byserv (not retval))
-		(setq data (car (car byserv)))
-		(if (or (not (string-match "/" data))
-			(and
-			 (>= (length path) (length data))
-			 (string= data (substring path 0 (length data)))))
-		    (setq retval (cdr (car byserv))))
-		(setq byserv (cdr byserv))))
-	  (if (or (and (not retval) prompt) overwrite)
-	      (progn
-		(setq user (read-string "Username: " (user-real-login-name))
-		      pass (funcall url-passwd-entry-func "Password: ")
-		      retval (setq retval
-				   (cons user
-					 (url-digest-auth-create-key
-					  user pass realm
-					  (or url-request-method "GET")
-					  url)))
-		      byserv (assoc server url-digest-auth-storage))
-		(setcdr byserv
-			(cons (cons path retval) (cdr byserv))))))
-	 (t (setq retval nil)))
-	(if retval
-	    (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
-		  (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
-	      (format
-	       (concat "Digest username=\"%s\", realm=\"%s\","
-		       "nonce=\"%s\", uri=\"%s\","
-		       "response=\"%s\", opaque=\"%s\"")
-	       (nth 0 retval) realm nonce (url-filename href)
-	       (md5 (concat (nth 1 retval) ":" nonce ":"
-			    (nth 2 retval))) opaque))))))
-
-(defvar url-registered-auth-schemes nil
-  "A list of the registered authorization schemes and various and sundry
-information associated with them.")
-
-(defun url-get-authentication (url realm type prompt &optional args)
-  "Return an authorization string suitable for use in the WWW-Authenticate
-header in an HTTP/1.0 request.
-
-URL    is the url you are requesting authorization to.  This can be either a
-       string representing the URL, or the parsed representation returned by
-       `url-generic-parse-url'
-REALM  is the realm at a specific site we are looking for.  This should be a
-       string specifying the exact realm, or nil or the symbol 'any' to
-       specify that the filename portion of the URL should be used as the
-       realm
-TYPE   is the type of authentication to be returned.  This is either a string
-       representing the type (basic, digest, etc), or nil or the symbol 'any'
-       to specify that any authentication is acceptable.  If requesting 'any'
-       the strongest matching authentication will be returned.  If this is
-       wrong, its no big deal, the error from the server will specify exactly
-       what type of auth to use
-PROMPT is boolean - specifies whether to ask the user for a username/password
-       if one cannot be found in the cache"
-  (if (not realm)
-      (setq realm (cdr-safe (assoc "realm" args))))
-  (if (stringp url)
-      (setq url (url-generic-parse-url url)))
-  (if (or (null type) (eq type 'any))
-      ;; Whooo doogies!
-      ;; Go through and get _all_ the authorization strings that could apply
-      ;; to this URL, store them along with the 'rating' we have in the list
-      ;; of schemes, then sort them so that the 'best' is at the front of the
-      ;; list, then get the car, then get the cdr.
-      ;; Zooom zooom zoooooom
-      (cdr-safe
-       (car-safe
-	(sort
-	 (mapcar
-	  (function
-	   (lambda (scheme)
-	     (if (fboundp (car (cdr scheme)))
-		 (cons (cdr (cdr scheme))
-		       (funcall (car (cdr scheme)) url nil nil realm))
-	       (cons 0 nil))))
-	  url-registered-auth-schemes)
-	 (function
-	  (lambda (x y)
-	    (cond
-	     ((null (cdr x)) nil)
-	     ((and (cdr x) (null (cdr y))) t)
-	     ((and (cdr x) (cdr y))
-	      (>= (car x) (car y)))
-	     (t nil)))))))
-    (if (symbolp type) (setq type (symbol-name type)))
-    (let* ((scheme (car-safe
-		    (cdr-safe (assoc (downcase type)
-				     url-registered-auth-schemes)))))
-      (if (and scheme (fboundp scheme))
-	  (funcall scheme url prompt
-		   (and prompt
-			(funcall scheme url nil nil realm args))
-		   realm args)))))
-
-(defun url-register-auth-scheme (type &optional function rating)
-  "Register an HTTP authentication method.
-
-TYPE     is a string or symbol specifying the name of the method.   This
-         should be the same thing you expect to get returned in an Authenticate
-         header in HTTP/1.0 - it will be downcased.
-FUNCTION is the function to call to get the authorization information.  This
-         defaults to `url-?-auth', where ? is TYPE
-RATING   a rating between 1 and 10 of the strength of the authentication.
-         This is used when asking for the best authentication for a specific
-         URL.  The item with the highest rating is returned."
-  (let* ((type (cond
-		((stringp type) (downcase type))
-		((symbolp type) (downcase (symbol-name type)))
-		(t (error "Bad call to `url-register-auth-scheme'"))))
-	 (function (or function (intern (concat "url-" type "-auth"))))
-	 (rating (cond
-		  ((null rating) 2)
-		  ((stringp rating) (string-to-int rating))
-		  (t rating)))
-	 (node (assoc type url-registered-auth-schemes)))
-    (if (not (fboundp function))
-	(url-warn 'security
-		  (format (eval-when-compile
-			    "Tried to register `%s' as an auth scheme"
-			    ", but it is not a function!") function)))
-
-    (if node
-	(progn
-	  (setcdr node (cons function rating))
-	  (url-warn 'security
-		    (format
-		     "Replacing authorization method `%s' - this could be bad."
-		     type)))
-      (setq url-registered-auth-schemes
-	    (cons (cons type (cons function rating))
-		  url-registered-auth-schemes)))))
-
-(defun url-auth-registered (scheme)
-  ;; Return non-nil iff SCHEME is registered as an auth type
-  (assoc scheme url-registered-auth-schemes))
-
-(provide 'urlauth)