[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, 2009, 2010, 2011  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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:

(require 'url-vars)
(require 'url-parse)
(autoload 'url-warn "url")
(autoload 'auth-source-user-or-password "auth-source")

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