code.delx.au - gnu-emacs/blob - lisp/url/url-auth.el

   1 ;;; url-auth.el --- Uniform Resource Locator authorization modules
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
   4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Keywords: comm, data, processes, hypermedia
   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 3, 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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  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
  64 instead of the filename inheritance method."
  65   (let* ((href (if (stringp url)
  66                    (url-generic-parse-url url)
  67                  url))
  68          (server (url-host href))
  69          (port (url-port href))
  70          (file (url-filename href))
  71          (user (url-user href))
  72          (pass (url-password href))
  73          byserv retval data)
  74     (setq server (format "%s:%d" server port)
  75           file (cond
  76                 (realm realm)
  77                 ((string= "" file) "/")
  78                 ((string-match "/$" file) file)
  79                 (t (url-file-directory file)))
  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)
  85                               (or user (user-real-login-name)))
  86             pass (read-passwd "Password: " nil (or pass "")))
  87       (set url-basic-auth-storage
  88            (cons (list server
  89                        (cons file
  90                              (setq retval
  91                                    (base64-encode-string
  92                                     (format "%s:%s" user pass)))))
  93                  (symbol-value url-basic-auth-storage))))
  94      (byserv
  95       (setq retval (cdr-safe (assoc file byserv)))
  96       (if (and (not retval)
  97                (string-match "/" file))
  98           (while (and byserv (not retval))
  99             (setq data (car (car byserv)))
 100             (if (or (not (string-match "/" data)) ; It's a realm - take it!
 101                     (and
 102                      (>= (length file) (length data))
 103                      (string= data (substring file 0 (length data)))))
 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))
 110                   pass (read-passwd "Password: ")
 111                   retval (base64-encode-string (format "%s:%s" user pass))
 112                   byserv (assoc server (symbol-value url-basic-auth-storage)))
 113             (setcdr byserv
 114                     (cons (cons file retval) (cdr byserv))))))
 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))
 156              (file (url-filename href))
 157              user pass byserv retval data)
 158         (setq file (cond
 159                     (realm realm)
 160                     ((string-match "/$" file) file)
 161                     (t (url-file-directory file)))
 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))
 168                 pass (read-passwd "Password: ")
 169                 url-digest-auth-storage
 170                 (cons (list server
 171                             (cons file
 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
 180           (setq retval (cdr-safe (assoc file byserv)))
 181           (if (and (not retval)         ; no exact match, check directories
 182                    (string-match "/" file)) ; not looking for a realm
 183               (while (and byserv (not retval))
 184                 (setq data (car (car byserv)))
 185                 (if (or (not (string-match "/" data))
 186                         (and
 187                          (>= (length file) (length data))
 188                          (string= data (substring file 0 (length data)))))
 189                     (setq retval (cdr (car byserv))))
 190                 (setq byserv (cdr byserv))))
 191           (if (or (and (not retval) prompt) overwrite)
 192               (progn
 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))
 203                 (setcdr byserv
 204                         (cons (cons file retval) (cdr byserv))))))
 205          (t (setq retval nil)))
 206         (if retval
 207             (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
 208                   (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
 209               (format
 210                (concat "Digest username=\"%s\", realm=\"%s\","
 211                        "nonce=\"%s\", uri=\"%s\","
 212                        "response=\"%s\", opaque=\"%s\"")
 213                (nth 0 retval) realm nonce (url-filename href)
 214                (md5 (concat (nth 1 retval) ":" nonce ":"
 215                             (nth 2 retval))) opaque))))))
 216
 217 (defvar url-registered-auth-schemes nil
 218   "A list of the registered authorization schemes and various and sundry
 219 information associated with them.")
 220
 221 ;;;###autoload
 222 (defun url-get-authentication (url realm type prompt &optional args)
 223   "Return an authorization string suitable for use in the WWW-Authenticate
 224 header in an HTTP/1.0 request.
 225
 226 URL    is the url you are requesting authorization to.  This can be either a
 227        string representing the URL, or the parsed representation returned by
 228        `url-generic-parse-url'
 229 REALM  is the realm at a specific site we are looking for.  This should be a
 230        string specifying the exact realm, or nil or the symbol 'any' to
 231        specify that the filename portion of the URL should be used as the
 232        realm
 233 TYPE   is the type of authentication to be returned.  This is either a string
 234        representing the type (basic, digest, etc), or nil or the symbol 'any'
 235        to specify that any authentication is acceptable.  If requesting 'any'
 236        the strongest matching authentication will be returned.  If this is
 237        wrong, it's no big deal, the error from the server will specify exactly
 238        what type of auth to use
 239 PROMPT is boolean - specifies whether to ask the user for a username/password
 240        if one cannot be found in the cache"
 241   (if (not realm)
 242       (setq realm (cdr-safe (assoc "realm" args))))
 243   (if (stringp url)
 244       (setq url (url-generic-parse-url url)))
 245   (if (or (null type) (eq type 'any))
 246       ;; Whooo doogies!
 247       ;; Go through and get _all_ the authorization strings that could apply
 248       ;; to this URL, store them along with the 'rating' we have in the list
 249       ;; of schemes, then sort them so that the 'best' is at the front of the
 250       ;; list, then get the car, then get the cdr.
 251       ;; Zooom zooom zoooooom
 252       (cdr-safe
 253        (car-safe
 254         (sort
 255          (mapcar
 256           (function
 257            (lambda (scheme)
 258              (if (fboundp (car (cdr scheme)))
 259                  (cons (cdr (cdr scheme))
 260                        (funcall (car (cdr scheme)) url nil nil realm))
 261                (cons 0 nil))))
 262           url-registered-auth-schemes)
 263          (function
 264           (lambda (x y)
 265             (cond
 266              ((null (cdr x)) nil)
 267              ((and (cdr x) (null (cdr y))) t)
 268              ((and (cdr x) (cdr y))
 269               (>= (car x) (car y)))
 270              (t nil)))))))
 271     (if (symbolp type) (setq type (symbol-name type)))
 272     (let* ((scheme (car-safe
 273                     (cdr-safe (assoc (downcase type)
 274                                      url-registered-auth-schemes)))))
 275       (if (and scheme (fboundp scheme))
 276           (funcall scheme url prompt
 277                    (and prompt
 278                         (funcall scheme url nil nil realm args))
 279                    realm args)))))
 280
 281 ;;;###autoload
 282 (defun url-register-auth-scheme (type &optional function rating)
 283   "Register an HTTP authentication method.
 284
 285 TYPE     is a string or symbol specifying the name of the method.   This
 286          should be the same thing you expect to get returned in an Authenticate
 287          header in HTTP/1.0 - it will be downcased.
 288 FUNCTION is the function to call to get the authorization information.  This
 289          defaults to `url-?-auth', where ? is TYPE
 290 RATING   a rating between 1 and 10 of the strength of the authentication.
 291          This is used when asking for the best authentication for a specific
 292          URL.  The item with the highest rating is returned."
 293   (let* ((type (cond
 294                 ((stringp type) (downcase type))
 295                 ((symbolp type) (downcase (symbol-name type)))
 296                 (t (error "Bad call to `url-register-auth-scheme'"))))
 297          (function (or function (intern (concat "url-" type "-auth"))))
 298          (rating (cond
 299                   ((null rating) 2)
 300                   ((stringp rating) (string-to-number rating))
 301                   (t rating)))
 302          (node (assoc type url-registered-auth-schemes)))
 303     (if (not (fboundp function))
 304         (url-warn 'security
 305                   (format (concat
 306                            "Tried to register `%s' as an auth scheme"
 307                            ", but it is not a function!") function)))
 308
 309     (if node
 310         (setcdr node (cons function rating))
 311       (setq url-registered-auth-schemes
 312             (cons (cons type (cons function rating))
 313                   url-registered-auth-schemes)))))
 314
 315 (defun url-auth-registered (scheme)
 316   "Return non-nil if SCHEME is registered as an auth type."
 317   (assoc scheme url-registered-auth-schemes))
 318
 319 (provide 'url-auth)
 320
 321 ;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
 322 ;;; url-auth.el ends here