[bpt/emacs.git] / lisp / url / url-auth.el

;;; url-auth.el --- Uniform Resource Locator authorization modules

;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.

;; Keywords: comm, data, processes, hypermedia

;; This file is part of GNU Emacs.

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'url-vars)
(require 'url-parse)
(autoload 'url-warn "url")

(defsubst url-auth-user-prompt (url realm)
  "String to usefully prompt for a username."
  (concat "Username [for "
	  (or realm (url-truncate-url-for-viewing
		     (url-recreate-url url)
		     (- (window-width) 10 20)))
	  "]: "))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 'url-http-real-basic-auth-storage
  "Where usernames and passwords are stored.

Must be a symbol pointing to another variable that will actually store
the information.  The value of this variable 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 (url-host href))
	 (port (url-port href))
	 (path (url-filename href))
	 user pass byserv retval data)
    (setq server (format "%s:%d" server port)
	  path (cond
		(realm realm)
		((string-match "/$" path) path)
		(t (url-basepath path)))
	  byserv (cdr-safe (assoc server
				  (symbol-value url-basic-auth-storage))))
    (cond
     ((and prompt (not byserv))
      (setq user (read-string (url-auth-user-prompt url realm)
			      (user-real-login-name))
	    pass (read-passwd "Password: "))
      (set url-basic-auth-storage
	   (cons (list server
		       (cons path
			     (setq retval
				   (base64-encode-string
				    (format "%s:%s" user pass)))))
		 (symbol-value 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 (url-auth-user-prompt url realm)
				    (user-real-login-name))
		  pass (read-passwd "Password: ")
		  retval (base64-encode-string (format "%s:%s" user pass))
		  byserv (assoc server (symbol-value 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 (url-host href))
	     (port (url-port href))
	     (path (url-filename href))
	     user pass byserv retval data)
	(setq path (cond
		    (realm realm)
		    ((string-match "/$" path) path)
		    (t (url-basepath path)))
	      server (format "%s:%d" server port)
	      byserv (cdr-safe (assoc server url-digest-auth-storage)))
	(cond
	 ((and prompt (not byserv))
	  (setq user (read-string (url-auth-user-prompt url realm)
				  (user-real-login-name))
		pass (read-passwd "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 (url-auth-user-prompt url realm)
					(user-real-login-name))
		      pass (read-passwd "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.")

;;;###autoload
(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)))))

;;;###autoload
(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-number rating))
		  (t rating)))
	 (node (assoc type url-registered-auth-schemes)))
    (if (not (fboundp function))
	(url-warn 'security
		  (format (concat
			   "Tried to register `%s' as an auth scheme"
			   ", but it is not a function!") function)))

    (if node
	(setcdr node (cons function rating))
      (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 'url-auth)

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