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