code.delx.au - gnu-emacs/blob - lisp/url/url-auth.el

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