lisp/url/url.el

   1 ;;; url.el --- Uniform Resource Locator retrieval tool  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 1996-1999, 2001, 2004-2018 Free Software Foundation,
   4 ;; Inc.
   5
   6 ;; Author: Bill Perry <wmperry@gnu.org>
   7 ;; Maintainer: emacs-devel@gnu.org
   8 ;; Keywords: comm, data, processes, hypermedia
   9
  10 ;; This file is part of GNU Emacs.
  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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
  28
  29 ;;; Code:
  30
  31
  32 (require 'mailcap)
  33
  34 (eval-when-compile
  35   (require 'mm-decode)
  36   (require 'mm-view))
  37
  38 (require 'url-vars)
  39 (require 'url-cookie)
  40 (require 'url-history)
  41 (require 'url-expand)
  42 (require 'url-privacy)
  43 (require 'url-methods)
  44 (require 'url-proxy)
  45 (require 'url-parse)
  46 (require 'url-util)
  47
  48
  49 (defcustom url-configuration-directory
  50   (locate-user-emacs-file "url/" ".url/")
  51   "Directory used by the URL package for cookies, history, etc."
  52   :type 'directory
  53   :group 'url)
  54
  55 (defun url-do-setup ()
  56   "Setup the URL package.
  57 This is to avoid conflict with user settings if URL is dumped with
  58 Emacs."
  59   (unless url-setup-done
  60
  61     (mailcap-parse-mailcaps)
  62     (mailcap-parse-mimetypes)
  63
  64     ;; Register all the authentication schemes we can handle
  65     (url-register-auth-scheme "basic" nil 4)
  66     (url-register-auth-scheme "digest" nil 7)
  67
  68     (setq url-cookie-file
  69           (or url-cookie-file
  70               (expand-file-name "cookies" url-configuration-directory)))
  71
  72     (setq url-history-file
  73           (or url-history-file
  74               (expand-file-name "history" url-configuration-directory)))
  75
  76     ;; Parse the global history file if it exists, so that it can be used
  77     ;; for URL completion, etc.
  78     (url-history-parse-history)
  79     (url-history-setup-save-timer)
  80
  81     ;; Ditto for cookies
  82     (url-cookie-setup-save-timer)
  83     (url-cookie-parse-file url-cookie-file)
  84
  85     ;; Read in proxy gateways
  86     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  87                         (or (getenv "NO_PROXY")
  88                             (getenv "no_PROXY")
  89                             (getenv "no_proxy")))))
  90       (if noproxy
  91           (setq url-proxy-services
  92                 (cons (cons "no_proxy"
  93                             (concat "\\("
  94                                     (mapconcat
  95                                      (lambda (x)
  96                                        (cond
  97                                         ((= x ?,) "\\|")
  98                                         ((= x ? ) "")
  99                                         ((= x ?.) (regexp-quote "."))
 100                                         ((= x ?*) ".*")
 101                                         ((= x ??) ".")
 102                                         (t (char-to-string x))))
 103                                      noproxy "") "\\)"))
 104                       url-proxy-services))))
 105
 106     (url-setup-privacy-info)
 107     (run-hooks 'url-load-hook)
 108     (setq url-setup-done t)))
 109
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;;; Retrieval functions
 112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113
 114 (defvar url-redirect-buffer nil
 115   "New buffer into which the retrieval will take place.
 116 Sometimes while retrieving a URL, the URL library needs to use another buffer
 117 than the one returned initially by `url-retrieve'.  In this case, it sets this
 118 variable in the original buffer as a forwarding pointer.")
 119
 120 (defvar url-retrieve-number-of-calls 0)
 121 (autoload 'url-cache-prune-cache "url-cache")
 122 (defvar url-asynchronous t
 123   "Bind to nil before calling `url-retrieve' to signal :nowait connections.")
 124
 125 ;;;###autoload
 126 (defun url-retrieve (url callback &optional cbargs silent inhibit-cookies)
 127   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
 128 URL is either a string or a parsed URL.  If it is a string
 129 containing characters that are not valid in a URI, those
 130 characters are percent-encoded; see `url-encode-url'.
 131
 132 CALLBACK is called when the object has been completely retrieved, with
 133 the current buffer containing the object, and any MIME headers associated
 134 with it.  It is called as (apply CALLBACK STATUS CBARGS).
 135 STATUS is a plist representing what happened during the request,
 136 with most recent events first, or an empty list if no events have
 137 occurred.  Each pair is one of:
 138
 139 \(:redirect REDIRECTED-TO) - the request was redirected to this URL
 140 \(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
 141 signaled with (signal ERROR-SYMBOL DATA).
 142
 143 Return the buffer URL will load into, or nil if the process has
 144 already completed (i.e. URL was a mailto URL or similar; in this case
 145 the callback is not called).
 146
 147 The variables `url-request-data', `url-request-method' and
 148 `url-request-extra-headers' can be dynamically bound around the
 149 request; dynamic binding of other variables doesn't necessarily
 150 take effect.
 151
 152 If SILENT, then don't message progress reports and the like.
 153 If INHIBIT-COOKIES, cookies will neither be stored nor sent to
 154 the server.
 155 If URL is a multibyte string, it will be encoded as utf-8 and
 156 URL-encoded before it's used."
 157 ;;; XXX: There is code in Emacs that does dynamic binding
 158 ;;; of the following variables around url-retrieve:
 159 ;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
 160 ;;; url-confirmation-func, url-cookie-multiple-line,
 161 ;;; url-cookie-{{,secure-}storage,confirmation}
 162 ;;; url-standalone-mode and url-gateway-unplugged should work as
 163 ;;; usual.  url-confirmation-func is only used in nnwarchive.el and
 164 ;;; webmail.el; the latter should be updated.  Is
 165 ;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
 166 ;;; are (for now) only used in synchronous retrievals.
 167   (url-retrieve-internal url callback (cons nil cbargs) silent
 168                          inhibit-cookies))
 169
 170 (defun url-retrieve-internal (url callback cbargs &optional silent
 171                                   inhibit-cookies)
 172   "Internal function; external interface is `url-retrieve'.
 173 The callback function will receive an updated value of CBARGS as
 174 arguments; its first element should be a plist specifying what has
 175 happened so far during the request, as described in the docstring
 176 of `url-retrieve' (if in doubt, specify nil).
 177
 178 If SILENT, don't message progress reports and the like.
 179 If INHIBIT-COOKIES, cookies will neither be stored nor sent to
 180 the server.
 181 If URL is a multibyte string, it will be encoded as utf-8 and
 182 URL-encoded before it's used."
 183   (url-do-setup)
 184   (url-gc-dead-buffers)
 185   (when (stringp url)
 186     (set-text-properties 0 (length url) nil url)
 187     (setq url (url-encode-url url)))
 188   (if (not (url-p url))
 189       (setq url (url-generic-parse-url url)))
 190   (if (not (functionp callback))
 191       (error "Must provide a callback function to url-retrieve"))
 192   (unless (url-type url)
 193     (error "Bad url: %s" (url-recreate-url url)))
 194   (setf (url-silent url) silent)
 195   (setf (url-asynchronous url) url-asynchronous)
 196   (setf (url-use-cookies url) (not inhibit-cookies))
 197   ;; Once in a while, remove old entries from the URL cache.
 198   (when (zerop (% url-retrieve-number-of-calls 1000))
 199     (condition-case error
 200         (url-cache-prune-cache)
 201       (file-error
 202        (message "Error when expiring the cache: %s" error))))
 203   (setq url-retrieve-number-of-calls (1+ url-retrieve-number-of-calls))
 204   (let ((loader (url-scheme-get-property (url-type url) 'loader))
 205         (url-using-proxy (if (url-host url)
 206                              (url-find-proxy-for-url url (url-host url))))
 207         (buffer nil)
 208         (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
 209     (if url-using-proxy
 210         (setq asynch t
 211               loader 'url-proxy))
 212     (if asynch
 213         (let ((url-current-object url))
 214           (setq buffer (funcall loader url callback cbargs)))
 215       (setq buffer (funcall loader url))
 216       (if buffer
 217           (with-current-buffer buffer
 218             (apply callback cbargs))))
 219     (if url-history-track
 220         (url-history-update-url url (current-time)))
 221     buffer))
 222
 223 ;;;###autoload
 224 (defun url-retrieve-synchronously (url &optional silent inhibit-cookies timeout)
 225   "Retrieve URL synchronously.
 226 Return the buffer containing the data, or nil if there are no data
 227 associated with it (the case for dired, info, or mailto URLs that need
 228 no further processing).  URL is either a string or a parsed URL.
 229
 230 If SILENT is non-nil, don't do any messaging while retrieving.
 231 If INHIBIT-COOKIES is non-nil, refuse to store cookies.  If
 232 TIMEOUT is passed, it should be a number that says (in seconds)
 233 how long to wait for a response before giving up."
 234   (url-do-setup)
 235
 236   (let ((retrieval-done nil)
 237         (start-time (current-time))
 238         (url-asynchronous nil)
 239         (asynch-buffer nil))
 240     (setq asynch-buffer
 241           (url-retrieve url (lambda (&rest ignored)
 242                               (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
 243                               (setq retrieval-done t
 244                                     asynch-buffer (current-buffer)))
 245                         nil silent inhibit-cookies))
 246     (if (null asynch-buffer)
 247         ;; We do not need to do anything, it was a mailto or something
 248         ;; similar that takes processing completely outside of the URL
 249         ;; package.
 250         nil
 251       (let ((proc (get-buffer-process asynch-buffer)))
 252         ;; If the access method was synchronous, `retrieval-done' should
 253         ;; hopefully already be set to t.  If it is nil, and `proc' is also
 254         ;; nil, it implies that the async process is not running in
 255         ;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
 256         ;; url-file.el should probably set something like a `url-process'
 257         ;; buffer-local variable so we can find the exact process that we
 258         ;; should be waiting for.  In the mean time, we'll just wait for any
 259         ;; process output.
 260         (while (and (not retrieval-done)
 261                     (or (not timeout)
 262                         (< (float-time (time-subtract nil start-time))
 263                            timeout)))
 264           (url-debug 'retrieval
 265                      "Spinning in url-retrieve-synchronously: %S (%S)"
 266                      retrieval-done asynch-buffer)
 267           (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
 268               (setq proc (get-buffer-process
 269                           (setq asynch-buffer
 270                                 (buffer-local-value 'url-redirect-buffer
 271                                                     asynch-buffer))))
 272             (if (and proc (memq (process-status proc)
 273                                 '(closed exit signal failed))
 274                      ;; Make sure another process hasn't been started.
 275                      (eq proc (or (get-buffer-process asynch-buffer) proc)))
 276                 ;; FIXME: It's not clear whether url-retrieve's callback is
 277                 ;; guaranteed to be called or not.  It seems that url-http
 278                 ;; decides sometimes consciously not to call it, so it's not
 279                 ;; clear that it's a bug, but even then we need to decide how
 280                 ;; url-http can then warn us that the download has completed.
 281                 ;; In the mean time, we use this here workaround.
 282                 ;; XXX: The callback must always be called.  Any
 283                 ;; exception is a bug that should be fixed, not worked
 284                 ;; around.
 285                 (progn ;; Call delete-process so we run any sentinel now.
 286                   (delete-process proc)
 287                   (setq retrieval-done t)))
 288             ;; We used to use `sit-for' here, but in some cases it wouldn't
 289             ;; work because apparently pending keyboard input would always
 290             ;; interrupt it before it got a chance to handle process input.
 291             ;; `sleep-for' was tried but it lead to other forms of
 292             ;; hanging.  --Stef
 293             (unless (or (with-local-quit
 294                           (accept-process-output proc 1))
 295                         (null proc))
 296               ;; accept-process-output returned nil, maybe because the process
 297               ;; exited (and may have been replaced with another).  If we got
 298               ;; a quit, just stop.
 299               (when quit-flag
 300                 (delete-process proc))
 301               (setq proc (and (not quit-flag)
 302                               (get-buffer-process asynch-buffer)))))))
 303       asynch-buffer)))
 304
 305 ;; url-mm-callback called from url-mm, which requires mm-decode.
 306 (declare-function mm-dissect-buffer "mm-decode"
 307                   (&optional no-strict-mime loose-mime from))
 308 (declare-function mm-display-part "mm-decode"
 309                   (handle &optional no-default force))
 310
 311 (defun url-mm-callback (&rest ignored)
 312   (let ((handle (mm-dissect-buffer t)))
 313     (url-mark-buffer-as-dead (current-buffer))
 314     (with-current-buffer
 315         (generate-new-buffer (url-recreate-url url-current-object))
 316       (if (eq (mm-display-part handle) 'external)
 317           (progn
 318             (set-process-sentinel
 319              ;; Fixme: this shouldn't have to know the form of the
 320              ;; undisplayer produced by `mm-display-part'.
 321              (get-buffer-process (cdr (mm-handle-undisplayer handle)))
 322              `(lambda (proc event)
 323                 (mm-destroy-parts (quote ,handle))))
 324             (message "Viewing externally")
 325             (kill-buffer (current-buffer)))
 326         (display-buffer (current-buffer))
 327         (add-hook 'kill-buffer-hook
 328                   `(lambda () (mm-destroy-parts ',handle))
 329                   nil
 330                   t)))))
 331
 332 (defun url-mm-url (url)
 333   "Retrieve URL and pass to the appropriate viewing application."
 334   ;; These requires could advantageously be moved to url-mm-callback or
 335   ;; turned into autoloads, but I suspect that it would introduce some bugs
 336   ;; because loading those files from a process sentinel or filter may
 337   ;; result in some undesirable corner cases.
 338   (require 'mm-decode)
 339   (require 'mm-view)
 340   (url-retrieve url 'url-mm-callback nil))
 341
 342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 343 ;;; Miscellaneous
 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 345 (defvar url-dead-buffer-list nil)
 346
 347 (defun url-mark-buffer-as-dead (buff)
 348   (push buff url-dead-buffer-list))
 349
 350 (defun url-gc-dead-buffers ()
 351   (let ((buff))
 352     (while (setq buff (pop url-dead-buffer-list))
 353       (if (buffer-live-p buff)
 354           (kill-buffer buff)))))
 355
 356 (cond
 357  ((fboundp 'display-warning)
 358   (defalias 'url-warn 'display-warning))
 359  ((fboundp 'warn)
 360   (defun url-warn (class message &optional level)
 361     (warn "(%s/%s) %s" class (or level 'warning) message)))
 362  (t
 363   (defun url-warn (class message &optional level)
 364     (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
 365       (goto-char (point-max))
 366       (save-excursion
 367         (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
 368       (display-buffer (current-buffer))))))
 369
 370 (provide 'url)
 371
 372 ;;; url.el ends here