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