1 files changed, 318 insertions, 0 deletions
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
new file mode 100644
index 00000000000..5a88b32159c
--- /dev/null
+++ b/lisp/url/url-auth.el
@@ -0,0 +1,318 @@
+;;; url-auth.el --- Uniform Resource Locator authorization modules
+;; Author: $Author: wmperry $
+;; Created: $Date: 2001/12/05 19:05:51 $
+;; Version: $Revision: 1.4 $
+;; Keywords: comm, data, processes, hypermedia
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
+;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
+;;;
+;;; 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., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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 (funcall url-passwd-entry-func "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 (funcall url-passwd-entry-func "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 (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 (url-auth-user-prompt url realm)
+					(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.")
+
+;;;###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-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
+	(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)