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