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

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

;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
;;   2005, 2006, 2007, 2008 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 3, 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 filename inheritance method."
  (let* ((href (if (stringp url)
		   (url-generic-parse-url url)
		 url))
	 (server (url-host href))
	 (port (url-port href))
	 (file (url-filename href))
	 (user (url-user href))
	 (pass (url-password href))
	 byserv retval data)
    (setq server (format "%s:%d" server port)
	  file (cond
		(realm realm)
		((string= "" file) "/")
		((string-match "/$" file) file)
		(t (url-file-directory file)))
	  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)
			      (or user (user-real-login-name)))
	    pass (read-passwd "Password: " nil (or pass "")))
      (set url-basic-auth-storage
	   (cons (list server
		       (cons file
			     (setq retval
				   (base64-encode-string
				    (format "%s:%s" user pass)))))
		 (symbol-value url-basic-auth-storage))))
     (byserv
      (setq retval (cdr-safe (assoc file byserv)))
      (if (and (not retval)
	       (string-match "/" file))
 	  (while (and byserv (not retval))
	    (setq data (car (car byserv)))
	    (if (or (not (string-match "/" data)) ; It's a realm - take it!
		    (and
		     (>= (length file) (length data))
		     (string= data (substring file 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 file 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))
	     (file (url-filename href))
	     user pass byserv retval data)
	(setq file (cond
		    (realm realm)
		    ((string-match "/$" file) file)
		    (t (url-file-directory file)))
	      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 file
				  (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 file byserv)))
	  (if (and (not retval)		; no exact match, check directories
		   (string-match "/" file)) ; not looking for a realm
	      (while (and byserv (not retval))
		(setq data (car (car byserv)))
		(if (or (not (string-match "/" data))
			(and
			 (>= (length file) (length data))
			 (string= data (substring file 0 (length data)))))
		    (setq retval (cdr (car byserv))))
		(setq byserv (cdr byserv))))
	  (if overwrite
	      (if (and (not retval) prompt)
		  (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 file retval) (cdr byserv))))))
	 (t (setq retval nil)))
	(if retval
	    (if (cdr-safe (assoc "opaque" args))
		(let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
		      (opaque (cdr-safe (assoc "opaque" args))))
		  (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))
	      (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")))
		(format
		 (concat "Digest username=\"%s\", realm=\"%s\","
			 "nonce=\"%s\", uri=\"%s\","
			 "response=\"%s\"")
		 (nth 0 retval) realm nonce (url-filename href)
		 (md5 (concat (nth 1 retval) ":" nonce ":"
			      (nth 2 retval))))))))))

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