diff options
Diffstat (limited to 'lisp/url')
| -rw-r--r-- | lisp/url/url-cookie.el | 18 | ||||
| -rw-r--r-- | lisp/url/url-file.el | 1 | ||||
| -rw-r--r-- | lisp/url/url-gw.el | 4 | ||||
| -rw-r--r-- | lisp/url/url-handlers.el | 3 | ||||
| -rw-r--r-- | lisp/url/url-http.el | 199 | ||||
| -rw-r--r-- | lisp/url/url-misc.el | 1 | ||||
| -rw-r--r-- | lisp/url/url-queue.el | 18 | ||||
| -rw-r--r-- | lisp/url/url-util.el | 2 | ||||
| -rw-r--r-- | lisp/url/url-vars.el | 27 | ||||
| -rw-r--r-- | lisp/url/url.el | 19 |
10 files changed, 220 insertions, 72 deletions
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 4c7366adc8e..6848230c28f 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -353,6 +353,24 @@ to run the `url-cookie-setup-save-timer' function manually." url-cookie-save-interval #'url-cookie-write-file)))) +(defun url-cookie-delete-cookies (&optional regexp keep) + "Delete all cookies from the cookie store where the domain matches REGEXP. +If REGEXP is nil, all cookies are deleted. If KEEP is non-nil, +instead delete all cookies that do not match REGEXP." + (dolist (variable '(url-cookie-secure-storage url-cookie-storage)) + (let ((cookies (symbol-value variable))) + (dolist (elem cookies) + (when (or (and (null keep) + (or (null regexp) + (string-match regexp (car elem)))) + (and keep + regexp + (not (string-match regexp (car elem))))) + (setq cookies (delq elem cookies)))) + (set variable cookies))) + (setq url-cookies-changed-since-last-save t) + (url-cookie-write-file)) + ;;; Mode for listing and editing cookies. (defun url-cookie-list () diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 9eb9377583d..61e83c09974 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -27,6 +27,7 @@ (require 'url-vars) (require 'url-parse) (require 'url-dired) +(declare-function mm-disable-multibyte "mm-util" ()) (defconst url-file-default-port 21 "Default FTP port.") (defconst url-file-asynchronous-p t "FTP transfers are asynchronous.") diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 460ee0dd426..d898368cf9e 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -246,8 +246,8 @@ overriding the value of `url-gateway-method'." :type gw-method ;; Use non-blocking socket if we can. :nowait (featurep 'make-network-process - '(:nowait t)))) - (`socks + '(:nowait t)))) + (`socks (socks-open-network-stream name buffer host service)) (`telnet (url-open-telnet name buffer host service)) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 717651df544..d3be880b382 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -269,7 +269,8 @@ A prefix arg makes KEEP-TIME non-nil." (error "Opening input file: No such file or directory, %s" url)) (with-current-buffer buffer (setq handle (mm-dissect-buffer t))) - (mm-save-part-to-file handle newname) + (let ((mm-attachment-file-modes (default-file-modes))) + (mm-save-part-to-file handle newname)) (kill-buffer buffer) (mm-destroy-parts handle))) (put 'copy-file 'url-file-handlers 'url-copy-file) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 5832e92c5a3..306b36ae951 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1,4 +1,4 @@ -;;; url-http.el --- HTTP retrieval routines +;;; url-http.el --- HTTP retrieval routines -*- lexical-binding:t -*- ;; Copyright (C) 1999, 2001, 2004-2016 Free Software Foundation, Inc. @@ -26,6 +26,8 @@ ;;; Code: (require 'cl-lib) +(require 'puny) +(require 'nsm) (eval-when-compile (require 'subr-x)) @@ -135,6 +137,8 @@ request.") (507 insufficient-storage "Insufficient storage")) "The HTTP return codes and their text.") +(defconst url-https-default-port 443 "Default HTTPS port.") + ;(eval-when-compile ;; These are all macros so that they are hidden from external sight ;; when the file is byte-compiled. @@ -196,7 +200,14 @@ request.") ;; `url-open-stream' needs a buffer in which to do things ;; like authentication. But we use another buffer afterwards. (unwind-protect - (let ((proc (url-open-stream host buf host port gateway-method))) + (let ((proc (url-open-stream host buf + (if url-using-proxy + (url-host url-using-proxy) + host) + (if url-using-proxy + (url-port url-using-proxy) + port) + gateway-method))) ;; url-open-stream might return nil. (when (processp proc) ;; Drop the temp buffer link before killing the buffer. @@ -211,15 +222,36 @@ request.") (if connection (url-http-mark-connection-as-busy host port connection)))) +(defun url-http--user-agent-default-string () + "Compute a default User-Agent string based on `url-privacy-level'." + (let ((package-info (when url-package-name + (format "%s/%s" url-package-name url-package-version))) + (emacs-info (unless (and (listp url-privacy-level) + (memq 'emacs url-privacy-level)) + (format "Emacs/%s" emacs-version))) + (os-info (unless (and (listp url-privacy-level) + (memq 'os url-privacy-level)) + (format "(%s; %s)" url-system-type url-os-type))) + (url-info (format "URL/%s" url-version))) + (string-join (delq nil (list package-info url-info + emacs-info os-info)) + " "))) + ;; Building an HTTP request (defun url-http-user-agent-string () - (if (or (eq url-privacy-level 'paranoid) - (and (listp url-privacy-level) - (memq 'agent url-privacy-level))) - "" - (if (functionp url-user-agent) - (funcall url-user-agent) - url-user-agent))) + "Compute a User-Agent string. +The string is based on `url-privacy-level' and `url-user-agent'." + (let* ((hide-ua + (or (eq url-privacy-level 'paranoid) + (and (listp url-privacy-level) + (memq 'agent url-privacy-level)))) + (ua-string + (and (not hide-ua) + (cond + ((functionp url-user-agent) (funcall url-user-agent)) + ((stringp url-user-agent) url-user-agent) + ((eq url-user-agent 'default) (url-http--user-agent-default-string)))))) + (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) ""))) (defun url-http-create-request (&optional ref-url) "Create an HTTP request for `url-http-target-url', referred to by REF-URL." @@ -307,8 +339,9 @@ request.") (url-scheme-get-property (url-type url-http-target-url) 'default-port)) (format - "Host: %s:%d\r\n" host (url-port url-http-target-url)) - (format "Host: %s\r\n" host)) + "Host: %s:%d\r\n" (puny-encode-domain host) + (url-port url-http-target-url)) + (format "Host: %s\r\n" (puny-encode-domain host))) ;; Who its from (if url-personal-mail-address (concat @@ -475,6 +508,7 @@ work correctly." ) (declare-function gnutls-peer-status "gnutls.c" (proc)) +(declare-function gnutls-negotiate "gnutls.el" t t) (defun url-http-parse-headers () "Parse and handle HTTP specific headers. @@ -588,15 +622,7 @@ should be shown to the user." ;; We do not support agent-driven negotiation, so we just ;; redirect to the preferred URI if one is provided. nil) - ((or `moved-permanently `found `temporary-redirect) ; 301 302 307 - ;; If the 301|302 status code is received in response to a - ;; request other than GET or HEAD, the user agent MUST NOT - ;; automatically redirect the request unless it can be - ;; confirmed by the user, since this might change the - ;; conditions under which the request was issued. - (unless (member url-http-method '("HEAD" "GET")) - (setq redirect-uri nil))) - (`see-other ; 303 + (`see-other ; 303 ;; The response to the request can be found under a different ;; URI and SHOULD be retrieved using a GET method on that ;; resource. @@ -905,7 +931,7 @@ should be shown to the user." ;; ) ;; These unfortunately cannot be macros... please ignore them! -(defun url-http-idle-sentinel (proc why) +(defun url-http-idle-sentinel (proc _why) "Remove (now defunct) process PROC from the list of open connections." (maphash (lambda (key val) (if (memq proc val) @@ -931,18 +957,24 @@ should be shown to the user." (erase-buffer) (let ((url-request-method url-http-method) (url-request-extra-headers url-http-extra-headers) - (url-request-data url-http-data)) + (url-request-data url-http-data) + (url-using-proxy (url-find-proxy-for-url + url-current-object + (url-host url-current-object)))) + (when url-using-proxy + (setq url-using-proxy + (url-generic-parse-url url-using-proxy))) (url-http url-current-object url-callback-function url-callback-arguments (current-buffer))))) ((url-http-parse-headers) (url-http-activate-callback)))))) -(defun url-http-simple-after-change-function (st nd length) +(defun url-http-simple-after-change-function (_st _nd _length) ;; Function used when we do NOT know how long the document is going to be ;; Just _very_ simple 'downloaded %d' type of info. - (url-lazy-message "Reading %s..." (file-size-human-readable nd))) + (url-lazy-message "Reading %s..." (file-size-human-readable (buffer-size)))) -(defun url-http-content-length-after-change-function (st nd length) +(defun url-http-content-length-after-change-function (_st nd _length) "Function used when we DO know how long the document is going to be. More sophisticated percentage downloaded, etc. Also does minimal parsing of HTTP headers and will actually cause @@ -1061,7 +1093,7 @@ the end of the document." (if (url-http-parse-headers) (url-http-activate-callback)))))))))) -(defun url-http-wait-for-headers-change-function (st nd length) +(defun url-http-wait-for-headers-change-function (_st nd _length) ;; This will wait for the headers to arrive and then splice in the ;; next appropriate after-change-function, etc. (url-http-debug "url-http-wait-for-headers-change-function (%s)" @@ -1069,7 +1101,8 @@ the end of the document." (let ((end-of-headers nil) (old-http nil) (process-buffer (current-buffer)) - (content-length nil)) + ;; (content-length nil) + ) (when (not (bobp)) (goto-char (point-min)) (if (and (looking-at ".*\n") ; have one line at least @@ -1195,34 +1228,40 @@ the end of the document." "Retrieve URL via HTTP asynchronously. URL must be a parsed URL. See `url-generic-parse-url' for details. -When retrieval is completed, execute the function CALLBACK, passing it -an updated value of CBARGS as arguments. The first element in CBARGS -should be a plist describing what has happened so far during the -request, as described in the docstring of `url-retrieve' (if in -doubt, specify nil). +When retrieval is completed, execute the function CALLBACK, +passing it an updated value of CBARGS as arguments. The first +element in CBARGS should be a plist describing what has happened +so far during the request, as described in the docstring of +`url-retrieve' (if in doubt, specify nil). The current buffer +then CALLBACK is executed is the retrieval buffer. Optional arg RETRY-BUFFER, if non-nil, specifies the buffer of a previous `url-http' call, which is being re-attempted. Optional arg GATEWAY-METHOD specifies the gateway to be used, -overriding the value of `url-gateway-method'." +overriding the value of `url-gateway-method'. + +The return value of this function is the retrieval buffer." (cl-check-type url vector "Need a pre-parsed URL.") - (let* ((host (url-host (or url-using-proxy url))) - (port (url-port (or url-using-proxy url))) + (let* (;; (host (url-host (or url-using-proxy url))) + ;; (port (url-port (or url-using-proxy url))) (nsm-noninteractive (or url-request-noninteractive (and (boundp 'url-http-noninteractive) url-http-noninteractive))) - (connection (url-http-find-free-connection host port gateway-method)) + (connection (url-http-find-free-connection (url-host url) + (url-port url) + gateway-method)) (mime-accept-string url-mime-accept-string) (buffer (or retry-buffer (generate-new-buffer - (format " *http %s:%d*" host port))))) + (format " *http %s:%d*" (url-host url) (url-port url)))))) (if (not connection) ;; Failed to open the connection for some reason (progn (kill-buffer buffer) (setq buffer nil) - (error "Could not create connection to %s:%d" host port)) + (error "Could not create connection to %s:%d" (url-host url) + (url-port url))) (with-current-buffer buffer (mm-disable-multibyte) (setq url-current-object url @@ -1278,13 +1317,72 @@ overriding the value of `url-gateway-method'." (set-process-sentinel connection 'url-http-async-sentinel)) (`failed ;; Asynchronous connection failed - (error "Could not create connection to %s:%d" host port)) + (error "Could not create connection to %s:%d" (url-host url) + (url-port url))) (_ - (set-process-sentinel connection - 'url-http-end-of-document-sentinel) - (process-send-string connection (url-http-create-request)))))) + (if (and url-http-proxy (string= "https" + (url-type url-current-object))) + (url-https-proxy-connect connection) + (set-process-sentinel connection + 'url-http-end-of-document-sentinel) + (process-send-string connection (url-http-create-request))))))) buffer)) +(defun url-https-proxy-connect (connection) + (setq url-http-after-change-function 'url-https-proxy-after-change-function) + (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n" + "Host: %s\r\n" + "\r\n") + (url-host url-current-object) + (or (url-port url-current-object) + url-https-default-port) + (url-host url-current-object)))) + +(defun url-https-proxy-after-change-function (_st _nd _length) + (let* ((process-buffer (current-buffer)) + (proc (get-buffer-process process-buffer))) + (goto-char (point-min)) + (when (re-search-forward "^\r?\n" nil t) + (backward-char 1) + ;; Saw the end of the headers + (setq url-http-end-of-headers (set-marker (make-marker) (point))) + (url-http-parse-response) + (cond + ((null url-http-response-status) + ;; We got back a headerless malformed response from the + ;; server. + (url-http-activate-callback) + (error "Malformed response from proxy, fail!")) + ((= url-http-response-status 200) + (if (gnutls-available-p) + (condition-case e + (let ((tls-connection (gnutls-negotiate + :process proc + :hostname (url-host url-current-object) + :verify-error nil))) + ;; check certificate validity + (setq tls-connection + (nsm-verify-connection tls-connection + (url-host url-current-object) + (url-port url-current-object))) + (with-current-buffer process-buffer (erase-buffer)) + (set-process-buffer tls-connection process-buffer) + (setq url-http-after-change-function + 'url-http-wait-for-headers-change-function) + (set-process-filter tls-connection 'url-http-generic-filter) + (process-send-string tls-connection + (url-http-create-request))) + (gnutls-error + (url-http-activate-callback) + (error "gnutls-error: %s" e)) + (error + (url-http-activate-callback) + (error "error: %s" e))) + (error "error: gnutls support needed!"))) + (t + (message "error response: %d" url-http-response-status) + (url-http-activate-callback)))))) + (defun url-http-async-sentinel (proc why) ;; We are performing an asynchronous connection, and a status change ;; has occurred. @@ -1296,11 +1394,13 @@ overriding the value of `url-gateway-method'." (url-http-end-of-document-sentinel proc why)) ((string= (substring why 0 4) "open") (setq url-http-connection-opened t) - (condition-case error - (process-send-string proc (url-http-create-request)) - (file-error - (setq url-http-connection-opened nil) - (message "HTTP error: %s" error)))) + (if (and url-http-proxy (string= "https" (url-type url-current-object))) + (url-https-proxy-connect proc) + (condition-case error + (process-send-string proc (url-http-create-request)) + (file-error + (setq url-http-connection-opened nil) + (message "HTTP error: %s" error))))) (t (setf (car url-callback-arguments) (nconc (list :error (list 'error 'connection-failed why @@ -1362,7 +1462,7 @@ overriding the value of `url-gateway-method'." (defalias 'url-http-file-readable-p 'url-http-file-exists-p) -(defun url-http-head-file-attributes (url &optional id-format) +(defun url-http-head-file-attributes (url &optional _id-format) (let ((buffer (url-http-head url))) (when buffer (prog1 @@ -1377,7 +1477,7 @@ overriding the value of `url-gateway-method'." nil nil nil) ;whether gid would change ; inode ; device. (kill-buffer buffer))))) -(declare-function url-dav-file-attributes "url-dav" (url &optional id-format)) +(declare-function url-dav-file-attributes "url-dav" (url &optional _id-format)) (defun url-http-file-attributes (url &optional id-format) (if (url-dav-supported-p url) @@ -1461,7 +1561,6 @@ p3p ;; with url-http.el on systems with 8-character file names. (require 'tls) -(defconst url-https-default-port 443 "Default HTTPS port.") (defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") ;; FIXME what is the point of this alias being an autoload? diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el index 2c277fb69c2..14b9f7eab44 100644 --- a/lisp/url/url-misc.el +++ b/lisp/url/url-misc.el @@ -24,6 +24,7 @@ (require 'url-vars) (require 'url-parse) +(declare-function mm-disable-multibyte "mm-util" ()) (autoload 'Info-goto-node "info" "" t) (autoload 'man "man" nil t) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index 0ff4ad1556c..8972d0b056c 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -1,4 +1,4 @@ -;;; url-queue.el --- Fetching web pages in parallel +;;; url-queue.el --- Fetching web pages in parallel -*- lexical-binding: t -*- ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. @@ -47,6 +47,7 @@ ;;; Internal variables. (defvar url-queue nil) +(defvar url-queue-progress-timer nil) (cl-defstruct url-queue url callback cbargs silentp @@ -90,7 +91,13 @@ The variable `url-queue-timeout' sets a timeout." (when (and waiting (< running url-queue-parallel-processes)) (setf (url-queue-pre-triggered waiting) t) - (run-with-idle-timer 0.01 nil 'url-queue-run-queue)))) + ;; We start fetching from this idle timer... + (run-with-idle-timer 0.01 nil #'url-queue-run-queue) + ;; And then we set up a separate timer to ensure progress when a + ;; web server is unresponsive. + (unless url-queue-progress-timer + (setq url-queue-progress-timer + (run-with-idle-timer 1 1 #'url-queue-check-progress)))))) (defun url-queue-run-queue () (url-queue-prune-old-entries) @@ -107,6 +114,13 @@ The variable `url-queue-timeout' sets a timeout." (setf (url-queue-start-time waiting) (float-time)) (url-queue-start-retrieve waiting)))) +(defun url-queue-check-progress () + (when url-queue-progress-timer + (if url-queue + (url-queue-run-queue) + (cancel-timer url-queue-progress-timer) + (setq url-queue-progress-timer nil)))) + (defun url-queue-callback-function (status job) (setq url-queue (delq job url-queue)) (when (and (eq (car status) :error) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 1ae2213eee6..af18acd8b6a 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -468,7 +468,7 @@ should return it unchanged." (and host (not (string-match "\\`\\[.*\\]\\'" host)) (setf (url-host obj) - (url-hexify-string host url-host-allowed-chars))) + (decode-coding-string (url-host obj) 'utf-8))) (if path (setq path (url-hexify-string path url-path-allowed-chars))) diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 960a04ad30f..f6aae21a838 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -116,6 +116,7 @@ If a list, this should be a list of symbols of what NOT to send. Valid symbols are: email -- the email address os -- the operating system info +emacs -- the version of Emacs lastloc -- the last location agent -- do not send the User-Agent string cookies -- never accept HTTP cookies @@ -143,6 +144,7 @@ variable." (checklist :tag "Custom" (const :tag "Email address" :value email) (const :tag "Operating system" :value os) + (const :tag "Emacs version" :value emacs) (const :tag "Last location" :value lastloc) (const :tag "Browser identification" :value agent) (const :tag "No cookies" :value cookie))) @@ -357,16 +359,21 @@ Currently supported methods: (const :tag "Direct connection" :value native)) :group 'url-hairy) -(defcustom url-user-agent (format "User-Agent: %sURL/%s\r\n" - (if url-package-name - (concat url-package-name "/" - url-package-version " ") - "") url-version) - "User Agent used by the URL package for HTTP/HTTPS requests -Should be a string or a function of no arguments returning a string." - :type '(choice (string :tag "A static User-Agent string") - (function :tag "Call a function to get the User-Agent string")) - :version "25.1" +(defcustom url-user-agent 'default + "User Agent used by the URL package for HTTP/HTTPS requests. +Should be one of: +* A string (not including the \"User-Agent:\" prefix) +* A function of no arguments, returning a string +* `default' (to compute a value according to `url-privacy-level') +* nil (to omit the User-Agent header entirely)" + :type + '(choice + (string :tag "A static User-Agent string") + (function :tag "Call a function to get the User-Agent string") + (const :tag "No User-Agent at all" :value nil) + (const :tag "An string auto-generated according to `url-privacy-level'" + :value default)) + :version "25.2" :group 'url) (defvar url-setup-done nil "Has setup configuration been done?") diff --git a/lisp/url/url.el b/lisp/url/url.el index 91adada5e85..6d710e02d63 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -221,17 +221,20 @@ URL-encoded before it's used." buffer)) ;;;###autoload -(defun url-retrieve-synchronously (url &optional silent inhibit-cookies) +(defun url-retrieve-synchronously (url &optional silent inhibit-cookies timeout) "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 no further processing). URL is either a string or a parsed URL. -If SILENT is non-nil, don't display progress reports and similar messages. -If INHIBIT-COOKIES is non-nil, cookies will neither be stored nor sent -to the server." + +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." (url-do-setup) (let ((retrieval-done nil) + (start-time (current-time)) (asynch-buffer nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) @@ -253,7 +256,11 @@ to the server." ;; 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. - (while (not retrieval-done) + (while (and (not retrieval-done) + (or (not timeout) + (< (float-time (time-subtract + (current-time) start-time)) + timeout))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" retrieval-done asynch-buffer) @@ -284,7 +291,7 @@ to the server." ;; `sleep-for' was tried but it lead to other forms of ;; hanging. --Stef (unless (or (with-local-quit - (accept-process-output proc)) + (accept-process-output proc 1)) (null proc)) ;; accept-process-output returned nil, maybe because the process ;; exited (and may have been replaced with another). If we got |