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