|
14
|
1 ;;; url-http.el --- HTTP Uniform Resource Locator retrieval code
|
|
|
2 ;; Author: wmperry
|
|
120
|
3 ;; Created: 1997/04/07 13:24:34
|
|
|
4 ;; Version: 1.18
|
|
14
|
5 ;; Keywords: comm, data, processes
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
|
|
82
|
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
|
|
14
|
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))))
|
|
98
|
136 (proxy-obj (if (and (boundp 'proxy-info) proxy-info)
|
|
86
|
137 (url-generic-parse-url proxy-info)))
|
|
|
138 (real-fname (if proxy-obj (url-filename proxy-obj) fname))
|
|
|
139 (host (or (and proxy-obj (url-host proxy-obj))
|
|
102
|
140 (url-host url-current-object)))
|
|
14
|
141 (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
|
|
|
142 nil
|
|
|
143 (url-get-authentication (or
|
|
|
144 (and (boundp 'proxy-info)
|
|
|
145 proxy-info)
|
|
|
146 url) nil 'any nil))))
|
|
|
147 (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
|
|
|
148 (if auth
|
|
|
149 (setq auth (concat "Authorization: " auth "\r\n")))
|
|
|
150 (if proxy-auth
|
|
|
151 (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
|
|
|
152
|
|
|
153 (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
|
|
|
154 (string= ref-url "")))
|
|
|
155 (setq ref-url nil))
|
|
|
156
|
|
|
157 (if (or (memq url-privacy-level '(low high paranoid))
|
|
|
158 (and (listp url-privacy-level)
|
|
|
159 (memq 'lastloc url-privacy-level)))
|
|
|
160 (setq ref-url nil))
|
|
|
161
|
|
|
162 (setq extra-headers (mapconcat
|
|
|
163 (function (lambda (x)
|
|
|
164 (concat (car x) ": " (cdr x))))
|
|
|
165 url-request-extra-headers "\r\n"))
|
|
|
166 (if (not (equal extra-headers ""))
|
|
|
167 (setq extra-headers (concat extra-headers "\r\n")))
|
|
|
168 (setq request
|
|
|
169 (format
|
|
|
170 (concat
|
|
|
171 "%s %s HTTP/1.0\r\n" ; The request
|
|
|
172 "MIME-Version: 1.0\r\n" ; Version of MIME we speaketh
|
|
|
173 "Extension: %s\r\n" ; HTTP extensions we support
|
|
|
174 "Host: %s\r\n" ; Who we want to talk to
|
|
|
175 "%s" ; Who its from
|
|
|
176 "Accept-encoding: %s\r\n" ; Encodings we understand
|
|
|
177 "Accept-language: %s\r\n" ; Languages we understand
|
|
|
178 "Accept: %s\r\n" ; Types we understand
|
|
|
179 "%s" ; User agent
|
|
|
180 "%s" ; Authorization
|
|
|
181 "%s" ; Cookies
|
|
|
182 "%s" ; Proxy Authorization
|
|
|
183 "%s" ; If-modified-since
|
|
|
184 "%s" ; Where we came from
|
|
|
185 "%s" ; Any extra headers
|
|
|
186 "%s" ; Any data
|
|
|
187 "\r\n") ; End request
|
|
|
188 (or url-request-method "GET")
|
|
|
189 fname
|
|
|
190 (or url-extensions-header "none")
|
|
|
191 (or host "UNKNOWN.HOST.NAME")
|
|
|
192 (if url-personal-mail-address
|
|
|
193 (concat "From: " url-personal-mail-address "\r\n")
|
|
|
194 "")
|
|
|
195 url-mime-encoding-string
|
|
|
196 url-mime-language-string
|
|
|
197 url-mime-accept-string
|
|
|
198 (url-http-user-agent-string)
|
|
|
199 (or auth "")
|
|
102
|
200 (url-cookie-generate-header-lines
|
|
|
201 host real-fname (equal "https" (url-type url-current-object)))
|
|
14
|
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...")
|
|
108
|
402 (url-cache-extract (url-cache-create-filename (url-view-url t))))
|
|
14
|
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 ((url-auth-registered type)
|
|
|
417 (let ((args y)
|
|
|
418 (ctr (1- (length y)))
|
|
|
419 auth
|
|
|
420 (url-request-extra-headers url-request-extra-headers))
|
|
|
421 (while (/= 0 ctr)
|
|
|
422 (if (= ?, (aref args ctr))
|
|
|
423 (aset args ctr ?\;))
|
|
|
424 (setq ctr (1- ctr)))
|
|
|
425 (setq args (mm-parse-args y)
|
|
|
426 auth (url-get-authentication url
|
|
|
427 (cdr-safe
|
|
|
428 (assoc "realm" args))
|
|
|
429 type t args))
|
|
|
430 (if auth
|
|
|
431 (setq url-request-extra-headers
|
|
|
432 (cons (cons "Authorization" auth)
|
|
|
433 url-request-extra-headers)))
|
|
|
434 (url-retrieve url t)))
|
|
|
435 (t
|
|
|
436 (widen)
|
|
|
437 (goto-char (point-max))
|
|
|
438 (setq url-current-can-be-cached nil)
|
|
|
439 (insert "<hr>Sorry, but I do not know how to handle " y
|
|
|
440 " authentication. If you'd like to write it,"
|
|
|
441 " send it to " url-bug-address ".<hr>")))))
|
|
|
442 ((= status 407) ; Proxy authentication required
|
|
|
443 (let* ((y (or (cdr (assoc "proxy-authenticate" result)) "basic"))
|
|
|
444 (url (url-view-url t))
|
|
118
|
445 (urlobj (url-generic-parse-url url))
|
|
14
|
446 (url-basic-auth-storage url-proxy-basic-authentication)
|
|
118
|
447 (url-using-proxy (url-find-proxy-for-url urlobj
|
|
|
448 (url-host urlobj)))
|
|
14
|
449 (type (downcase (if (string-match "[ \t]" y)
|
|
|
450 (substring y 0 (match-beginning 0))
|
|
|
451 y))))
|
|
|
452 (cond
|
|
|
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 (let* ((server (url-host urlobj))
|
|
|
535 (port (url-port urlobj))
|
|
|
536 (file (or proxy-info (url-recreate-with-attributes urlobj)))
|
|
|
537 (dest (url-target urlobj))
|
|
|
538 request)
|
|
|
539 (if (equal port "") (setq port "80"))
|
|
|
540 (if (equal file "") (setq file "/"))
|
|
|
541 (if (not server)
|
|
|
542 (progn
|
|
|
543 (url-warn
|
|
|
544 'url
|
|
|
545 (eval-when-compile
|
|
|
546 (concat
|
|
|
547 "Malformed URL got passed into url-retrieve.\n"
|
|
|
548 "Either `url-expand-file-name' is broken in some\n"
|
|
|
549 "way, or an incorrect URL was manually entered (more likely)."
|
|
|
550 )))
|
|
|
551 (error "Malformed URL: `%s'" url)))
|
|
|
552 (if (or (not (member port url-bad-port-list))
|
|
|
553 (funcall url-confirmation-func
|
|
|
554 (concat
|
|
|
555 "Warning! Trying to connect to port "
|
|
|
556 port
|
|
|
557 " - continue? ")))
|
|
|
558 (progn
|
|
102
|
559 (setq request (url-create-mime-request file ref-url))
|
|
14
|
560 (url-lazy-message "Contacting %s:%s" server port)
|
|
|
561 (let ((process
|
|
|
562 (url-open-stream "WWW" url-working-buffer server
|
|
|
563 (string-to-int port))))
|
|
98
|
564 (if (not (processp process))
|
|
|
565 nil
|
|
14
|
566 (progn
|
|
|
567 (url-process-put process 'url (or proxy-info url))
|
|
120
|
568 (set-process-sentinel process 'ignore)
|
|
14
|
569 (process-kill-without-query process)
|
|
|
570 (process-send-string process request)
|
|
|
571 (url-lazy-message "Request sent, waiting for response...")
|
|
82
|
572 (setq url-current-content-length nil)
|
|
|
573 (make-local-variable 'after-change-functions)
|
|
|
574 (add-hook 'after-change-functions 'url-after-change-function)
|
|
14
|
575 (if url-be-asynchronous
|
|
|
576 (set-process-sentinel process 'url-sentinel)
|
|
|
577 (unwind-protect
|
|
|
578 (save-excursion
|
|
|
579 (set-buffer url-working-buffer)
|
|
|
580 (while (memq (url-process-status process)
|
|
|
581 '(run open))
|
|
|
582 (url-accept-process-output process)))
|
|
|
583 (condition-case ()
|
|
|
584 (url-kill-process process)
|
|
|
585 (error nil))))
|
|
|
586 (if url-be-asynchronous
|
|
|
587 nil
|
|
|
588 (message "Retrieval complete.")
|
|
|
589 (remove-hook 'after-change-functions
|
|
|
590 'url-after-change-function))))))
|
|
|
591 (progn
|
|
|
592 (ding)
|
|
|
593 (url-warn 'security "Aborting connection to bad port..."))))))
|
|
|
594
|
|
|
595 (defun url-https (url)
|
|
|
596 ;; Retrieve a URL via SSL
|
|
|
597 (condition-case ()
|
|
|
598 (require 'ssl)
|
|
|
599 (error (error "Not configured for SSL, please read the info pages.")))
|
|
|
600 (let ((url-this-is-ssl t)
|
|
|
601 (url-gateway-method 'ssl))
|
|
|
602 (url-http url)))
|
|
|
603
|
|
|
604 (provide 'url-http)
|
