lisp/url/url-auth.el

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