Commit 5f9671e5 authored by Stefan Monnier's avatar Stefan Monnier

* lisp/emacs-lisp/package.el: Fix decoding of downloaded files

This is a different fix for bug#34909, which should also fix bug#35739.

Our downloading code used to automatically decode the result according
to the usual heuristics for files.  This caused problems when we later
needed to save the data in a file that needed to be byte-for-byte
equal to the original in order to pass the signature verification,
especially because we didn't keep track of which coding-system was
used to decode the data.

(package--unless-error): New macro extracted from
package--with-response-buffer-1, so that we can specify edebug and
indent specs.
(package--with-response-buffer-1): Use it.  More importantly, change
code so it runs `body` in a unibyte buffer with undecoded data.
(package--download-one-archive): Don't encode with utf-8 since the data
is not decoded yet.
(describe-package-1): Explicitly decode the readem.txt files here.

* lisp/url/url-handlers.el (url-insert-file-contents): Use it.
(url-insert): Don't decode if buffer is unibyte.

* lisp/url/url-http.el (url-http--insert-file-helper): New function,
extracted from url-insert-file-contents.
parent 2a570576
Pipeline #1727 failed with stage
in 50 minutes and 30 seconds
...@@ -1203,42 +1203,60 @@ errors signaled by ERROR-FORM or by BODY). ...@@ -1203,42 +1203,60 @@ errors signaled by ERROR-FORM or by BODY).
:error-function (lambda () ,error-form) :error-function (lambda () ,error-form)
:noerror ,noerror)) :noerror ,noerror))
(defmacro package--unless-error (body &rest before-body)
(declare (debug t) (indent 1))
(let ((err (make-symbol "err")))
`(with-temp-buffer
(set-buffer-multibyte nil)
(when (condition-case ,err
(progn ,@before-body t)
(error (funcall error-function)
(unless noerror
(signal (car ,err) (cdr ,err)))))
(funcall ,body)))))
(cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys) (cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys)
(cl-macrolet ((unless-error (body &rest before-body) (if (string-match-p "\\`https?:" url)
(let ((err (make-symbol "err")))
`(with-temp-buffer
(when (condition-case ,err
(progn ,@before-body t)
(error (funcall error-function)
(unless noerror
(signal (car ,err) (cdr ,err)))))
(funcall ,body))))))
(if (string-match-p "\\`https?:" url)
(let ((url (concat url file))) (let ((url (concat url file)))
(if async (if async
(unless-error #'ignore (package--unless-error #'ignore
(url-retrieve url (url-retrieve
(lambda (status) url
(let ((b (current-buffer))) (lambda (status)
(require 'url-handlers) (let ((b (current-buffer)))
(unless-error body (require 'url-handlers)
(when-let* ((er (plist-get status :error))) (package--unless-error body
(error "Error retrieving: %s %S" url er)) (when-let* ((er (plist-get status :error)))
(with-current-buffer b (error "Error retrieving: %s %S" url er))
(goto-char (point-min)) (with-current-buffer b
(unless (search-forward-regexp "^\r?\n\r?" nil 'noerror) (goto-char (point-min))
(error "Error retrieving: %s %S" url "incomprehensible buffer"))) (unless (search-forward-regexp "^\r?\n\r?" nil t)
(url-insert-buffer-contents b url) (error "Error retrieving: %s %S"
(kill-buffer b) url "incomprehensible buffer")))
(goto-char (point-min))))) (url-insert b)
nil (kill-buffer b)
'silent)) (goto-char (point-min)))))
(unless-error body (url-insert-file-contents url)))) nil
(unless-error body 'silent))
(package--unless-error body
;; Copy&pasted from url-insert-file-contents,
;; except it calls `url-insert' because we want the contents
;; literally (but there's no url-insert-file-contents-literally).
(let ((buffer (url-retrieve-synchronously url)))
(unless buffer (signal 'file-error (list url "No Data")))
(when (fboundp 'url-http--insert-file-helper)
;; XXX: This is HTTP/S specific and should be moved
;; to url-http instead. See bug#17549.
(url-http--insert-file-helper buffer url))
(url-insert buffer)
(kill-buffer buffer)
(goto-char (point-min))))))
(package--unless-error body
(let ((url (expand-file-name file url))) (let ((url (expand-file-name file url)))
(unless (file-name-absolute-p url) (unless (file-name-absolute-p url)
(error "Location %s is not a url nor an absolute file name" url)) (error "Location %s is not a url nor an absolute file name"
(insert-file-contents url)))))) url))
(insert-file-contents-literally url)))))
(define-error 'bad-signature "Failed to verify signature") (define-error 'bad-signature "Failed to verify signature")
...@@ -1297,7 +1315,8 @@ else, even if an error is signaled." ...@@ -1297,7 +1315,8 @@ else, even if an error is signaled."
(package--with-response-buffer location :file sig-file (package--with-response-buffer location :file sig-file
:async async :noerror t :async async :noerror t
;; Connection error is assumed to mean "no sig-file". ;; Connection error is assumed to mean "no sig-file".
:error-form (let ((allow-unsigned (eq package-check-signature 'allow-unsigned))) :error-form (let ((allow-unsigned
(eq package-check-signature 'allow-unsigned)))
(when (and callback allow-unsigned) (when (and callback allow-unsigned)
(funcall callback nil)) (funcall callback nil))
(when unwind (funcall unwind)) (when unwind (funcall unwind))
...@@ -1306,8 +1325,9 @@ else, even if an error is signaled." ...@@ -1306,8 +1325,9 @@ else, even if an error is signaled."
;; OTOH, an error here means "bad signature", which we never ;; OTOH, an error here means "bad signature", which we never
;; suppress. (Bug#22089) ;; suppress. (Bug#22089)
(unwind-protect (unwind-protect
(let ((sig (package--check-signature-content (buffer-substring (point) (point-max)) (let ((sig (package--check-signature-content
string sig-file))) (buffer-substring (point) (point-max))
string sig-file)))
(when callback (funcall callback sig)) (when callback (funcall callback sig))
sig) sig)
(when unwind (funcall unwind)))))) (when unwind (funcall unwind))))))
...@@ -1584,15 +1604,18 @@ similar to an entry in `package-alist'. Save the cached copy to ...@@ -1584,15 +1604,18 @@ similar to an entry in `package-alist'. Save the cached copy to
(member name package-unsigned-archives)) (member name package-unsigned-archives))
;; If we don't care about the signature, save the file and ;; If we don't care about the signature, save the file and
;; we're done. ;; we're done.
(progn (let ((coding-system-for-write 'utf-8)) (progn
(write-region content nil local-file nil 'silent)) (cl-assert (not enable-multibyte-characters))
(package--update-downloads-in-progress archive)) (let ((coding-system-for-write 'binary))
(write-region content nil local-file nil 'silent))
(package--update-downloads-in-progress archive))
;; If we care, check it (perhaps async) and *then* write the file. ;; If we care, check it (perhaps async) and *then* write the file.
(package--check-signature (package--check-signature
location file content async location file content async
;; This function will be called after signature checking. ;; This function will be called after signature checking.
(lambda (&optional good-sigs) (lambda (&optional good-sigs)
(let ((coding-system-for-write 'utf-8)) (cl-assert (not enable-multibyte-characters))
(let ((coding-system-for-write 'binary))
(write-region content nil local-file nil 'silent)) (write-region content nil local-file nil 'silent))
;; Write out good signatures into archive-contents.signed file. ;; Write out good signatures into archive-contents.signed file.
(when good-sigs (when good-sigs
...@@ -1906,7 +1929,8 @@ if all the in-between dependencies are also in PACKAGE-LIST." ...@@ -1906,7 +1929,8 @@ if all the in-between dependencies are also in PACKAGE-LIST."
;; Update the old pkg-desc which will be shown on the description buffer. ;; Update the old pkg-desc which will be shown on the description buffer.
(setf (package-desc-signed pkg-desc) t) (setf (package-desc-signed pkg-desc) t)
;; Update the new (activated) pkg-desc as well. ;; Update the new (activated) pkg-desc as well.
(when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))) (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc)
package-alist))))
(setf (package-desc-signed (car pkg-descs)) t)))))))))) (setf (package-desc-signed (car pkg-descs)) t))))))))))
(defun package-installed-p (package &optional min-version) (defun package-installed-p (package &optional min-version)
...@@ -2480,10 +2504,12 @@ The description is read from the installed package files." ...@@ -2480,10 +2504,12 @@ The description is read from the installed package files."
(replace-match "")))) (replace-match ""))))
(if (package-installed-p desc) (if (package-installed-p desc)
;; For installed packages, get the description from the installed files. ;; For installed packages, get the description from the
;; installed files.
(insert (package--get-description desc)) (insert (package--get-description desc))
;; For non-built-in, non-installed packages, get description from the archive. ;; For non-built-in, non-installed packages, get description from
;; the archive.
(let* ((basename (format "%s-readme.txt" name)) (let* ((basename (format "%s-readme.txt" name))
readme-string) readme-string)
...@@ -2493,7 +2519,10 @@ The description is read from the installed package files." ...@@ -2493,7 +2519,10 @@ The description is read from the installed package files."
(goto-char (point-max)) (goto-char (point-max))
(unless (bolp) (unless (bolp)
(insert ?\n))) (insert ?\n)))
(setq readme-string (buffer-string)) (cl-assert (not enable-multibyte-characters))
(setq readme-string
;; The readme.txt files are defined to contain utf-8 text.
(decode-coding-region (point-min) (point-max) 'utf-8 t))
t) t)
(insert (or readme-string (insert (or readme-string
"This package does not provide a description."))) "This package does not provide a description.")))
......
...@@ -299,7 +299,8 @@ accessible." ...@@ -299,7 +299,8 @@ accessible."
(defun url-insert (buffer &optional beg end) (defun url-insert (buffer &optional beg end)
"Insert the body of a URL object. "Insert the body of a URL object.
BUFFER should be a complete URL buffer as returned by `url-retrieve'. BUFFER should be a complete URL buffer as returned by `url-retrieve'.
If the headers specify a coding-system, it is applied to the body before it is inserted. If the headers specify a coding-system (and current buffer is multibyte),
it is applied to the body before it is inserted.
Returns a list of the form (SIZE CHARSET), where SIZE is the size in bytes Returns a list of the form (SIZE CHARSET), where SIZE is the size in bytes
of the inserted text and CHARSET is the charset that was specified in the header, of the inserted text and CHARSET is the charset that was specified in the header,
or nil if none was found. or nil if none was found.
...@@ -311,12 +312,13 @@ They count bytes from the beginning of the body." ...@@ -311,12 +312,13 @@ They count bytes from the beginning of the body."
(buffer-substring (+ (point-min) beg) (buffer-substring (+ (point-min) beg)
(if end (+ (point-min) end) (point-max))) (if end (+ (point-min) end) (point-max)))
(buffer-string)))) (buffer-string))))
(charset (mail-content-type-get (mm-handle-type handle) (charset (if enable-multibyte-characters
'charset))) (mail-content-type-get (mm-handle-type handle)
'charset))))
(mm-destroy-parts handle) (mm-destroy-parts handle)
(if charset (insert (if charset
(insert (mm-decode-string data (mm-charset-to-coding-system charset))) (mm-decode-string data (mm-charset-to-coding-system charset))
(insert data)) data))
(list (length data) charset))) (list (length data) charset)))
(defvar url-http-codes) (defvar url-http-codes)
...@@ -349,23 +351,10 @@ if it had been inserted from a file named URL." ...@@ -349,23 +351,10 @@ if it had been inserted from a file named URL."
(defun url-insert-file-contents (url &optional visit beg end replace) (defun url-insert-file-contents (url &optional visit beg end replace)
(let ((buffer (url-retrieve-synchronously url))) (let ((buffer (url-retrieve-synchronously url)))
(unless buffer (signal 'file-error (list url "No Data"))) (unless buffer (signal 'file-error (list url "No Data")))
(with-current-buffer buffer (when (fboundp 'url-http--insert-file-helper)
;; XXX: This is HTTP/S specific and should be moved to url-http ;; XXX: This is HTTP/S specific and should be moved to url-http
;; instead. See bug#17549. ;; instead. See bug#17549.
(when (bound-and-true-p url-http-response-status) (url-http--insert-file-helper buffer url visit))
;; Don't signal an error if VISIT is non-nil, because
;; 'insert-file-contents' doesn't. This is required to
;; support, e.g., 'browse-url-emacs', which is a fancy way of
;; visiting the HTML source of a URL: in that case, we want to
;; display a file buffer even if the URL does not exist and
;; 'url-retrieve-synchronously' returns 404 or whatever.
(unless (or visit
(and (>= url-http-response-status 200)
(< url-http-response-status 300)))
(let ((desc (nth 2 (assq url-http-response-status url-http-codes))))
(kill-buffer buffer)
;; Signal file-error per bug#16733.
(signal 'file-error (list url desc))))))
(url-insert-buffer-contents buffer url visit beg end replace))) (url-insert-buffer-contents buffer url visit beg end replace)))
(put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents) (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
......
...@@ -530,6 +530,23 @@ work correctly." ...@@ -530,6 +530,23 @@ work correctly."
(declare-function gnutls-peer-status "gnutls.c" (proc)) (declare-function gnutls-peer-status "gnutls.c" (proc))
(declare-function gnutls-negotiate "gnutls.el" t t) (declare-function gnutls-negotiate "gnutls.el" t t)
(defun url-http--insert-file-helper (buffer url &optional visit)
(with-current-buffer buffer
(when (bound-and-true-p url-http-response-status)
;; Don't signal an error if VISIT is non-nil, because
;; 'insert-file-contents' doesn't. This is required to
;; support, e.g., 'browse-url-emacs', which is a fancy way of
;; visiting the HTML source of a URL: in that case, we want to
;; display a file buffer even if the URL does not exist and
;; 'url-retrieve-synchronously' returns 404 or whatever.
(unless (or visit
(and (>= url-http-response-status 200)
(< url-http-response-status 300)))
(let ((desc (nth 2 (assq url-http-response-status url-http-codes))))
(kill-buffer buffer)
;; Signal file-error per bug#16733.
(signal 'file-error (list url desc)))))))
(defun url-http-parse-headers () (defun url-http-parse-headers ()
"Parse and handle HTTP specific headers. "Parse and handle HTTP specific headers.
Return t if and only if the current buffer is still active and Return t if and only if the current buffer is still active and
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment