lisp/url/url-auth.el

   1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
   2 ;; Keywords: comm, data, processes, hypermedia
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
   6 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
   7 ;;;
   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
  12 ;;; the Free Software Foundation; either version 2, or (at your option)
  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
  22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;;; Boston, MA 02111-1307, USA.
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  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))
  82             pass (funcall url-passwd-entry-func "Password: "))
  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))
 106                   pass (funcall url-passwd-entry-func "Password: ")
 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))
 164                 pass (funcall url-passwd-entry-func "Password: ")
 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))
 191                       pass (funcall url-passwd-entry-func "Password: ")
 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)
 296                   ((stringp rating) (string-to-int rating))
 297                   (t rating)))
 298          (node (assoc type url-registered-auth-schemes)))
 299     (if (not (fboundp function))
 300         (url-warn 'security
 301                   (format (concat
 302                            "Tried to register `%s' as an auth scheme"
 303                            ", but it is not a function!") function)))
 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)
 316
 317 ;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91