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 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., 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 pathname 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          (path (url-filename href))
  71          user pass byserv retval data)
  72     (setq server (format "%s:%d" server port)
  73           path (cond
  74                 (realm realm)
  75                 ((string-match "/$" path) path)
  76                 (t (url-basepath path)))
  77           byserv (cdr-safe (assoc server
  78                                   (symbol-value url-basic-auth-storage))))
  79     (cond
  80      ((and prompt (not byserv))
  81       (setq user (read-string (url-auth-user-prompt url realm)
  82                               (user-real-login-name))
  83             pass (read-passwd "Password: "))
  84       (set url-basic-auth-storage
  85            (cons (list server
  86                        (cons path
  87                              (setq retval
  88                                    (base64-encode-string
  89                                     (format "%s:%s" user pass)))))
  90                  (symbol-value url-basic-auth-storage))))
  91      (byserv
  92       (setq retval (cdr-safe (assoc path byserv)))
  93       (if (and (not retval)
  94                (string-match "/" path))
  95           (while (and byserv (not retval))
  96             (setq data (car (car byserv)))
  97             (if (or (not (string-match "/" data)) ; It's a realm - take it!
  98                     (and
  99                      (>= (length path) (length data))
 100                      (string= data (substring path 0 (length data)))))
 101                 (setq retval (cdr (car byserv))))
 102             (setq byserv (cdr byserv))))
 103       (if (or (and (not retval) prompt) overwrite)
 104           (progn
 105             (setq user (read-string (url-auth-user-prompt url realm)
 106                                     (user-real-login-name))
 107                   pass (read-passwd "Password: ")
 108                   retval (base64-encode-string (format "%s:%s" user pass))
 109                   byserv (assoc server (symbol-value url-basic-auth-storage)))
 110             (setcdr byserv
 111                     (cons (cons path retval) (cdr byserv))))))
 112      (t (setq retval nil)))
 113     (if retval (setq retval (concat "Basic " retval)))
 114     retval))
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 ;;; Digest authorization code
 118 ;;; ------------------------
 119 ;;; This implements the DIGEST authorization type.  See the internet draft
 120 ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
 121 ;;; for the complete documentation on this type.
 122 ;;;
 123 ;;; This is very secure
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 (defvar url-digest-auth-storage nil
 126   "Where usernames and passwords are stored.  Its value is an assoc list of
 127 assoc lists.  The first assoc list is keyed by the server name.  The cdr of
 128 this is an assoc list based on the 'directory' specified by the url we are
 129 looking up.")
 130
 131 (defun url-digest-auth-create-key (username password realm method uri)
 132   "Create a key for digest authentication method"
 133   (let* ((info (if (stringp uri)
 134                    (url-generic-parse-url uri)
 135                  uri))
 136          (a1 (md5 (concat username ":" realm ":" password)))
 137          (a2 (md5 (concat method ":" (url-filename info)))))
 138     (list a1 a2)))
 139
 140 (defun url-digest-auth (url &optional prompt overwrite realm args)
 141   "Get the username/password for the specified URL.
 142 If optional argument PROMPT is non-nil, ask for the username/password
 143 to use for the url and its descendants.  If optional third argument
 144 OVERWRITE is non-nil, overwrite the old username/password pair if it
 145 is found in the assoc list.  If REALM is specified, use that as the realm
 146 instead of hostname:portnum."
 147   (if args
 148       (let* ((href (if (stringp url)
 149                        (url-generic-parse-url url)
 150                      url))
 151              (server (url-host href))
 152              (port (url-port href))
 153              (path (url-filename href))
 154              user pass byserv retval data)
 155         (setq path (cond
 156                     (realm realm)
 157                     ((string-match "/$" path) path)
 158                     (t (url-basepath path)))
 159               server (format "%s:%d" server port)
 160               byserv (cdr-safe (assoc server url-digest-auth-storage)))
 161         (cond
 162          ((and prompt (not byserv))
 163           (setq user (read-string (url-auth-user-prompt url realm)
 164                                   (user-real-login-name))
 165                 pass (read-passwd "Password: ")
 166                 url-digest-auth-storage
 167                 (cons (list server
 168                             (cons path
 169                                   (setq retval
 170                                         (cons user
 171                                               (url-digest-auth-create-key
 172                                                user pass realm
 173                                                (or url-request-method "GET")
 174                                                url)))))
 175                       url-digest-auth-storage)))
 176          (byserv
 177           (setq retval (cdr-safe (assoc path byserv)))
 178           (if (and (not retval)         ; no exact match, check directories
 179                    (string-match "/" path)) ; not looking for a realm
 180               (while (and byserv (not retval))
 181                 (setq data (car (car byserv)))
 182                 (if (or (not (string-match "/" data))
 183                         (and
 184                          (>= (length path) (length data))
 185                          (string= data (substring path 0 (length data)))))
 186                     (setq retval (cdr (car byserv))))
 187                 (setq byserv (cdr byserv))))
 188           (if (or (and (not retval) prompt) overwrite)
 189               (progn
 190                 (setq user (read-string (url-auth-user-prompt url realm)
 191                                         (user-real-login-name))
 192                       pass (read-passwd "Password: ")
 193                       retval (setq retval
 194                                    (cons user
 195                                          (url-digest-auth-create-key
 196                                           user pass realm
 197                                           (or url-request-method "GET")
 198                                           url)))
 199                       byserv (assoc server url-digest-auth-storage))
 200                 (setcdr byserv
 201                         (cons (cons path retval) (cdr byserv))))))
 202          (t (setq retval nil)))
 203         (if retval
 204             (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
 205                   (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
 206               (format
 207                (concat "Digest username=\"%s\", realm=\"%s\","
 208                        "nonce=\"%s\", uri=\"%s\","
 209                        "response=\"%s\", opaque=\"%s\"")
 210                (nth 0 retval) realm nonce (url-filename href)
 211                (md5 (concat (nth 1 retval) ":" nonce ":"
 212                             (nth 2 retval))) opaque))))))
 213
 214 (defvar url-registered-auth-schemes nil
 215   "A list of the registered authorization schemes and various and sundry
 216 information associated with them.")
 217
 218 ;;;###autoload
 219 (defun url-get-authentication (url realm type prompt &optional args)
 220   "Return an authorization string suitable for use in the WWW-Authenticate
 221 header in an HTTP/1.0 request.
 222
 223 URL    is the url you are requesting authorization to.  This can be either a
 224        string representing the URL, or the parsed representation returned by
 225        `url-generic-parse-url'
 226 REALM  is the realm at a specific site we are looking for.  This should be a
 227        string specifying the exact realm, or nil or the symbol 'any' to
 228        specify that the filename portion of the URL should be used as the
 229        realm
 230 TYPE   is the type of authentication to be returned.  This is either a string
 231        representing the type (basic, digest, etc), or nil or the symbol 'any'
 232        to specify that any authentication is acceptable.  If requesting 'any'
 233        the strongest matching authentication will be returned.  If this is
 234        wrong, it's no big deal, the error from the server will specify exactly
 235        what type of auth to use
 236 PROMPT is boolean - specifies whether to ask the user for a username/password
 237        if one cannot be found in the cache"
 238   (if (not realm)
 239       (setq realm (cdr-safe (assoc "realm" args))))
 240   (if (stringp url)
 241       (setq url (url-generic-parse-url url)))
 242   (if (or (null type) (eq type 'any))
 243       ;; Whooo doogies!
 244       ;; Go through and get _all_ the authorization strings that could apply
 245       ;; to this URL, store them along with the 'rating' we have in the list
 246       ;; of schemes, then sort them so that the 'best' is at the front of the
 247       ;; list, then get the car, then get the cdr.
 248       ;; Zooom zooom zoooooom
 249       (cdr-safe
 250        (car-safe
 251         (sort
 252          (mapcar
 253           (function
 254            (lambda (scheme)
 255              (if (fboundp (car (cdr scheme)))
 256                  (cons (cdr (cdr scheme))
 257                        (funcall (car (cdr scheme)) url nil nil realm))
 258                (cons 0 nil))))
 259           url-registered-auth-schemes)
 260          (function
 261           (lambda (x y)
 262             (cond
 263              ((null (cdr x)) nil)
 264              ((and (cdr x) (null (cdr y))) t)
 265              ((and (cdr x) (cdr y))
 266               (>= (car x) (car y)))
 267              (t nil)))))))
 268     (if (symbolp type) (setq type (symbol-name type)))
 269     (let* ((scheme (car-safe
 270                     (cdr-safe (assoc (downcase type)
 271                                      url-registered-auth-schemes)))))
 272       (if (and scheme (fboundp scheme))
 273           (funcall scheme url prompt
 274                    (and prompt
 275                         (funcall scheme url nil nil realm args))
 276                    realm args)))))
 277
 278 ;;;###autoload
 279 (defun url-register-auth-scheme (type &optional function rating)
 280   "Register an HTTP authentication method.
 281
 282 TYPE     is a string or symbol specifying the name of the method.   This
 283          should be the same thing you expect to get returned in an Authenticate
 284          header in HTTP/1.0 - it will be downcased.
 285 FUNCTION is the function to call to get the authorization information.  This
 286          defaults to `url-?-auth', where ? is TYPE
 287 RATING   a rating between 1 and 10 of the strength of the authentication.
 288          This is used when asking for the best authentication for a specific
 289          URL.  The item with the highest rating is returned."
 290   (let* ((type (cond
 291                 ((stringp type) (downcase type))
 292                 ((symbolp type) (downcase (symbol-name type)))
 293                 (t (error "Bad call to `url-register-auth-scheme'"))))
 294          (function (or function (intern (concat "url-" type "-auth"))))
 295          (rating (cond
 296                   ((null rating) 2)
 297                   ((stringp rating) (string-to-number rating))
 298                   (t rating)))
 299          (node (assoc type url-registered-auth-schemes)))
 300     (if (not (fboundp function))
 301         (url-warn 'security
 302                   (format (concat
 303                            "Tried to register `%s' as an auth scheme"
 304                            ", but it is not a function!") function)))
 305
 306     (if node
 307         (setcdr node (cons function rating))
 308       (setq url-registered-auth-schemes
 309             (cons (cons type (cons function rating))
 310                   url-registered-auth-schemes)))))
 311
 312 (defun url-auth-registered (scheme)
 313   ;; Return non-nil iff SCHEME is registered as an auth type
 314   (assoc scheme url-registered-auth-schemes))
 315
 316 (provide 'url-auth)
 317
 318 ;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
 319 ;;; url-auth.el ends here