diff options
| author | Lars Ingebrigtsen | 2018-04-13 16:38:10 +0200 |
|---|---|---|
| committer | Lars Ingebrigtsen | 2018-04-13 16:38:10 +0200 |
| commit | 4a6302330384ad89bcfccce6b563eb5462b753a9 (patch) | |
| tree | 2695c81d4681e5e62fbbde9dbd9fd68707423f35 | |
| parent | 1fd104d30a8985e1f6962eb325207efad96273b6 (diff) | |
| download | emacs-4a6302330384ad89bcfccce6b563eb5462b753a9.tar.gz emacs-4a6302330384ad89bcfccce6b563eb5462b753a9.zip | |
Make Unicode domain names work again in URL after recent changes
* lisp/net/gnutls.el (open-gnutls-stream): IDNA-encode hostnames
before passing them on to gnutls for verification.
* lisp/net/network-stream.el (network-stream-open-starttls): Ditto.
* lisp/url/url-http.el (url-http--get-referer): Be IDNA-aware.
(url-http-create-request): Don't de-Unicodify host names, because
they may be IDNA names (that are later encoded).
* lisp/url/url-util.el (url-domain): Be IDNA-aware when doing
domain name computations.
| -rw-r--r-- | lisp/net/gnutls.el | 4 | ||||
| -rw-r--r-- | lisp/net/network-stream.el | 3 | ||||
| -rw-r--r-- | lisp/url/url-http.el | 47 | ||||
| -rw-r--r-- | lisp/url/url-util.el | 2 |
4 files changed, 29 insertions, 27 deletions
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 57ac26fc741..cea6c25112e 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el | |||
| @@ -154,12 +154,12 @@ trust and key files, and priority string." | |||
| 154 | (cons 'gnutls-x509pki | 154 | (cons 'gnutls-x509pki |
| 155 | (gnutls-boot-parameters | 155 | (gnutls-boot-parameters |
| 156 | :type 'gnutls-x509pki | 156 | :type 'gnutls-x509pki |
| 157 | :hostname host)))))) | 157 | :hostname (puny-encode-domain host))))))) |
| 158 | (if nowait | 158 | (if nowait |
| 159 | process | 159 | process |
| 160 | (gnutls-negotiate :process process | 160 | (gnutls-negotiate :process process |
| 161 | :type 'gnutls-x509pki | 161 | :type 'gnutls-x509pki |
| 162 | :hostname host)))) | 162 | :hostname (puny-encode-domain host))))) |
| 163 | 163 | ||
| 164 | (define-error 'gnutls-error "GnuTLS error") | 164 | (define-error 'gnutls-error "GnuTLS error") |
| 165 | 165 | ||
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index f55f5486b62..19e0c6421fb 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el | |||
| @@ -295,7 +295,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." | |||
| 295 | (if (gnutls-available-p) | 295 | (if (gnutls-available-p) |
| 296 | (let ((cert (network-stream-certificate host service parameters))) | 296 | (let ((cert (network-stream-certificate host service parameters))) |
| 297 | (condition-case nil | 297 | (condition-case nil |
| 298 | (gnutls-negotiate :process stream :hostname host | 298 | (gnutls-negotiate :process stream |
| 299 | :hostname (puny-encode-domain host) | ||
| 299 | :keylist (and cert (list cert))) | 300 | :keylist (and cert (list cert))) |
| 300 | ;; If we get a gnutls-specific error (for instance if | 301 | ;; If we get a gnutls-specific error (for instance if |
| 301 | ;; the certificate the server gives us is completely | 302 | ;; the certificate the server gives us is completely |
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 45e887b348d..bb3e76997a8 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el | |||
| @@ -244,28 +244,29 @@ request.") | |||
| 244 | (when url-current-lastloc | 244 | (when url-current-lastloc |
| 245 | (if (not (url-p url-current-lastloc)) | 245 | (if (not (url-p url-current-lastloc)) |
| 246 | (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) | 246 | (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) |
| 247 | (let* ((referer url-current-lastloc) | 247 | (let ((referer (copy-sequence url-current-lastloc))) |
| 248 | (referer-string (url-recreate-url referer))) | 248 | (setf (url-host referer) (puny-encode-domain (url-host referer))) |
| 249 | (when (and (not (memq url-privacy-level '(low high paranoid))) | 249 | (let ((referer-string (url-recreate-url referer))) |
| 250 | (not (and (listp url-privacy-level) | 250 | (when (and (not (memq url-privacy-level '(low high paranoid))) |
| 251 | (memq 'lastloc url-privacy-level)))) | 251 | (not (and (listp url-privacy-level) |
| 252 | ;; url-privacy-level allows referer. But url-lastloc-privacy-level | 252 | (memq 'lastloc url-privacy-level)))) |
| 253 | ;; may restrict who we send it to. | 253 | ;; url-privacy-level allows referer. But url-lastloc-privacy-level |
| 254 | (cl-case url-lastloc-privacy-level | 254 | ;; may restrict who we send it to. |
| 255 | (host-match | 255 | (cl-case url-lastloc-privacy-level |
| 256 | (let ((referer-host (url-host referer)) | 256 | (host-match |
| 257 | (url-host (url-host url))) | 257 | (let ((referer-host (url-host referer)) |
| 258 | (when (string= referer-host url-host) | 258 | (url-host (url-host url))) |
| 259 | referer-string))) | 259 | (when (string= referer-host url-host) |
| 260 | (domain-match | 260 | referer-string))) |
| 261 | (let ((referer-domain (url-domain referer)) | 261 | (domain-match |
| 262 | (url-domain (url-domain url))) | 262 | (let ((referer-domain (url-domain referer)) |
| 263 | (when (and referer-domain | 263 | (url-domain (url-domain url))) |
| 264 | url-domain | 264 | (when (and referer-domain |
| 265 | (string= referer-domain url-domain)) | 265 | url-domain |
| 266 | referer-string))) | 266 | (string= referer-domain url-domain)) |
| 267 | (otherwise | 267 | referer-string))) |
| 268 | referer-string)))))) | 268 | (otherwise |
| 269 | referer-string))))))) | ||
| 269 | 270 | ||
| 270 | ;; Building an HTTP request | 271 | ;; Building an HTTP request |
| 271 | (defun url-http-user-agent-string () | 272 | (defun url-http-user-agent-string () |
| @@ -298,7 +299,7 @@ as the Referer-header (subject to `url-privacy-level'." | |||
| 298 | 'url-http-proxy-basic-auth-storage)) | 299 | 'url-http-proxy-basic-auth-storage)) |
| 299 | (url-get-authentication url-http-proxy nil 'any nil)))) | 300 | (url-get-authentication url-http-proxy nil 'any nil)))) |
| 300 | (real-fname (url-filename url-http-target-url)) | 301 | (real-fname (url-filename url-http-target-url)) |
| 301 | (host (url-http--encode-string (url-host url-http-target-url))) | 302 | (host (url-host url-http-target-url)) |
| 302 | (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) | 303 | (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) |
| 303 | nil | 304 | nil |
| 304 | (url-get-authentication (or | 305 | (url-get-authentication (or |
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 77e015068a3..b2064484809 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el | |||
| @@ -645,7 +645,7 @@ not contain a registered name." | |||
| 645 | ;; | 645 | ;; |
| 646 | ;; Domain delegations change rarely enough that we won't bother with | 646 | ;; Domain delegations change rarely enough that we won't bother with |
| 647 | ;; cache invalidation, I think. | 647 | ;; cache invalidation, I think. |
| 648 | (let* ((host-parts (split-string (url-host url) "\\.")) | 648 | (let* ((host-parts (split-string (puny-encode-domain (url-host url)) "\\.")) |
| 649 | (result (gethash host-parts url--domain-cache 'not-found))) | 649 | (result (gethash host-parts url--domain-cache 'not-found))) |
| 650 | (when (eq result 'not-found) | 650 | (when (eq result 'not-found) |
| 651 | (setq result | 651 | (setq result |