| 1 |
|
|---|
| 2 |
|
|---|
| 3 |
|
|---|
| 4 |
|
|---|
| 5 |
|
|---|
| 6 |
|
|---|
| 7 |
|
|---|
| 8 |
|
|---|
| 9 |
|
|---|
| 10 |
|
|---|
| 11 |
|
|---|
| 12 |
|
|---|
| 13 |
|
|---|
| 14 |
|
|---|
| 15 |
|
|---|
| 16 |
|
|---|
| 17 |
|
|---|
| 18 |
|
|---|
| 19 |
|
|---|
| 20 |
|
|---|
| 21 |
|
|---|
| 22 |
|
|---|
| 23 |
|
|---|
| 24 |
|
|---|
| 25 |
|
|---|
| 26 |
|
|---|
| 27 |
|
|---|
| 28 |
|
|---|
| 29 |
(eval-when-compile (require 'cl)) |
|---|
| 30 |
(defvar url-http-extra-headers) |
|---|
| 31 |
(defvar url-http-target-url) |
|---|
| 32 |
(defvar url-http-proxy) |
|---|
| 33 |
(defvar url-http-connection-opened) |
|---|
| 34 |
(require 'url-gw) |
|---|
| 35 |
(require 'url-util) |
|---|
| 36 |
(require 'url-parse) |
|---|
| 37 |
(require 'url-cookie) |
|---|
| 38 |
(require 'mail-parse) |
|---|
| 39 |
(require 'url-auth) |
|---|
| 40 |
(require 'url) |
|---|
| 41 |
(autoload 'url-cache-create-filename "url-cache") |
|---|
| 42 |
|
|---|
| 43 |
(defconst url-http-default-port 80 "Default HTTP port.") |
|---|
| 44 |
(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.") |
|---|
| 45 |
(defalias 'url-http-expand-file-name 'url-default-expander) |
|---|
| 46 |
|
|---|
| 47 |
(defvar url-http-real-basic-auth-storage nil) |
|---|
| 48 |
(defvar url-http-proxy-basic-auth-storage nil) |
|---|
| 49 |
|
|---|
| 50 |
(defvar url-http-open-connections (make-hash-table :test 'equal |
|---|
| 51 |
:size 17) |
|---|
| 52 |
"A hash table of all open network connections.") |
|---|
| 53 |
|
|---|
| 54 |
(defvar url-http-version "1.1" |
|---|
| 55 |
"What version of HTTP we advertise, as a string. |
|---|
| 56 |
Valid values are 1.1 and 1.0. |
|---|
| 57 |
This is only useful when debugging the HTTP subsystem. |
|---|
| 58 |
|
|---|
| 59 |
Setting this to 1.0 will tell servers not to send chunked encoding, |
|---|
| 60 |
and other HTTP/1.1 specific features.") |
|---|
| 61 |
|
|---|
| 62 |
(defvar url-http-attempt-keepalives t |
|---|
| 63 |
"Whether to use a single TCP connection multiple times in HTTP. |
|---|
| 64 |
This is only useful when debugging the HTTP subsystem. Setting to |
|---|
| 65 |
nil will explicitly close the connection to the server after every |
|---|
| 66 |
request.") |
|---|
| 67 |
|
|---|
| 68 |
|
|---|
| 69 |
|
|---|
| 70 |
|
|---|
| 71 |
|
|---|
| 72 |
|
|---|
| 73 |
|
|---|
| 74 |
|
|---|
| 75 |
|
|---|
| 76 |
(defsubst url-http-debug (&rest args) |
|---|
| 77 |
(if quit-flag |
|---|
| 78 |
(let ((proc (get-buffer-process (current-buffer)))) |
|---|
| 79 |
|
|---|
| 80 |
|
|---|
| 81 |
(if proc |
|---|
| 82 |
(progn |
|---|
| 83 |
(set-process-sentinel proc nil) |
|---|
| 84 |
(set-process-filter proc nil))) |
|---|
| 85 |
(error "Transfer interrupted!"))) |
|---|
| 86 |
(apply 'url-debug 'http args)) |
|---|
| 87 |
|
|---|
| 88 |
(defun url-http-mark-connection-as-busy (host port proc) |
|---|
| 89 |
(url-http-debug "Marking connection as busy: %s:%d %S" host port proc) |
|---|
| 90 |
(set-process-query-on-exit-flag proc t) |
|---|
| 91 |
(puthash (cons host port) |
|---|
| 92 |
(delq proc (gethash (cons host port) url-http-open-connections)) |
|---|
| 93 |
url-http-open-connections) |
|---|
| 94 |
proc) |
|---|
| 95 |
|
|---|
| 96 |
(defun url-http-mark-connection-as-free (host port proc) |
|---|
| 97 |
(url-http-debug "Marking connection as free: %s:%d %S" host port proc) |
|---|
| 98 |
(when (memq (process-status proc) '(open run connect)) |
|---|
| 99 |
(set-process-buffer proc nil) |
|---|
| 100 |
(set-process-sentinel proc 'url-http-idle-sentinel) |
|---|
| 101 |
(set-process-query-on-exit-flag proc nil) |
|---|
| 102 |
(puthash (cons host port) |
|---|
| 103 |
(cons proc (gethash (cons host port) url-http-open-connections)) |
|---|
| 104 |
url-http-open-connections)) |
|---|
| 105 |
nil) |
|---|
| 106 |
|
|---|
| 107 |
(defun url-http-find-free-connection (host port) |
|---|
| 108 |
(let ((conns (gethash (cons host port) url-http-open-connections)) |
|---|
| 109 |
(found nil)) |
|---|
| 110 |
(while (and conns (not found)) |
|---|
| 111 |
(if (not (memq (process-status (car conns)) '(run open connect))) |
|---|
| 112 |
(progn |
|---|
| 113 |
(url-http-debug "Cleaning up dead process: %s:%d %S" |
|---|
| 114 |
host port (car conns)) |
|---|
| 115 |
(url-http-idle-sentinel (car conns) nil)) |
|---|
| 116 |
(setq found (car conns)) |
|---|
| 117 |
(url-http-debug "Found existing connection: %s:%d %S" host port found)) |
|---|
| 118 |
(pop conns)) |
|---|
| 119 |
(if found |
|---|
| 120 |
(url-http-debug "Reusing existing connection: %s:%d" host port) |
|---|
| 121 |
(url-http-debug "Contacting host: %s:%d" host port)) |
|---|
| 122 |
(url-lazy-message "Contacting host: %s:%d" host port) |
|---|
| 123 |
(url-http-mark-connection-as-busy |
|---|
| 124 |
host port |
|---|
| 125 |
(or found |
|---|
| 126 |
(let ((buf (generate-new-buffer " *url-http-temp*"))) |
|---|
| 127 |
|
|---|
| 128 |
|
|---|
| 129 |
(unwind-protect |
|---|
| 130 |
(let ((proc (url-open-stream host buf host port))) |
|---|
| 131 |
|
|---|
| 132 |
(when (processp proc) |
|---|
| 133 |
|
|---|
| 134 |
(set-process-buffer proc nil)) |
|---|
| 135 |
proc) |
|---|
| 136 |
(kill-buffer buf))))))) |
|---|
| 137 |
|
|---|
| 138 |
|
|---|
| 139 |
(defun url-http-user-agent-string () |
|---|
| 140 |
(if (or (eq url-privacy-level 'paranoid) |
|---|
| 141 |
(and (listp url-privacy-level) |
|---|
| 142 |
(memq 'agent url-privacy-level))) |
|---|
| 143 |
"" |
|---|
| 144 |
(format "User-Agent: %sURL/%s%s\r\n" |
|---|
| 145 |
(if url-package-name |
|---|
| 146 |
(concat url-package-name "/" url-package-version " ") |
|---|
| 147 |
"") |
|---|
| 148 |
url-version |
|---|
| 149 |
(cond |
|---|
| 150 |
((and url-os-type url-system-type) |
|---|
| 151 |
(concat " (" url-os-type "; " url-system-type ")")) |
|---|
| 152 |
((or url-os-type url-system-type) |
|---|
| 153 |
(concat " (" (or url-system-type url-os-type) ")")) |
|---|
| 154 |
(t ""))))) |
|---|
| 155 |
|
|---|
| 156 |
(defun url-http-create-request (&optional ref-url) |
|---|
| 157 |
"Create an HTTP request for `url-http-target-url', referred to by REF-URL." |
|---|
| 158 |
(declare (special proxy-info |
|---|
| 159 |
url-http-method url-http-data |
|---|
| 160 |
url-http-extra-headers)) |
|---|
| 161 |
(let* ((extra-headers) |
|---|
| 162 |
(request nil) |
|---|
| 163 |
(no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) |
|---|
| 164 |
(using-proxy url-http-proxy) |
|---|
| 165 |
(proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization" |
|---|
| 166 |
url-http-extra-headers)) |
|---|
| 167 |
(not using-proxy)) |
|---|
| 168 |
nil |
|---|
| 169 |
(let ((url-basic-auth-storage |
|---|
| 170 |
'url-http-proxy-basic-auth-storage)) |
|---|
| 171 |
(url-get-authentication url-http-target-url nil 'any nil)))) |
|---|
| 172 |
(real-fname (concat (url-filename url-http-target-url) |
|---|
| 173 |
(url-recreate-url-attributes url-http-target-url))) |
|---|
| 174 |
(host (url-host url-http-target-url)) |
|---|
| 175 |
(auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) |
|---|
| 176 |
nil |
|---|
| 177 |
(url-get-authentication (or |
|---|
| 178 |
(and (boundp 'proxy-info) |
|---|
| 179 |
proxy-info) |
|---|
| 180 |
url-http-target-url) nil 'any nil)))) |
|---|
| 181 |
(if (equal "" real-fname) |
|---|
| 182 |
(setq real-fname "/")) |
|---|
| 183 |
(setq no-cache (and no-cache (string-match "no-cache" no-cache))) |
|---|
| 184 |
(if auth |
|---|
| 185 |
(setq auth (concat "Authorization: " auth "\r\n"))) |
|---|
| 186 |
(if proxy-auth |
|---|
| 187 |
(setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n"))) |
|---|
| 188 |
|
|---|
| 189 |
|
|---|
| 190 |
(if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil") |
|---|
| 191 |
(string= ref-url ""))) |
|---|
| 192 |
(setq ref-url nil)) |
|---|
| 193 |
|
|---|
| 194 |
|
|---|
| 195 |
(if (or (memq url-privacy-level '(low high paranoid)) |
|---|
| 196 |
(and (listp url-privacy-level) |
|---|
| 197 |
(memq 'lastloc url-privacy-level))) |
|---|
| 198 |
(setq ref-url nil)) |
|---|
| 199 |
|
|---|
| 200 |
|
|---|
| 201 |
|
|---|
| 202 |
(setq extra-headers (mapconcat |
|---|
| 203 |
(lambda (x) |
|---|
| 204 |
(concat (car x) ": " (cdr x))) |
|---|
| 205 |
url-http-extra-headers "\r\n")) |
|---|
| 206 |
(if (not (equal extra-headers "")) |
|---|
| 207 |
(setq extra-headers (concat extra-headers "\r\n"))) |
|---|
| 208 |
|
|---|
| 209 |
|
|---|
| 210 |
|
|---|
| 211 |
|
|---|
| 212 |
|
|---|
| 213 |
(setq request |
|---|
| 214 |
|
|---|
| 215 |
|
|---|
| 216 |
|
|---|
| 217 |
|
|---|
| 218 |
|
|---|
| 219 |
|
|---|
| 220 |
(mapconcat |
|---|
| 221 |
|
|---|
| 222 |
|
|---|
| 223 |
|
|---|
| 224 |
'string-as-unibyte |
|---|
| 225 |
(delq nil |
|---|
| 226 |
(list |
|---|
| 227 |
|
|---|
| 228 |
(or url-http-method "GET") " " |
|---|
| 229 |
(if using-proxy (url-recreate-url url-http-target-url) real-fname) |
|---|
| 230 |
" HTTP/" url-http-version "\r\n" |
|---|
| 231 |
|
|---|
| 232 |
"MIME-Version: 1.0\r\n" |
|---|
| 233 |
|
|---|
| 234 |
"Connection: " (if (or using-proxy |
|---|
| 235 |
(not url-http-attempt-keepalives)) |
|---|
| 236 |
"close" "keep-alive") "\r\n" |
|---|
| 237 |
|
|---|
| 238 |
(if url-extensions-header |
|---|
| 239 |
(format |
|---|
| 240 |
"Extension: %s\r\n" url-extensions-header)) |
|---|
| 241 |
|
|---|
| 242 |
(if (/= (url-port url-http-target-url) |
|---|
| 243 |
(url-scheme-get-property |
|---|
| 244 |
(url-type url-http-target-url) 'default-port)) |
|---|
| 245 |
(format |
|---|
| 246 |
"Host: %s:%d\r\n" host (url-port url-http-target-url)) |
|---|
| 247 |
(format "Host: %s\r\n" host)) |
|---|
| 248 |
|
|---|
| 249 |
(if url-personal-mail-address |
|---|
| 250 |
(concat |
|---|
| 251 |
"From: " url-personal-mail-address "\r\n")) |
|---|
| 252 |
|
|---|
| 253 |
(if url-mime-encoding-string |
|---|
| 254 |
(concat |
|---|
| 255 |
"Accept-encoding: " url-mime-encoding-string "\r\n")) |
|---|
| 256 |
(if url-mime-charset-string |
|---|
| 257 |
(concat |
|---|
| 258 |
"Accept-charset: " url-mime-charset-string "\r\n")) |
|---|
| 259 |
|
|---|
| 260 |
(if url-mime-language-string |
|---|
| 261 |
(concat |
|---|
| 262 |
"Accept-language: " url-mime-language-string "\r\n")) |
|---|
| 263 |
|
|---|
| 264 |
"Accept: " (or url-mime-accept-string "*/*") "\r\n" |
|---|
| 265 |
|
|---|
| 266 |
(url-http-user-agent-string) |
|---|
| 267 |
|
|---|
| 268 |
proxy-auth |
|---|
| 269 |
|
|---|
| 270 |
auth |
|---|
| 271 |
|
|---|
| 272 |
(url-cookie-generate-header-lines host real-fname |
|---|
| 273 |
(equal "https" (url-type url-http-target-url))) |
|---|
| 274 |
|
|---|
| 275 |
(if (and (not no-cache) |
|---|
| 276 |
(member url-http-method '("GET" nil))) |
|---|
| 277 |
(let ((tm (url-is-cached url-http-target-url))) |
|---|
| 278 |
(if tm |
|---|
| 279 |
(concat "If-modified-since: " |
|---|
| 280 |
(url-get-normalized-date tm) "\r\n")))) |
|---|
| 281 |
|
|---|
| 282 |
(if ref-url (concat |
|---|
| 283 |
"Referer: " ref-url "\r\n")) |
|---|
| 284 |
extra-headers |
|---|
| 285 |
|
|---|
| 286 |
(if url-http-data |
|---|
| 287 |
(concat |
|---|
| 288 |
"Content-length: " (number-to-string |
|---|
| 289 |
(length url-http-data)) |
|---|
| 290 |
"\r\n")) |
|---|
| 291 |
|
|---|
| 292 |
"\r\n" |
|---|
| 293 |
|
|---|
| 294 |
url-http-data)) |
|---|
| 295 |
"")) |
|---|
| 296 |
(url-http-debug "Request is: \n%s" request) |
|---|
| 297 |
request)) |
|---|
| 298 |
|
|---|
| 299 |
|
|---|
| 300 |
(defun url-http-clean-headers () |
|---|
| 301 |
"Remove trailing \r from header lines. |
|---|
| 302 |
This allows us to use `mail-fetch-field', etc." |
|---|
| 303 |
(declare (special url-http-end-of-headers)) |
|---|
| 304 |
(goto-char (point-min)) |
|---|
| 305 |
(while (re-search-forward "\r$" url-http-end-of-headers t) |
|---|
| 306 |
(replace-match ""))) |
|---|
| 307 |
|
|---|
| 308 |
(defun url-http-handle-authentication (proxy) |
|---|
| 309 |
(declare (special status success url-http-method url-http-data |
|---|
| 310 |
url-callback-function url-callback-arguments)) |
|---|
| 311 |
(url-http-debug "Handling %s authentication" (if proxy "proxy" "normal")) |
|---|
| 312 |
(let ((auths (or (nreverse |
|---|
| 313 |
(mail-fetch-field |
|---|
| 314 |
(if proxy "proxy-authenticate" "www-authenticate") |
|---|
| 315 |
nil nil t)) |
|---|
| 316 |
'("basic"))) |
|---|
| 317 |
(type nil) |
|---|
| 318 |
(url (url-recreate-url url-current-object)) |
|---|
| 319 |
(url-basic-auth-storage 'url-http-real-basic-auth-storage) |
|---|
| 320 |
auth |
|---|
| 321 |
(strength 0)) |
|---|
| 322 |
|
|---|
| 323 |
(if proxy |
|---|
| 324 |
(setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage)) |
|---|
| 325 |
|
|---|
| 326 |
|
|---|
| 327 |
(dolist (this-auth auths) |
|---|
| 328 |
(setq this-auth (url-eat-trailing-space |
|---|
| 329 |
(url-strip-leading-spaces |
|---|
| 330 |
this-auth))) |
|---|
| 331 |
(let* ((this-type |
|---|
| 332 |
(if (string-match "[ \t]" this-auth) |
|---|
| 333 |
(downcase (substring this-auth 0 (match-beginning 0))) |
|---|
| 334 |
(downcase this-auth))) |
|---|
| 335 |
(registered (url-auth-registered this-type)) |
|---|
| 336 |
(this-strength (cddr registered))) |
|---|
| 337 |
(when (and registered (> this-strength strength)) |
|---|
| 338 |
(setq auth this-auth |
|---|
| 339 |
type this-type |
|---|
| 340 |
strength this-strength)))) |
|---|
| 341 |
|
|---|
| 342 |
(if (not (url-auth-registered type)) |
|---|
| 343 |
(progn |
|---|
| 344 |
(widen) |
|---|
| 345 |
(goto-char (point-max)) |
|---|
| 346 |
(insert "<hr>Sorry, but I do not know how to handle " type |
|---|
| 347 |
" authentication. If you'd like to write it," |
|---|
| 348 |
" send it to " url-bug-address ".<hr>") |
|---|
| 349 |
(setq status t)) |
|---|
| 350 |
(let* ((args (url-parse-args (subst-char-in-string ?, ?\ |
|---|
| 351 |
(auth (url-get-authentication url (cdr-safe (assoc "realm" args)) |
|---|
| 352 |
type t args))) |
|---|
| 353 |
(if (not auth) |
|---|
| 354 |
(setq success t) |
|---|
| 355 |
(push (cons (if proxy "Proxy-Authorization" "Authorization") auth) |
|---|
| 356 |
url-http-extra-headers) |
|---|
| 357 |
(let ((url-request-method url-http-method) |
|---|
| 358 |
(url-request-data url-http-data) |
|---|
| 359 |
(url-request-extra-headers url-http-extra-headers)) |
|---|
| 360 |
(url-retrieve-internal url url-callback-function |
|---|
| 361 |
url-callback-arguments))))))) |
|---|
| 362 |
|
|---|
| 363 |
(defun url-http-parse-response () |
|---|
| 364 |
"Parse just the response code." |
|---|
| 365 |
(declare (special url-http-end-of-headers url-http-response-status |
|---|
| 366 |
url-http-response-version)) |
|---|
| 367 |
(if (not url-http-end-of-headers) |
|---|
| 368 |
(error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) |
|---|
| 369 |
(url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) |
|---|
| 370 |
(goto-char (point-min)) |
|---|
| 371 |
(skip-chars-forward " \t\n") |
|---|
| 372 |
(skip-chars-forward "HTTP/") |
|---|
| 373 |
(setq url-http-response-version |
|---|
| 374 |
(buffer-substring (point) |
|---|
| 375 |
(progn |
|---|
| 376 |
(skip-chars-forward "[0-9].") |
|---|
| 377 |
(point)))) |
|---|
| 378 |
(setq url-http-response-status (read (current-buffer)))) |
|---|
| 379 |
|
|---|
| 380 |
(defun url-http-handle-cookies () |
|---|
| 381 |
"Handle all set-cookie / set-cookie2 headers in an HTTP response. |
|---|
| 382 |
The buffer must already be narrowed to the headers, so `mail-fetch-field' will |
|---|
| 383 |
work correctly." |
|---|
| 384 |
(let ((cookies (nreverse (mail-fetch-field "Set-Cookie" nil nil t))) |
|---|
| 385 |
(cookies2 (nreverse (mail-fetch-field "Set-Cookie2" nil nil t)))) |
|---|
| 386 |
(and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies))) |
|---|
| 387 |
(and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2))) |
|---|
| 388 |
(while cookies |
|---|
| 389 |
(url-cookie-handle-set-cookie (pop cookies))) |
|---|
| 390 |
|
|---|
| 391 |
|
|---|
| 392 |
) |
|---|
| 393 |
) |
|---|
| 394 |
|
|---|
| 395 |
(defun url-http-parse-headers () |
|---|
| 396 |
"Parse and handle HTTP specific headers. |
|---|
| 397 |
Return t if and only if the current buffer is still active and |
|---|
| 398 |
should be shown to the user." |
|---|
| 399 |
|
|---|
| 400 |
|
|---|
| 401 |
(declare (special url-http-end-of-headers url-http-response-status |
|---|
| 402 |
url-http-response-version |
|---|
| 403 |
url-http-method url-http-data url-http-process |
|---|
| 404 |
url-callback-function url-callback-arguments)) |
|---|
| 405 |
|
|---|
| 406 |
(url-http-mark-connection-as-free (url-host url-current-object) |
|---|
| 407 |
(url-port url-current-object) |
|---|
| 408 |
url-http-process) |
|---|
| 409 |
|
|---|
| 410 |
(if (or (not (boundp 'url-http-end-of-headers)) |
|---|
| 411 |
(not url-http-end-of-headers)) |
|---|
| 412 |
(error "Trying to parse headers in odd buffer: %s" (buffer-name))) |
|---|
| 413 |
(goto-char (point-min)) |
|---|
| 414 |
(url-http-debug "url-http-parse-headers called in (%s)" (buffer-name)) |
|---|
| 415 |
(url-http-parse-response) |
|---|
| 416 |
(mail-narrow-to-head) |
|---|
| 417 |
|
|---|
| 418 |
(let ((connection (mail-fetch-field "Connection"))) |
|---|
| 419 |
|
|---|
| 420 |
|
|---|
| 421 |
|
|---|
| 422 |
|
|---|
| 423 |
(cond |
|---|
| 424 |
((string= url-http-response-version "1.0") |
|---|
| 425 |
(unless (and connection |
|---|
| 426 |
(string= (downcase connection) "keep-alive")) |
|---|
| 427 |
(delete-process url-http-process))) |
|---|
| 428 |
(t |
|---|
| 429 |
(when (and connection |
|---|
| 430 |
(string= (downcase connection) "close")) |
|---|
| 431 |
(delete-process url-http-process))))) |
|---|
| 432 |
(let ((buffer (current-buffer)) |
|---|
| 433 |
(class nil) |
|---|
| 434 |
(success nil)) |
|---|
| 435 |
(setq class (/ url-http-response-status 100)) |
|---|
| 436 |
(url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status) |
|---|
| 437 |
(url-http-handle-cookies) |
|---|
| 438 |
|
|---|
| 439 |
(case class |
|---|
| 440 |
|
|---|
| 441 |
|
|---|
| 442 |
|
|---|
| 443 |
|
|---|
| 444 |
|
|---|
| 445 |
|
|---|
| 446 |
|
|---|
| 447 |
(1 |
|---|
| 448 |
|
|---|
| 449 |
|
|---|
| 450 |
|
|---|
| 451 |
(url-mark-buffer-as-dead buffer) |
|---|
| 452 |
(error "HTTP responses in class 1xx not supported (%d)" url-http-response-status)) |
|---|
| 453 |
(2 |
|---|
| 454 |
|
|---|
| 455 |
|
|---|
| 456 |
|
|---|
| 457 |
|
|---|
| 458 |
|
|---|
| 459 |
|
|---|
| 460 |
|
|---|
| 461 |
|
|---|
| 462 |
(case url-http-response-status |
|---|
| 463 |
((204 205) |
|---|
| 464 |
|
|---|
| 465 |
(url-mark-buffer-as-dead buffer) |
|---|
| 466 |
(setq success t)) |
|---|
| 467 |
(otherwise |
|---|
| 468 |
|
|---|
| 469 |
|
|---|
| 470 |
(widen) |
|---|
| 471 |
(if (and url-automatic-caching (equal url-http-method "GET")) |
|---|
| 472 |
(url-store-in-cache buffer)) |
|---|
| 473 |
(setq success t)))) |
|---|
| 474 |
(3 |
|---|
| 475 |
|
|---|
| 476 |
|
|---|
| 477 |
|
|---|
| 478 |
|
|---|
| 479 |
|
|---|
| 480 |
|
|---|
| 481 |
|
|---|
| 482 |
(let ((redirect-uri (or (mail-fetch-field "Location") |
|---|
| 483 |
(mail-fetch-field "URI")))) |
|---|
| 484 |
(case url-http-response-status |
|---|
| 485 |
(300 |
|---|
| 486 |
|
|---|
| 487 |
|
|---|
| 488 |
|
|---|
| 489 |
|
|---|
| 490 |
|
|---|
| 491 |
|
|---|
| 492 |
|
|---|
| 493 |
|
|---|
| 494 |
|
|---|
| 495 |
|
|---|
| 496 |
|
|---|
| 497 |
|
|---|
| 498 |
|
|---|
| 499 |
|
|---|
| 500 |
|
|---|
| 501 |
nil) |
|---|
| 502 |
((301 302 307) |
|---|
| 503 |
|
|---|
| 504 |
|
|---|
| 505 |
|
|---|
| 506 |
|
|---|
| 507 |
|
|---|
| 508 |
(if (member url-http-method '("HEAD" "GET")) |
|---|
| 509 |
|
|---|
| 510 |
nil |
|---|
| 511 |
|
|---|
| 512 |
|
|---|
| 513 |
|
|---|
| 514 |
(url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)" |
|---|
| 515 |
url-http-method url-http-response-status) |
|---|
| 516 |
(setq url-http-method "GET" |
|---|
| 517 |
url-http-data nil))) |
|---|
| 518 |
(303 |
|---|
| 519 |
|
|---|
| 520 |
|
|---|
| 521 |
|
|---|
| 522 |
(setq url-http-method "GET" |
|---|
| 523 |
url-http-data nil)) |
|---|
| 524 |
(304 |
|---|
| 525 |
|
|---|
| 526 |
(url-http-debug "Extracting document from cache... (%s)" |
|---|
| 527 |
(url-cache-create-filename (url-view-url t))) |
|---|
| 528 |
(url-cache-extract (url-cache-create-filename (url-view-url t))) |
|---|
| 529 |
(setq redirect-uri nil |
|---|
| 530 |
success t)) |
|---|
| 531 |
(305 |
|---|
| 532 |
|
|---|
| 533 |
|
|---|
| 534 |
|
|---|
| 535 |
|
|---|
| 536 |
|
|---|
| 537 |
(error "Redirection thru a proxy server not supported: %s" |
|---|
| 538 |
redirect-uri)) |
|---|
| 539 |
(otherwise |
|---|
| 540 |
|
|---|
| 541 |
nil)) |
|---|
| 542 |
(when redirect-uri |
|---|
| 543 |
|
|---|
| 544 |
(if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) |
|---|
| 545 |
(setq redirect-uri (match-string 1 redirect-uri))) |
|---|
| 546 |
(if (string-match "^<\\(.*\\)>$" redirect-uri) |
|---|
| 547 |
(setq redirect-uri (match-string 1 redirect-uri))) |
|---|
| 548 |
|
|---|
| 549 |
|
|---|
| 550 |
|
|---|
| 551 |
|
|---|
| 552 |
(if (not (string-match url-nonrelative-link redirect-uri)) |
|---|
| 553 |
|
|---|
| 554 |
|
|---|
| 555 |
(setq redirect-uri |
|---|
| 556 |
(url-expand-file-name redirect-uri url-http-target-url))) |
|---|
| 557 |
(let ((url-request-method url-http-method) |
|---|
| 558 |
(url-request-data url-http-data) |
|---|
| 559 |
(url-request-extra-headers url-http-extra-headers)) |
|---|
| 560 |
|
|---|
| 561 |
(if (or (< url-max-redirections 0) |
|---|
| 562 |
(and (> url-max-redirections 0) |
|---|
| 563 |
(let ((events (car url-callback-arguments)) |
|---|
| 564 |
(old-redirects 0)) |
|---|
| 565 |
(while events |
|---|
| 566 |
(if (eq (car events) :redirect) |
|---|
| 567 |
(setq old-redirects (1+ old-redirects))) |
|---|
| 568 |
(and (setq events (cdr events)) |
|---|
| 569 |
(setq events (cdr events)))) |
|---|
| 570 |
(< old-redirects url-max-redirections)))) |
|---|
| 571 |
|
|---|
| 572 |
|
|---|
| 573 |
(progn |
|---|
| 574 |
|
|---|
| 575 |
(setf (car url-callback-arguments) |
|---|
| 576 |
(nconc (list :redirect redirect-uri) |
|---|
| 577 |
(car url-callback-arguments))) |
|---|
| 578 |
|
|---|
| 579 |
|
|---|
| 580 |
|
|---|
| 581 |
|
|---|
| 582 |
|
|---|
| 583 |
|
|---|
| 584 |
(set (make-local-variable 'url-redirect-buffer) |
|---|
| 585 |
(url-retrieve-internal |
|---|
| 586 |
redirect-uri url-callback-function |
|---|
| 587 |
url-callback-arguments)) |
|---|
| 588 |
(url-mark-buffer-as-dead buffer)) |
|---|
| 589 |
|
|---|
| 590 |
|
|---|
| 591 |
(url-http-debug "Maximum redirections reached") |
|---|
| 592 |
(setf (car url-callback-arguments) |
|---|
| 593 |
(nconc (list :error (list 'error 'http-redirect-limit |
|---|
| 594 |
redirect-uri)) |
|---|
| 595 |
(car url-callback-arguments))) |
|---|
| 596 |
(setq success t)))))) |
|---|
| 597 |
(4 |
|---|
| 598 |
|
|---|
| 599 |
|
|---|
| 600 |
|
|---|
| 601 |
|
|---|
| 602 |
|
|---|
| 603 |
|
|---|
| 604 |
|
|---|
| 605 |
|
|---|
| 606 |
|
|---|
| 607 |
|
|---|
| 608 |
|
|---|
| 609 |
|
|---|
| 610 |
|
|---|
| 611 |
|
|---|
| 612 |
|
|---|
| 613 |
|
|---|
| 614 |
|
|---|
| 615 |
|
|---|
| 616 |
|
|---|
| 617 |
|
|---|
| 618 |
|
|---|
| 619 |
(case url-http-response-status |
|---|
| 620 |
(401 |
|---|
| 621 |
|
|---|
| 622 |
|
|---|
| 623 |
|
|---|
| 624 |
|
|---|
| 625 |
|
|---|
| 626 |
(url-http-handle-authentication nil)) |
|---|
| 627 |
(402 |
|---|
| 628 |
|
|---|
| 629 |
(url-mark-buffer-as-dead buffer) |
|---|
| 630 |
(error "Somebody wants you to give them money")) |
|---|
| 631 |
(403 |
|---|
| 632 |
|
|---|
| 633 |
|
|---|
| 634 |
|
|---|
| 635 |
(setq success t)) |
|---|
| 636 |
(404 |
|---|
| 637 |
|
|---|
| 638 |
(setq success t)) |
|---|
| 639 |
(405 |
|---|
| 640 |
|
|---|
| 641 |
|
|---|
| 642 |
|
|---|
| 643 |
|
|---|
| 644 |
(setq success t)) |
|---|
| 645 |
(406 |
|---|
| 646 |
|
|---|
| 647 |
|
|---|
| 648 |
|
|---|
| 649 |
|
|---|
| 650 |
(setq success t)) |
|---|
| 651 |
(407 |
|---|
| 652 |
|
|---|
| 653 |
|
|---|
| 654 |
|
|---|
| 655 |
|
|---|
| 656 |
|
|---|
| 657 |
(url-http-handle-authentication t)) |
|---|
| 658 |
(408 |
|---|
| 659 |
|
|---|
| 660 |
|
|---|
| 661 |
|
|---|
| 662 |
(setq success t)) |
|---|
| 663 |
(409 |
|---|
| 664 |
|
|---|
| 665 |
|
|---|
| 666 |
|
|---|
| 667 |
|
|---|
| 668 |
|
|---|
| 669 |
|
|---|
| 670 |
|
|---|
| 671 |
(setq success t)) |
|---|
| 672 |
(410 |
|---|
| 673 |
|
|---|
| 674 |
|
|---|
| 675 |
(setq success t)) |
|---|
| 676 |
(411 |
|---|
| 677 |
|
|---|
| 678 |
|
|---|
| 679 |
|
|---|
| 680 |
|
|---|
| 681 |
|
|---|
| 682 |
|
|---|
| 683 |
|
|---|
| 684 |
|
|---|
| 685 |
(setq success t)) |
|---|
| 686 |
(412 |
|---|
| 687 |
|
|---|
| 688 |
|
|---|
| 689 |
|
|---|
| 690 |
(setq success t)) |
|---|
| 691 |
((413 414) |
|---|
| 692 |
|
|---|
| 693 |
|
|---|
| 694 |
|
|---|
| 695 |
(setq success t)) |
|---|
| 696 |
(415 |
|---|
| 697 |
|
|---|
| 698 |
|
|---|
|
|---|