Mercurial > hg > xemacs-beta

comparison lisp/w3/url-http.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents
children 0293115a14e9 6a378aca36af
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;; url-http.el --- HTTP Uniform Resource Locator retrieval code
2 ;; Author: wmperry
3 ;; Created: 1996/12/18 00:38:45
4 ;; Version: 1.7
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
17 ;;;
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29 (require 'url-vars)
30 (require 'url-parse)
31 (require 'url-cookie)
32 (require 'timezone)
33
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;;; Support for HTTP/1.0 MIME messages
36 ;;; ----------------------------------
37 ;;; These functions are the guts of the HTTP/0.9 and HTTP/1.0 transfer
38 ;;; protocol, handling access authorization, format negotiation, the
39 ;;; whole nine yards.
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 (defun url-parse-viewer-types ()
42 "Create a string usable for an Accept: header from mm-mime-data"
43 (let ((tmp mm-mime-data)
44 label mjr mnr cur-mnr (str ""))
45 (while tmp
46 (setq mnr (cdr (car tmp))
47 mjr (car (car tmp))
48 tmp (cdr tmp))
49 (while mnr
50 (setq cur-mnr (car mnr)
51 label (concat mjr "/" (if (string= ".*" (car cur-mnr))
52 "*"
53 (car cur-mnr))))
54 (cond
55 ((string-match (regexp-quote label) str) nil)
56 ((> (+ (% (length str) 60)
57 (length (concat ", " mjr "/" (car cur-mnr)))) 60)
58 (setq str (format "%s\r\nAccept: %s" str label)))
59 (t
60 (setq str (format "%s, %s" str label))))
61 (setq mnr (cdr mnr))))
62 (substring str 2 nil)))
63
64 (defun url-create-multipart-request (file-list)
65 "Create a multi-part MIME request for all files in FILE-LIST"
66 (let ((separator (current-time-string))
67 (content "message/http-request")
68 (ref-url nil))
69 (setq separator
70 (concat "separator-"
71 (mapconcat
72 (function
73 (lambda (char)
74 (if (memq char url-mime-separator-chars)
75 (char-to-string char) ""))) separator "")))
76 (cons separator
77 (concat
78 (mapconcat
79 (function
80 (lambda (file)
81 (concat "--" separator "\nContent-type: " content "\n\n"
82 (url-create-mime-request file ref-url)))) file-list
83 "\n")
84 "--" separator))))
85
86 (defun url-create-message-id ()
87 "Generate a string suitable for the Message-ID field of a request"
88 (concat "<" (url-create-unique-id) "@" (system-name) ">"))
89
90 (defun url-create-unique-id ()
91 ;; Generate unique ID from user name and current time.
92 (let* ((date (current-time-string))
93 (name (user-login-name))
94 (dateinfo (and date (timezone-parse-date date)))
95 (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
96 (if (and dateinfo timeinfo)
97 (concat (upcase name) "."
98 (aref dateinfo 0) ; Year
99 (aref dateinfo 1) ; Month
100 (aref dateinfo 2) ; Day
101 (aref timeinfo 0) ; Hour
102 (aref timeinfo 1) ; Minute
103 (aref timeinfo 2) ; Second
104 )
105 (error "Cannot understand current-time-string: %s." date))
106 ))
107
108 (defun url-http-user-agent-string ()
109 (if (or (eq url-privacy-level 'paranoid)
110 (and (listp url-privacy-level)
111 (memq 'agent url-privacy-level)))
112 ""
113 (format "User-Agent: %s/%s URL/%s%s\r\n"
114 url-package-name url-package-version
115 url-version
116 (cond
117 ((and url-os-type url-system-type)
118 (concat " (" url-os-type "; " url-system-type ")"))
119 ((or url-os-type url-system-type)
120 (concat " (" (or url-system-type url-os-type) ")"))
121 (t "")))))
122
123 (defun url-create-mime-request (fname ref-url)
124 "Create a MIME request for fname, referred to by REF-URL."
125 (let* ((extra-headers)
126 (request nil)
127 (url (url-view-url t))
128 (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
129 (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
130 url-request-extra-headers))
131 (not (boundp 'proxy-info)))
132 nil
133 (let ((url-basic-auth-storage
134 url-proxy-basic-authentication))
135 (url-get-authentication url nil 'any nil))))
136 (host (if (boundp 'proxy-info)
137 (url-host (url-generic-parse-url proxy-info))
138 url-current-server))
139 (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
140 nil
141 (url-get-authentication (or
142 (and (boundp 'proxy-info)
143 proxy-info)
144 url) nil 'any nil))))
145 (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
146 (if auth
147 (setq auth (concat "Authorization: " auth "\r\n")))
148 (if proxy-auth
149 (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
150
151 (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
152 (string= ref-url "")))
153 (setq ref-url nil))
154
155 (if (or (memq url-privacy-level '(low high paranoid))
156 (and (listp url-privacy-level)
157 (memq 'lastloc url-privacy-level)))
158 (setq ref-url nil))
159
160 (setq extra-headers (mapconcat
161 (function (lambda (x)
162 (concat (car x) ": " (cdr x))))
163 url-request-extra-headers "\r\n"))
164 (if (not (equal extra-headers ""))
165 (setq extra-headers (concat extra-headers "\r\n")))
166 (setq request
167 (format
168 (concat
169 "%s %s HTTP/1.0\r\n" ; The request
170 "MIME-Version: 1.0\r\n" ; Version of MIME we speaketh
171 "Extension: %s\r\n" ; HTTP extensions we support
172 "Host: %s\r\n" ; Who we want to talk to
173 "%s" ; Who its from
174 "Accept-encoding: %s\r\n" ; Encodings we understand
175 "Accept-language: %s\r\n" ; Languages we understand
176 "Accept: %s\r\n" ; Types we understand
177 "%s" ; User agent
178 "%s" ; Authorization
179 "%s" ; Cookies
180 "%s" ; Proxy Authorization
181 "%s" ; If-modified-since
182 "%s" ; Where we came from
183 "%s" ; Any extra headers
184 "%s" ; Any data
185 "\r\n") ; End request
186 (or url-request-method "GET")
187 fname
188 (or url-extensions-header "none")
189 (or host "UNKNOWN.HOST.NAME")
190 (if url-personal-mail-address
191 (concat "From: " url-personal-mail-address "\r\n")
192 "")
193 url-mime-encoding-string
194 url-mime-language-string
195 url-mime-accept-string
196 (url-http-user-agent-string)
197 (or auth "")
198 (url-cookie-generate-header-lines url-current-server
199 fname
200 (string-match "https"
201 url-current-type))
202 (or proxy-auth "")
203 (if (and (not no-cache)
204 (member url-request-method '("GET" nil)))
205 (let ((tm (url-is-cached url)))
206 (if tm
207 (concat "If-modified-since: "
208 (url-get-normalized-date tm) "\r\n")
209 ""))
210 "")
211 (if ref-url (concat "Referer: " ref-url "\r\n") "")
212 extra-headers
213 (if url-request-data
214 (format "Content-length: %d\r\n\r\n%s"
215 (length url-request-data) url-request-data)
216 "")))
217 request))
218
219 (defun url-setup-reload-timer (url must-be-viewing &optional time)
220 ;; Set up a timer to load URL at optional TIME. If TIME is unspecified,
221 ;; default to 5 seconds. Only loads document if MUST-BE-VIEWING is the
222 ;; current URL when the timer expires."
223 (if (or (not time)
224 (<= time 0))
225 (setq time 5))
226 (let ((func
227 (` (lambda ()
228 (if (equal (url-view-url t) (, must-be-viewing))
229 (let ((w3-reuse-buffers 'no))
230 (if (equal (, url) (url-view-url t))
231 (kill-buffer (current-buffer)))
232 (w3-fetch (, url))))))))
233 (cond
234 ((featurep 'itimer)
235 (start-itimer "reloader" func time))
236 ((fboundp 'run-at-time)
237 (run-at-time time nil func))
238 (t
239 (url-warn 'url "Cannot set up timer for automatic reload, sorry!")))))
240
241 (defun url-handle-refresh-header (reload)
242 (if (and reload
243 url-honor-refresh-requests
244 (or (eq url-honor-refresh-requests t)
245 (funcall url-confirmation-func "Honor refresh request? ")))
246 (let ((uri (url-view-url t)))
247 (if (string-match ";" reload)
248 (progn
249 (setq uri (substring reload (match-end 0) nil)
250 reload (substring reload 0 (match-beginning 0)))
251 (if (string-match
252 "ur[li][ \t]*=[ \t]*\"*\\([^ \t\"]+\\)\"*"
253 uri)
254 (setq uri (url-match uri 1)))
255 (setq uri (url-expand-file-name uri (url-view-url t)))))
256 (url-setup-reload-timer uri (url-view-url t)
257 (string-to-int (or reload "5"))))))
258
259 (defun url-parse-mime-headers (&optional no-delete switch-buff)
260 ;; Parse mime headers and remove them from the html
261 (and switch-buff (set-buffer url-working-buffer))
262 (let* ((st (point-min))
263 (nd (progn
264 (goto-char (point-min))
265 (skip-chars-forward " \t\n")
266 (if (re-search-forward "^\r*$" nil t)
267 (1+ (point))
268 (point-max))))
269 save-pos
270 status
271 class
272 hname
273 hvalu
274 result
275 )
276 (narrow-to-region st (min nd (point-max)))
277 (goto-char (point-min))
278 (skip-chars-forward " \t\n") ; Get past any blank crap
279 (skip-chars-forward "^ \t") ; Skip over the HTTP/xxx
280 (setq status (read (current-buffer)); Quicker than buffer-substring, etc.
281 result (cons (cons "status" status) result))
282 (end-of-line)
283 (while (not (eobp))
284 (skip-chars-forward " \t\n\r")
285 (setq save-pos (point))
286 (skip-chars-forward "^:\n\r")
287 (downcase-region save-pos (point))
288 (setq hname (buffer-substring save-pos (point)))
289 (skip-chars-forward ": \t ")
290 (setq save-pos (point))
291 (skip-chars-forward "^\n\r")
292 (setq hvalu (buffer-substring save-pos (point))
293 result (cons (cons hname hvalu) result))
294 (if (string= hname "set-cookie")
295 (url-cookie-handle-set-cookie hvalu)))
296 (or no-delete (delete-region st (min nd (point))))
297 (setq url-current-mime-type (cdr (assoc "content-type" result))
298 url-current-mime-encoding (cdr (assoc "content-encoding" result))
299 url-current-mime-viewer (mm-mime-info url-current-mime-type nil t)
300 url-current-mime-headers result
301 url-current-can-be-cached
302 (not (string-match "no-cache"
303 (or (cdr-safe (assoc "pragma" result)) ""))))
304 (url-handle-refresh-header (cdr-safe (assoc "refresh" result)))
305 (if (and url-request-method
306 (not (string= url-request-method "GET")))
307 (setq url-current-can-be-cached nil))
308 (let ((expires (cdr-safe (assoc "expires" result))))
309 (if (and expires url-current-can-be-cached (featurep 'timezone))
310 (progn
311 (if (string-match
312 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
313 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
314 expires)
315 (setq expires (concat (url-match expires 1) " "
316 (url-match expires 2) " "
317 (url-match expires 3) " "
318 (url-match expires 4) " ["
319 (url-match expires 5) "]")))
320 (setq expires
321 (let ((d1 (mapcar
322 (function
323 (lambda (s) (and s (string-to-int s))))
324 (timezone-parse-date
325 (current-time-string))))
326 (d2 (mapcar
327 (function (lambda (s) (and s (string-to-int s))))
328 (timezone-parse-date expires))))
329 (- (timezone-absolute-from-gregorian
330 (nth 1 d1) (nth 2 d1) (car d1))
331 (timezone-absolute-from-gregorian
332 (nth 1 d2) (nth 2 d2) (car d2))))
333 url-current-can-be-cached (/= 0 expires)))))
334 (setq class (/ status 100))
335 (cond
336 ;; Classes of response codes
337 ;;
338 ;; 5xx = Server Error
339 ;; 4xx = Client Error
340 ;; 3xx = Redirection
341 ;; 2xx = Successful
342 ;; 1xx = Informational
343 ;;
344 ((= class 2) ; Successful in some form or another
345 (cond
346 ((or (= status 206) ; Partial content
347 (= status 205)) ; Reset content
348 (setq url-current-can-be-cached nil))
349 ((= status 204) ; No response - leave old document
350 (kill-buffer url-working-buffer))
351 (t nil)) ; All others indicate success
352 )
353 ((= class 3) ; Redirection of some type
354 (cond
355 ((or (= status 301) ; Moved - retry with Location: header
356 (= status 302) ; Found - retry with Location: header
357 (= status 303)) ; Method - retry with location/method
358 (let ((x (url-view-url t))
359 (redir (or (cdr (assoc "uri" result))
360 (cdr (assoc "location" result))))
361 (redirmeth (upcase (or (cdr (assoc "method" result))
362 url-request-method
363 "get"))))
364 (if (and redir (string-match "\\([^ \t]+\\)[ \t]" redir))
365 (setq redir (url-match redir 1)))
366 (if (and redir (string-match "^<\\(.*\\)>$" redir))
367 (setq redir (url-match redir 1)))
368
369 ;; As per Roy Fielding, 303 maps _any_ method to a 'GET'
370 (if (= 303 status)
371 (setq redirmeth "GET"))
372
373 ;; As per Roy Fielding, 301, 302 use the same method as the
374 ;; original request, but if != GET, user interaction is
375 ;; required.
376 (if (and (not (string= "GET" redirmeth))
377 (not (funcall
378 url-confirmation-func
379 (concat
380 "Honor redirection with non-GET method "
381 "(possible security risks)? "))))
382 (progn
383 (url-warn 'url
384 (format
385 "The URL %s tried to issue a redirect to %s using a method other than
386 GET, which can open up various security holes. Please see the
387 HTTP/1.0 specification for more details." x redir) 'error)
388 (if (funcall url-confirmation-func
389 "Continue (with method of GET)? ")
390 (setq redirmeth "GET")
391 (error "Transaction aborted."))))
392
393 (if (not (equal x redir))
394 (let ((url-request-method redirmeth))
395 (url-maybe-relative redir))
396 (progn
397 (goto-char (point-max))
398 (insert "<hr>Error! This URL tried to redirect me to itself!<P>"
399 "Please notify the server maintainer.")))))
400 ((= status 304) ; Cached document is newer
401 (message "Extracting from cache...")
402 (url-extract-from-cache (url-create-cached-filename (url-view-url t))))
403 ((= status 305) ; Use proxy in Location: header
404 nil)))
405 ((= class 4) ; Client error
406 (cond
407 ((and (= status 401) ; Unauthorized access, retry w/auth.
408 (< url-current-passwd-count url-max-password-attempts))
409 (setq url-current-passwd-count (1+ url-current-passwd-count))
410 (let* ((y (or (cdr (assoc "www-authenticate" result)) "basic"))
411 (url (url-view-url t))
412 (type (downcase (if (string-match "[ \t]" y)
413 (substring y 0 (match-beginning 0))
414 y))))
415 (cond
416 ((or (equal "pem" type) (equal "pgp" type))
417 (if (string-match "entity=\"\\([^\"]+\\)\"" y)
418 (url-fetch-with-pgp url-current-file
419 (url-match y 1) (intern type))
420 (error "Could not find entity in %s!" type)))
421 ((url-auth-registered type)
422 (let ((args y)
423 (ctr (1- (length y)))
424 auth
425 (url-request-extra-headers url-request-extra-headers))
426 (while (/= 0 ctr)
427 (if (= ?, (aref args ctr))
428 (aset args ctr ?\;))
429 (setq ctr (1- ctr)))
430 (setq args (mm-parse-args y)
431 auth (url-get-authentication url
432 (cdr-safe
433 (assoc "realm" args))
434 type t args))
435 (if auth
436 (setq url-request-extra-headers
437 (cons (cons "Authorization" auth)
438 url-request-extra-headers)))
439 (url-retrieve url t)))
440 (t
441 (widen)
442 (goto-char (point-max))
443 (setq url-current-can-be-cached nil)
444 (insert "<hr>Sorry, but I do not know how to handle " y
445 " authentication. If you'd like to write it,"
446 " send it to " url-bug-address ".<hr>")))))
447 ((= status 407) ; Proxy authentication required
448 (let* ((y (or (cdr (assoc "proxy-authenticate" result)) "basic"))
449 (url (url-view-url t))
450 (url-basic-auth-storage url-proxy-basic-authentication)
451 (type (downcase (if (string-match "[ \t]" y)
452 (substring y 0 (match-beginning 0))
453 y))))
454 (cond
455 ((or (equal "pem" type) (equal "pgp" type))
456 (if (string-match "entity=\"\\([^\"]+\\)\"" y)
457 (url-fetch-with-pgp url-current-file
458 (url-match y 1) (intern type))
459 (error "Could not find entity in %s!" type)))
460 ((url-auth-registered type)
461 (let ((args y)
462 (ctr (1- (length y)))
463 auth
464 (url-request-extra-headers url-request-extra-headers))
465 (while (/= 0 ctr)
466 (if (= ?, (aref args ctr))
467 (aset args ctr ?\;))
468 (setq ctr (1- ctr)))
469 (setq args (mm-parse-args y)
470 auth (url-get-authentication (or url-using-proxy url)
471 (cdr-safe
472 (assoc "realm" args))
473 type t args))
474 (if auth
475 (setq url-request-extra-headers
476 (cons (cons "Proxy-Authorization" auth)
477 url-request-extra-headers)))
478 (setq url-proxy-basic-authentication url-basic-auth-storage)
479 (url-retrieve url t)))
480 (t
481 (widen)
482 (goto-char (point-max))
483 (setq url-current-can-be-cached nil)
484 (insert "<hr>Sorry, but I do not know how to handle " y
485 " authentication. If you'd like to write it,"
486 " send it to " url-bug-address ".<hr>")))))
487 ;;((= status 400) nil) ; Bad request - syntax
488 ;;((= status 401) nil) ; Tried too many times
489 ;;((= status 402) nil) ; Payment required, retry w/Chargeto:
490 ;;((= status 403) nil) ; Access is forbidden
491 ;;((= status 404) nil) ; Not found...
492 ;;((= status 405) nil) ; Method not allowed
493 ;;((= status 406) nil) ; None acceptable
494 ;;((= status 408) nil) ; Request timeout
495 ;;((= status 409) nil) ; Conflict
496 ;;((= status 410) nil) ; Document is gone
497 ;;((= status 411) nil) ; Length required
498 ;;((= status 412) nil) ; Unless true
499 (t ; All others mena something hosed
500 (setq url-current-can-be-cached nil))))
501 ((= class 5)
502 ;;; (= status 504) ; Gateway timeout
503 ;;; (= status 503) ; Service unavailable
504 ;;; (= status 502) ; Bad gateway
505 ;;; (= status 501) ; Facility not supported
506 ;;; (= status 500) ; Internal server error
507 (setq url-current-can-be-cached nil))
508 ((= class 1)
509 (cond
510 ((or (= status 100) ; Continue
511 (= status 101)) ; Switching protocols
512 nil)))
513 (t
514 (setq url-current-can-be-cached nil)))
515 (widen)
516 status))
517
518 (defun url-mime-response-p (&optional switch-buff)
519 ;; Determine if the current buffer is a MIME response
520 (and switch-buff (set-buffer url-working-buffer))
521 (goto-char (point-min))
522 (skip-chars-forward " \t\n")
523 (and (looking-at "^HTTP/.+")))
524
525 (defsubst url-recreate-with-attributes (obj)
526 (if (url-attributes obj)
527 (concat (url-filename obj) ";"
528 (mapconcat
529 (function
530 (lambda (x)
531 (if (cdr x)
532 (concat (car x) "=" (cdr x))
533 (car x)))) (url-attributes obj) ";"))
534 (url-filename obj)))
535
536 (defun url-http (url &optional proxy-info)
537 ;; Retrieve URL via http.
538 (let* ((urlobj (url-generic-parse-url url))
539 (ref-url (or url-current-referer (url-view-url t))))
540 (url-clear-tmp-buffer)
541 (setq url-current-type (if (boundp 'url-this-is-ssl)
542 "https" "http"))
543 (let* ((server (url-host urlobj))
544 (port (url-port urlobj))
545 (file (or proxy-info (url-recreate-with-attributes urlobj)))
546 (dest (url-target urlobj))
547 request)
548 (if (equal port "") (setq port "80"))
549 (if (equal file "") (setq file "/"))
550 (if (not server)
551 (progn
552 (url-warn
553 'url
554 (eval-when-compile
555 (concat
556 "Malformed URL got passed into url-retrieve.\n"
557 "Either `url-expand-file-name' is broken in some\n"
558 "way, or an incorrect URL was manually entered (more likely)."
559 )))
560 (error "Malformed URL: `%s'" url)))
561 (if proxy-info
562 (let ((x (url-generic-parse-url url)))
563 (setq url-current-server (url-host urlobj)
564 url-current-port (url-port urlobj)
565 url-current-file (url-filename urlobj)
566 url-find-this-link (url-target urlobj)
567 request (url-create-mime-request file ref-url)))
568 (setq url-current-server server
569 url-current-port port
570 url-current-file file
571 url-find-this-link dest
572 request (url-create-mime-request file ref-url)))
573 (if (or (not (member port url-bad-port-list))
574 (funcall url-confirmation-func
575 (concat
576 "Warning! Trying to connect to port "
577 port
578 " - continue? ")))
579 (progn
580 (url-lazy-message "Contacting %s:%s" server port)
581 (let ((process
582 (url-open-stream "WWW" url-working-buffer server
583 (string-to-int port))))
584 (if (stringp process)
585 (progn
586 (set-buffer url-working-buffer)
587 (erase-buffer)
588 (setq url-current-mime-type "text/html"
589 url-current-mime-viewer
590 (mm-mime-info "text/html" nil 5))
591 (insert "<title>ERROR</title>\n"
592 "<h1>ERROR - Could not establish connection</h1>"
593 "<p>"
594 "The browser could not establish a connection "
595 (format "to %s:%s.<P>" server port)
596 "The server is either down, or the URL"
597 (format "(%s) is malformed.<p>" (url-view-url t)))
598 (message "%s" process))
599 (progn
600 (url-process-put process 'url (or proxy-info url))
601 (process-kill-without-query process)
602 (process-send-string process request)
603 (url-lazy-message "Request sent, waiting for response...")
604 (if url-show-http2-transfer
605 (progn
606 (make-local-variable 'after-change-functions)
607 (setq url-current-content-length nil)
608 (add-hook 'after-change-functions
609 'url-after-change-function)))
610 (if url-be-asynchronous
611 (set-process-sentinel process 'url-sentinel)
612 (unwind-protect
613 (save-excursion
614 (set-buffer url-working-buffer)
615 (while (memq (url-process-status process)
616 '(run open))
617 (url-accept-process-output process)))
618 (condition-case ()
619 (url-kill-process process)
620 (error nil))))
621 (if url-be-asynchronous
622 nil
623 (message "Retrieval complete.")
624 (remove-hook 'after-change-functions
625 'url-after-change-function))))))
626 (progn
627 (ding)
628 (url-warn 'security "Aborting connection to bad port..."))))))
629
630 (defun url-shttp (url)
631 ;; Retrieve a URL via Secure-HTTP
632 (error "Secure-HTTP not implemented yet."))
633
634 (defun url-https (url)
635 ;; Retrieve a URL via SSL
636 (condition-case ()
637 (require 'ssl)
638 (error (error "Not configured for SSL, please read the info pages.")))
639 (let ((url-this-is-ssl t)
640 (url-gateway-method 'ssl))
641 (url-http url)))
642
643 (provide 'url-http)