diff options
Diffstat (limited to 'lisp/url/url-http.el')
| -rw-r--r-- | lisp/url/url-http.el | 199 |
1 files changed, 149 insertions, 50 deletions
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index bbe5268e4df..f62ec57f53e 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." @@ -296,8 +328,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 @@ -474,6 +507,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. @@ -587,15 +621,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. @@ -904,7 +930,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) @@ -930,18 +956,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 @@ -1060,7 +1092,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)" @@ -1068,7 +1100,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 @@ -1194,34 +1227,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 @@ -1277,13 +1316,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. @@ -1295,11 +1393,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 @@ -1361,7 +1461,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 @@ -1376,7 +1476,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) @@ -1460,7 +1560,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? |