home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / urlauth.el < prev    next >
Encoding:
Text File  |  1995-08-22  |  12.1 KB  |  306 lines
  1. ;;; urlauth.el,v --- Uniform Resource Locator authorization modules
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/20 18:02:45
  4. ;; Version: 1.6
  5. ;; Keywords: comm, data, processes, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)   ;;;
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;;; Basic authorization code
  33. ;;; ------------------------
  34. ;;; This implements the BASIC authorization type.  See the online
  35. ;;; documentation at
  36. ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
  37. ;;; for the complete documentation on this type.
  38. ;;;
  39. ;;; This is very insecure, but it works as a proof-of-concept
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. (defvar url-basic-auth-storage nil
  42.   "Where usernames and passwords are stored.  Its value is an assoc list of
  43. assoc lists.  The first assoc list is keyed by the server name.  The cdr of
  44. this is an assoc list based on the 'directory' specified by the url we are
  45. looking up.")
  46.  
  47. (defun url-basic-auth (url &optional prompt overwrite realm args)
  48.   "Get the username/password for the specified URL.
  49. If optional argument PROMPT is non-nil, ask for the username/password
  50. to use for the url and its descendants.  If optional third argument
  51. OVERWRITE is non-nil, overwrite the old username/password pair if it
  52. is found in the assoc list.  If REALM is specified, use that as the realm
  53. instead of the pathname inheritance method."
  54.   (let* ((href (if (stringp url)
  55.            (url-generic-parse-url url)
  56.          url))
  57.      (server (or (url-host href) url-current-server))
  58.      (port (or (url-port href) "80"))
  59.      (path (url-filename href))
  60.      user pass byserv retval data)
  61.     (setq server (concat server ":" port)
  62.       path (cond
  63.         (realm realm)
  64.         ((string-match "/$" path) path)
  65.         (t (url-basepath path)))
  66.       byserv (cdr-safe (assoc server url-basic-auth-storage)))
  67.     (cond
  68.      ((and prompt (not byserv))
  69.       (setq user (read-string "Username: " (user-real-login-name))
  70.         pass (funcall url-passwd-entry-func "Password: ")
  71.         url-basic-auth-storage
  72.         (cons (list server
  73.             (cons path
  74.                   (setq retval
  75.                     (base64-encode
  76.                      (format "%s:%s" user pass)))))
  77.           url-basic-auth-storage)))
  78.      (byserv
  79.       (setq retval (cdr-safe (assoc path byserv)))
  80.       (if (and (not retval)
  81.            (string-match "/" path))
  82.        (while (and byserv (not retval))
  83.         (setq data (car (car byserv)))
  84.         (if (or (not (string-match "/" data)) ; Its a realm - take it!
  85.             (and
  86.              (>= (length path) (length data))
  87.              (string= data (substring path 0 (length data)))))
  88.         (setq retval (cdr (car byserv))))
  89.         (setq byserv (cdr byserv))))
  90.       (if (or (and (not retval) prompt) overwrite)
  91.       (progn
  92.         (setq user (read-string "Username: " (user-real-login-name))
  93.           pass (funcall url-passwd-entry-func "Password: ")
  94.           retval (base64-encode (format "%s:%s" user pass))
  95.           byserv (assoc server url-basic-auth-storage))
  96.         (setcdr byserv
  97.             (cons (cons path retval) (cdr byserv))))))
  98.      (t (setq retval nil)))
  99.     (if retval (setq retval (concat "Basic " retval)))
  100.     retval))
  101.  
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. ;;; Digest authorization code
  104. ;;; ------------------------
  105. ;;; This implements the DIGEST authorization type.  See the internet draft
  106. ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
  107. ;;; for the complete documentation on this type.
  108. ;;;
  109. ;;; This is very secure
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111. (defvar url-digest-auth-storage nil
  112.   "Where usernames and passwords are stored.  Its value is an assoc list of
  113. assoc lists.  The first assoc list is keyed by the server name.  The cdr of
  114. this is an assoc list based on the 'directory' specified by the url we are
  115. looking up.")
  116.  
  117. (defun url-digest-auth-create-key (username password realm method uri)
  118.   "Create a key for digest authentication method"
  119.   (let* ((info (if (stringp uri)
  120.            (url-generic-parse-url uri)
  121.          uri))
  122.      (a1 (md5 (concat username ":" realm ":" password)))
  123.      (a2 (md5 (concat method ":" (url-filename info)))))
  124.     (list a1 a2)))
  125.  
  126. (defun url-digest-auth (url &optional prompt overwrite realm args)
  127.   "Get the username/password for the specified URL.
  128. If optional argument PROMPT is non-nil, ask for the username/password
  129. to use for the url and its descendants.  If optional third argument
  130. OVERWRITE is non-nil, overwrite the old username/password pair if it
  131. is found in the assoc list.  If REALM is specified, use that as the realm
  132. instead of hostname:portnum."
  133.   (if args
  134.       (let* ((href (if (stringp url)
  135.                (url-generic-parse-url url)
  136.              url))
  137.          (server (or (url-host href) url-current-server))
  138.          (port (or (url-port href) "80"))
  139.          (path (url-filename href))
  140.          user pass byserv retval data)
  141.     (setq path (cond
  142.             (realm realm)
  143.             ((string-match "/$" path) path)
  144.             (t (url-basepath path)))
  145.           server (concat server ":" port)
  146.           byserv (cdr-safe (assoc server url-digest-auth-storage)))
  147.     (cond
  148.      ((and prompt (not byserv))
  149.       (setq user (read-string "Username: " (user-real-login-name))
  150.         pass (funcall url-passwd-entry-func "Password: ")
  151.         url-digest-auth-storage
  152.         (cons (list server
  153.                 (cons path
  154.                   (setq retval
  155.                     (cons user
  156.                           (url-digest-auth-create-key
  157.                            user pass realm
  158.                            (or url-request-method "GET")
  159.                            url)))))
  160.               url-digest-auth-storage)))
  161.      (byserv
  162.       (setq retval (cdr-safe (assoc path byserv)))
  163.       (if (and (not retval)        ; no exact match, check directories
  164.            (string-match "/" path)) ; not looking for a realm
  165.           (while (and byserv (not retval))
  166.         (setq data (car (car byserv)))
  167.         (if (or (not (string-match "/" data))
  168.             (and
  169.              (>= (length path) (length data))
  170.              (string= data (substring path 0 (length data)))))
  171.             (setq retval (cdr (car byserv))))
  172.         (setq byserv (cdr byserv))))
  173.       (if (or (and (not retval) prompt) overwrite)
  174.           (progn
  175.         (setq user (read-string "Username: " (user-real-login-name))
  176.               pass (funcall url-passwd-entry-func "Password: ")
  177.               retval (setq retval
  178.                    (cons user
  179.                      (url-digest-auth-create-key
  180.                       user pass realm
  181.                       (or url-request-method "GET")
  182.                       url)))
  183.               byserv (assoc server url-digest-auth-storage))
  184.         (setcdr byserv
  185.             (cons (cons path retval) (cdr byserv))))))
  186.      (t (setq retval nil)))
  187.     (if retval
  188.         (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
  189.           (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
  190.           (format
  191.            (concat "Digest username=\"%s\", realm=\"%s\","
  192.                "nonce=\"%s\", uri=\"%s\","
  193.                "response=\"%s\", opaque=\"%s\"")
  194.            (nth 0 retval) realm nonce (url-filename href)
  195.            (md5 (concat (nth 1 retval) ":" nonce ":"
  196.                 (nth 2 retval))) opaque))))))
  197.  
  198. (defvar url-registered-auth-schemes nil
  199.   "A list of the registered authorization schemes and various and sundry
  200. information associated with them.")
  201.  
  202. (defun url-get-authentication (url realm type prompt &optional args)
  203.   "Return an authorization string suitable for use in the WWW-Authenticate
  204. header in an HTTP/1.0 request.
  205.  
  206. URL    is the url you are requesting authorization to.  This can be either a
  207.        string representing the URL, or the parsed representation returned by
  208.        `url-generic-parse-url'
  209. REALM  is the realm at a specific site we are looking for.  This should be a
  210.        string specifying the exact realm, or nil or the symbol 'any' to
  211.        specify that the filename portion of the URL should be used as the
  212.        realm
  213. TYPE   is the type of authentication to be returned.  This is either a string
  214.        representing the type (basic, digest, etc), or nil or the symbol 'any'
  215.        to specify that any authentication is acceptable.  If requesting 'any'
  216.        the strongest matching authentication will be returned.  If this is
  217.        wrong, its no big deal, the error from the server will specify exactly
  218.        what type of auth to use
  219. PROMPT is boolean - specifies whether to ask the user for a username/password
  220.        if one cannot be found in the cache"
  221.   (if (not realm)
  222.       (setq realm (cdr-safe (assoc "realm" args))))
  223.   (if (stringp url)
  224.       (setq url (url-generic-parse-url url)))
  225.   (if (or (null type) (eq type 'any))
  226.       ;; Whooo doogies!
  227.       ;; Go through and get _all_ the authorization strings that could apply
  228.       ;; to this URL, store them along with the 'rating' we have in the list
  229.       ;; of schemes, then sort them so that the 'best' is at the front of the
  230.       ;; list, then get the car, then get the cdr.
  231.       ;; Zooom zooom zoooooom
  232.       (cdr-safe
  233.        (car-safe
  234.     (sort
  235.      (mapcar
  236.       (function
  237.        (lambda (scheme)
  238.          (if (fboundp (car (cdr scheme)))
  239.          (cons (cdr (cdr scheme))
  240.                (funcall (car (cdr scheme)) url nil nil realm))
  241.            (cons 0 nil))))
  242.       url-registered-auth-schemes)
  243.      (function
  244.       (lambda (x y)
  245.         (cond
  246.          ((null (cdr x)) nil)
  247.          ((and (cdr x) (null (cdr y))) t)
  248.          ((and (cdr x) (cdr y))
  249.           (>= (car x) (car y)))
  250.          (t nil)))))))
  251.     (if (symbolp type) (setq type (symbol-name type)))
  252.     (let* ((scheme (car-safe
  253.             (cdr-safe (assoc (downcase type)
  254.                      url-registered-auth-schemes)))))
  255.       (if (and scheme (fboundp scheme))
  256.       (funcall scheme url prompt
  257.            (and prompt
  258.             (funcall scheme url nil nil realm args))
  259.            realm args)))))
  260.  
  261. (if (not (fboundp 'warn))
  262.     (defun warn (&rest args)
  263.       (apply 'message args)))
  264.  
  265. (defun url-register-auth-scheme (type &optional function rating)
  266.   "Register an HTTP authentication method.
  267.  
  268. TYPE     is a string or symbol specifying the name of the method.   This
  269.          should be the same thing you expect to get returned in an Authenticate
  270.          header in HTTP/1.0 - it will be downcased.
  271. FUNCTION is the function to call to get the authorization information.  This
  272.          defaults to `url-?-auth', where ? is TYPE
  273. RATING   a rating between 1 and 10 of the strength of the authentication.
  274.          This is used when asking for the best authentication for a specific
  275.          URL.  The item with the highest rating is returned."
  276.   (let* ((type (cond
  277.         ((stringp type) (downcase type))
  278.         ((symbolp type) (downcase (symbol-name type)))
  279.         (t (error "Bad call to `url-register-auth-scheme'"))))
  280.      (function (or function (intern (concat "url-" type "-auth"))))
  281.      (rating (cond
  282.           ((null rating) 2)
  283.           ((stringp rating) (string-to-int rating))
  284.           (t rating)))
  285.      (node (assoc type url-registered-auth-schemes)))
  286.     (if (not (fboundp function))
  287.     (warn (concat "Tried to register `%s' as an auth scheme"
  288.               ", but it is not a function!") function))
  289.  
  290.     (if node
  291.     (progn
  292.       (setcdr node (cons function rating))
  293.       (url-warn 'security
  294.             (format
  295.              "Replacing authorization method `%s' - this could be bad."
  296.              type)))
  297.       (setq url-registered-auth-schemes
  298.         (cons (cons type (cons function rating))
  299.           url-registered-auth-schemes)))))
  300.  
  301. (defun url-auth-registered (scheme)
  302.   ;; Return non-nil iff SCHEME is registered as an auth type
  303.   (assoc scheme url-registered-auth-schemes))
  304.  
  305. (provide 'urlauth)
  306.