url.el 13.9 KB
Newer Older
1
;;; url.el --- Uniform Resource Locator retrieval tool  -*- lexical-binding: t -*-
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1996-1999, 2001, 2004-2017 Free Software Foundation,
Paul Eggert's avatar
Paul Eggert committed
4
;; Inc.
5

Stefan Monnier's avatar
Stefan Monnier committed
6
;; Author: Bill Perry <wmperry@gnu.org>
7
;; Maintainer: emacs-devel@gnu.org
Stefan Monnier's avatar
Stefan Monnier committed
8 9
;; Keywords: comm, data, processes, hypermedia

10 11
;; This file is part of GNU Emacs.
;;
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 15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

17 18 19 20
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; 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.  If not, see <http://www.gnu.org/licenses/>.
24 25

;;; Commentary:
Stefan Monnier's avatar
Stefan Monnier committed
26 27 28

;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes

29 30
;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
31

32 33
(require 'mailcap)

Stefan Monnier's avatar
Stefan Monnier committed
34 35 36 37 38 39 40 41 42 43 44 45 46 47
(eval-when-compile
  (require 'mm-decode)
  (require 'mm-view))

(require 'url-vars)
(require 'url-cookie)
(require 'url-history)
(require 'url-expand)
(require 'url-privacy)
(require 'url-methods)
(require 'url-proxy)
(require 'url-parse)
(require 'url-util)

48 49

(defcustom url-configuration-directory
50
  (locate-user-emacs-file "url/" ".url/")
51 52 53
  "Directory used by the URL package for cookies, history, etc."
  :type 'directory
  :group 'url)
Stefan Monnier's avatar
Stefan Monnier committed
54 55

(defun url-do-setup ()
Juanma Barranquero's avatar
Juanma Barranquero committed
56
  "Setup the URL package.
Stefan Monnier's avatar
Stefan Monnier committed
57 58 59 60 61 62
This is to avoid conflict with user settings if URL is dumped with
Emacs."
  (unless url-setup-done

    (mailcap-parse-mailcaps)
    (mailcap-parse-mimetypes)
63

Stefan Monnier's avatar
Stefan Monnier committed
64 65 66 67 68 69 70
    ;; Register all the authentication schemes we can handle
    (url-register-auth-scheme "basic" nil 4)
    (url-register-auth-scheme "digest" nil 7)

    (setq url-cookie-file
	  (or url-cookie-file
	      (expand-file-name "cookies" url-configuration-directory)))
71

Stefan Monnier's avatar
Stefan Monnier committed
72 73 74
    (setq url-history-file
	  (or url-history-file
	      (expand-file-name "history" url-configuration-directory)))
75

Stefan Monnier's avatar
Stefan Monnier committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
    ;; Parse the global history file if it exists, so that it can be used
    ;; for URL completion, etc.
    (url-history-parse-history)
    (url-history-setup-save-timer)

    ;; Ditto for cookies
    (url-cookie-setup-save-timer)
    (url-cookie-parse-file url-cookie-file)

    ;; Read in proxy gateways
    (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
			(or (getenv "NO_PROXY")
			    (getenv "no_PROXY")
			    (getenv "no_proxy")))))
      (if noproxy
	  (setq url-proxy-services
		(cons (cons "no_proxy"
			    (concat "\\("
				    (mapconcat
				     (lambda (x)
				       (cond
					((= x ?,) "\\|")
					((= x ? ) "")
					((= x ?.) (regexp-quote "."))
					((= x ?*) ".*")
					((= x ??) ".")
					(t (char-to-string x))))
				     noproxy "") "\\)"))
		      url-proxy-services))))

    (url-setup-privacy-info)
    (run-hooks 'url-load-hook)
    (setq url-setup-done t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieval functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
113 114 115 116 117 118 119

(defvar url-redirect-buffer nil
  "New buffer into which the retrieval will take place.
Sometimes while retrieving a URL, the URL library needs to use another buffer
than the one returned initially by `url-retrieve'.  In this case, it sets this
variable in the original buffer as a forwarding pointer.")

120 121 122
(defvar url-retrieve-number-of-calls 0)
(autoload 'url-cache-prune-cache "url-cache")

123
;;;###autoload
124
(defun url-retrieve (url callback &optional cbargs silent inhibit-cookies)
Stefan Monnier's avatar
Stefan Monnier committed
125
  "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
126 127 128
URL is either a string or a parsed URL.  If it is a string
containing characters that are not valid in a URI, those
characters are percent-encoded; see `url-encode-url'.
129 130

CALLBACK is called when the object has been completely retrieved, with
Stefan Monnier's avatar
Stefan Monnier committed
131
the current buffer containing the object, and any MIME headers associated
132
with it.  It is called as (apply CALLBACK STATUS CBARGS).
Chong Yidong's avatar
Chong Yidong committed
133 134 135
STATUS is a plist representing what happened during the request,
with most recent events first, or an empty list if no events have
occurred.  Each pair is one of:
136 137 138 139

\(:redirect REDIRECTED-TO) - the request was redirected to this URL
\(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
signaled with (signal ERROR-SYMBOL DATA).
Stefan Monnier's avatar
Stefan Monnier committed
140 141

Return the buffer URL will load into, or nil if the process has
142 143 144 145 146 147
already completed (i.e. URL was a mailto URL or similar; in this case
the callback is not called).

The variables `url-request-data', `url-request-method' and
`url-request-extra-headers' can be dynamically bound around the
request; dynamic binding of other variables doesn't necessarily
148 149
take effect.

150 151
If SILENT, then don't message progress reports and the like.
If INHIBIT-COOKIES, cookies will neither be stored nor sent to
152 153 154
the server.
If URL is a multibyte string, it will be encoded as utf-8 and
URL-encoded before it's used."
155 156 157 158 159 160 161 162 163 164
;;; XXX: There is code in Emacs that does dynamic binding
;;; of the following variables around url-retrieve:
;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
;;; url-confirmation-func, url-cookie-multiple-line,
;;; url-cookie-{{,secure-}storage,confirmation}
;;; url-standalone-mode and url-gateway-unplugged should work as
;;; usual.  url-confirmation-func is only used in nnwarchive.el and
;;; webmail.el; the latter should be updated.  Is
;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
;;; are (for now) only used in synchronous retrievals.
165 166
  (url-retrieve-internal url callback (cons nil cbargs) silent
			 inhibit-cookies))
167

168 169
(defun url-retrieve-internal (url callback cbargs &optional silent
				  inhibit-cookies)
170
  "Internal function; external interface is `url-retrieve'.
171 172
The callback function will receive an updated value of CBARGS as
arguments; its first element should be a plist specifying what has
Chong Yidong's avatar
Chong Yidong committed
173 174
happened so far during the request, as described in the docstring
of `url-retrieve' (if in doubt, specify nil).
175

176 177
If SILENT, don't message progress reports and the like.
If INHIBIT-COOKIES, cookies will neither be stored nor sent to
178 179 180
the server.
If URL is a multibyte string, it will be encoded as utf-8 and
URL-encoded before it's used."
Stefan Monnier's avatar
Stefan Monnier committed
181 182
  (url-do-setup)
  (url-gc-dead-buffers)
183 184 185
  (when (stringp url)
    (set-text-properties 0 (length url) nil url)
    (setq url (url-encode-url url)))
186
  (if (not (url-p url))
Stefan Monnier's avatar
Stefan Monnier committed
187 188 189 190 191
      (setq url (url-generic-parse-url url)))
  (if (not (functionp callback))
      (error "Must provide a callback function to url-retrieve"))
  (unless (url-type url)
    (error "Bad url: %s" (url-recreate-url url)))
192
  (setf (url-silent url) silent)
193
  (setf (url-use-cookies url) (not inhibit-cookies))
194 195
  ;; Once in a while, remove old entries from the URL cache.
  (when (zerop (% url-retrieve-number-of-calls 1000))
196 197 198 199
    (condition-case error
	(url-cache-prune-cache)
      (file-error
       (message "Error when expiring the cache: %s" error))))
200
  (setq url-retrieve-number-of-calls (1+ url-retrieve-number-of-calls))
Stefan Monnier's avatar
Stefan Monnier committed
201 202 203 204 205 206 207 208 209
  (let ((loader (url-scheme-get-property (url-type url) 'loader))
	(url-using-proxy (if (url-host url)
			     (url-find-proxy-for-url url (url-host url))))
	(buffer nil)
	(asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
    (if url-using-proxy
	(setq asynch t
	      loader 'url-proxy))
    (if asynch
210 211
	(let ((url-current-object url))
	  (setq buffer (funcall loader url callback cbargs)))
Stefan Monnier's avatar
Stefan Monnier committed
212 213
      (setq buffer (funcall loader url))
      (if buffer
214
	  (with-current-buffer buffer
Stefan Monnier's avatar
Stefan Monnier committed
215
	    (apply callback cbargs))))
216 217
    (if url-history-track
	(url-history-update-url url (current-time)))
Stefan Monnier's avatar
Stefan Monnier committed
218 219
    buffer))

220
;;;###autoload
221
(defun url-retrieve-synchronously (url &optional silent inhibit-cookies timeout)
Stefan Monnier's avatar
Stefan Monnier committed
222 223 224
  "Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
associated with it (the case for dired, info, or mailto URLs that need
225 226 227 228 229 230
no further processing).  URL is either a string or a parsed URL.

If SILENT is non-nil, don't do any messaging while retrieving.
If INHIBIT-COOKIES is non-nil, refuse to store cookies.  If
TIMEOUT is passed, it should be a number that says (in seconds)
how long to wait for a response before giving up."
Stefan Monnier's avatar
Stefan Monnier committed
231 232
  (url-do-setup)

233
  (let ((retrieval-done nil)
234
	(start-time (current-time))
235
        (asynch-buffer nil))
Stefan Monnier's avatar
Stefan Monnier committed
236 237 238 239
    (setq asynch-buffer
	  (url-retrieve url (lambda (&rest ignored)
			      (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
			      (setq retrieval-done t
240 241
				    asynch-buffer (current-buffer)))
			nil silent inhibit-cookies))
242 243 244 245 246 247 248 249 250 251 252 253 254 255
    (if (null asynch-buffer)
        ;; We do not need to do anything, it was a mailto or something
        ;; similar that takes processing completely outside of the URL
        ;; package.
        nil
      (let ((proc (get-buffer-process asynch-buffer)))
	;; If the access method was synchronous, `retrieval-done' should
	;; hopefully already be set to t.  If it is nil, and `proc' is also
	;; nil, it implies that the async process is not running in
	;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
	;; url-file.el should probably set something like a `url-process'
	;; buffer-local variable so we can find the exact process that we
	;; should be waiting for.  In the mean time, we'll just wait for any
	;; process output.
256 257 258 259 260
	(while (and (not retrieval-done)
                    (or (not timeout)
                        (< (float-time (time-subtract
                                        (current-time) start-time))
                           timeout)))
261 262 263
	  (url-debug 'retrieval
		     "Spinning in url-retrieve-synchronously: %S (%S)"
		     retrieval-done asynch-buffer)
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
          (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
              (setq proc (get-buffer-process
                          (setq asynch-buffer
                                (buffer-local-value 'url-redirect-buffer
                                                    asynch-buffer))))
            (if (and proc (memq (process-status proc)
                                '(closed exit signal failed))
                     ;; Make sure another process hasn't been started.
                     (eq proc (or (get-buffer-process asynch-buffer) proc)))
                ;; FIXME: It's not clear whether url-retrieve's callback is
                ;; guaranteed to be called or not.  It seems that url-http
                ;; decides sometimes consciously not to call it, so it's not
                ;; clear that it's a bug, but even then we need to decide how
                ;; url-http can then warn us that the download has completed.
                ;; In the mean time, we use this here workaround.
279 280 281
		;; XXX: The callback must always be called.  Any
		;; exception is a bug that should be fixed, not worked
		;; around.
282 283 284
		(progn ;; Call delete-process so we run any sentinel now.
		  (delete-process proc)
		  (setq retrieval-done t)))
285 286 287 288 289
            ;; We used to use `sit-for' here, but in some cases it wouldn't
            ;; work because apparently pending keyboard input would always
            ;; interrupt it before it got a chance to handle process input.
            ;; `sleep-for' was tried but it lead to other forms of
            ;; hanging.  --Stef
Paul Eggert's avatar
Paul Eggert committed
290
            (unless (or (with-local-quit
291
			  (accept-process-output proc 1))
292
			(null proc))
293
              ;; accept-process-output returned nil, maybe because the process
294 295 296 297 298 299
              ;; exited (and may have been replaced with another).  If we got
	      ;; a quit, just stop.
	      (when quit-flag
		(delete-process proc))
              (setq proc (and (not quit-flag)
			      (get-buffer-process asynch-buffer)))))))
Stefan Monnier's avatar
Stefan Monnier committed
300 301
      asynch-buffer)))

302 303 304
;; url-mm-callback called from url-mm, which requires mm-decode.
(declare-function mm-dissect-buffer "mm-decode"
		  (&optional no-strict-mime loose-mime from))
Glenn Morris's avatar
Glenn Morris committed
305 306
(declare-function mm-display-part "mm-decode"
		  (handle &optional no-default force))
307

Stefan Monnier's avatar
Stefan Monnier committed
308 309
(defun url-mm-callback (&rest ignored)
  (let ((handle (mm-dissect-buffer t)))
310 311 312
    (url-mark-buffer-as-dead (current-buffer))
    (with-current-buffer
        (generate-new-buffer (url-recreate-url url-current-object))
Stefan Monnier's avatar
Stefan Monnier committed
313 314 315 316 317 318 319 320 321 322 323
      (if (eq (mm-display-part handle) 'external)
	  (progn
	    (set-process-sentinel
	     ;; Fixme: this shouldn't have to know the form of the
	     ;; undisplayer produced by `mm-display-part'.
	     (get-buffer-process (cdr (mm-handle-undisplayer handle)))
	     `(lambda (proc event)
		(mm-destroy-parts (quote ,handle))))
	    (message "Viewing externally")
	    (kill-buffer (current-buffer)))
	(display-buffer (current-buffer))
324
	(add-hook 'kill-buffer-hook
325 326 327
		  `(lambda () (mm-destroy-parts ',handle))
		  nil
		  t)))))
Stefan Monnier's avatar
Stefan Monnier committed
328 329 330

(defun url-mm-url (url)
  "Retrieve URL and pass to the appropriate viewing application."
Stefan Monnier's avatar
Stefan Monnier committed
331 332 333
  ;; These requires could advantageously be moved to url-mm-callback or
  ;; turned into autoloads, but I suspect that it would introduce some bugs
  ;; because loading those files from a process sentinel or filter may
Paul Eggert's avatar
Paul Eggert committed
334
  ;; result in some undesirable corner cases.
Stefan Monnier's avatar
Stefan Monnier committed
335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360
  (require 'mm-decode)
  (require 'mm-view)
  (url-retrieve url 'url-mm-callback nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar url-dead-buffer-list nil)

(defun url-mark-buffer-as-dead (buff)
  (push buff url-dead-buffer-list))

(defun url-gc-dead-buffers ()
  (let ((buff))
    (while (setq buff (pop url-dead-buffer-list))
      (if (buffer-live-p buff)
	  (kill-buffer buff)))))

(cond
 ((fboundp 'display-warning)
  (defalias 'url-warn 'display-warning))
 ((fboundp 'warn)
  (defun url-warn (class message &optional level)
    (warn "(%s/%s) %s" class (or level 'warning) message)))
 (t
  (defun url-warn (class message &optional level)
361
    (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
Stefan Monnier's avatar
Stefan Monnier committed
362 363 364 365 366 367 368 369
      (goto-char (point-max))
      (save-excursion
	(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
      (display-buffer (current-buffer))))))

(provide 'url)

;;; url.el ends here