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