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