=== modified file 'lisp/emacs-lisp/package.el' --- lisp/emacs-lisp/package.el 2013-06-15 15:36:11 +0000 +++ lisp/emacs-lisp/package.el 2013-06-16 11:05:16 +0000 @@ -229,6 +229,15 @@ :group 'package :version "24.1") +(defcustom package-signed-archives '("gnu") + "An list of archives whose contents are signed. + +Signed archives trigger verification of each package's contents." + :type '(list string :tag "Archive name") + :risky t + :group 'package + :version "24.4") + (defcustom package-pinned-packages nil "An alist of packages that are pinned to a specific archive @@ -699,20 +708,39 @@ nil nil nil 'excl)) (package--make-autoloads-and-compile name pkg-dir)))) -(defmacro package--with-work-buffer (location file &rest body) - "Run BODY in a buffer containing the contents of FILE at LOCATION. -LOCATION is the base location of a package archive, and should be -one of the URLs (or file names) specified in `package-archives'. +(defun package-archive-signed-p (archive) + "Returns whether ARCHIVE is signed. +ARCHIVE is a package archive in the form (NAME . LOCATION) and should +be specified in `package-archives'." + (member (car archive) package-signed-archives)) + +(defmacro package--with-work-buffer (archive file &rest body) + "Run BODY in a buffer containing the contents of FILE at ARCHIVE. +ARCHIVE is a package archive in the form (NAME . LOCATION) and should +be specified in `package-archives'. FILE is the name of a file relative to that base location. -This macro retrieves FILE from LOCATION into a temporary buffer, -and evaluates BODY while that buffer is current. This work -buffer is killed afterwards. Return the last value in BODY." - `(let* ((http (string-match "\\`https?:" ,location)) +This macro retrieves FILE from ARCHIVE into a temporary buffer, +checks its signature if the ARCHIVE is defined to be signed by +`package-signed-archives', and evaluates BODY while that buffer +is current. This work buffer is killed afterwards. Return the +last value in BODY." + `(let* ((archive-name (car ,archive)) + (location (cdr ,archive)) + (sign-file (concat ,file ".gpgsig")) + (http (string-match "\\`https?:" location)) + (sign (when (package-archive-signed-p archive) + (concat location sign-file))) (buffer (if http - (url-retrieve-synchronously (concat ,location ,file)) - (generate-new-buffer "*package work buffer*")))) + (url-retrieve-synchronously url) + (generate-new-buffer "*package work buffer*"))) + (sign-buffer (when sign + (if http + ;; Retrieve the signature file too. + (url-retrieve-synchronously + (concat location sign-file)) + (generate-new-buffer "*package sign buffer*"))))) (prog1 (with-current-buffer buffer (if http @@ -720,12 +748,32 @@ (re-search-forward "^$" nil 'move) (forward-char) (delete-region (point-min) (point))) - (unless (file-name-absolute-p ,location) + (unless (file-name-absolute-p location) (error "Archive location %s is not an absolute file name" - ,location)) - (insert-file-contents (expand-file-name ,file ,location))) + location)) + (insert-file-contents (expand-file-name ,file location))) + (when sign-buffer + (with-current-buffer sign-buffer + (if http + (progn (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point))) + ;; No need to check the location again like we did above. + (insert-file-contents (expand-file-name sign-file location))) + (unless (package--verify-signature archive sign-buffer buffer) + (let ((q (format "Can't verify .gpgsig for %s" + (concat location ,file)))) + (unless (y-or-n-p (concat q "; continue? (y/n)")) + (error q)))))) ,@body) - (kill-buffer buffer)))) + (kill-buffer buffer) + (when sign-buffer + (kill-buffer sign-buffer))))) + +(defun package--verify-signature archive sign-buffer buffer + "Verify SIGN-BUFFER signs BUFFER correctly for ARCHIVE." + t) (defun package-handle-response () "Handle the response from a `url-retrieve-synchronously' call. @@ -742,16 +790,16 @@ (defun package-download-single (name version desc requires) "Download and install a single-file package." - (let ((location (package-archive-base name)) + (let ((archive (package-archive-for name)) (file (concat (symbol-name name) "-" version ".el"))) - (package--with-work-buffer location file + (package--with-work-buffer archive file (package-unpack-single name version desc requires)))) (defun package-download-tar (name version) "Download and install a tar package." - (let ((location (package-archive-base name)) + (let ((archive (package-archive-for name)) (file (concat (symbol-name name) "-" version ".tar"))) - (package--with-work-buffer location file + (package--with-work-buffer archive file (package-unpack name version)))) (defvar package--initialized nil) @@ -875,6 +923,7 @@ (defun package--add-to-archive-contents (package archive) "Add the PACKAGE from the given ARCHIVE if necessary. PACKAGE should have the form (NAME . PACKAGE--AC-DESC). + Also, add the originating archive to the `package-desc' structure." (let* ((name (car package)) (version (package--ac-desc-version (cdr package))) @@ -1094,10 +1143,10 @@ (error "Package `%s' is a system package, not deleting" (package-desc-full-name pkg-desc))))) -(defun package-archive-base (name) +(defun package-archive-for (name) "Return the archive containing the package NAME." (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) - (cdr (assoc (package-desc-archive desc) package-archives)))) + (assoc (package-desc-archive desc) package-archives))) (defun package--download-one-archive (archive file) "Retrieve an archive file FILE from ARCHIVE, and cache it. @@ -1106,7 +1155,7 @@ \"archives/NAME/archive-contents\" in `package-user-dir'." (let* ((dir (expand-file-name (format "archives/%s" (car archive)) package-user-dir))) - (package--with-work-buffer (cdr archive) file + (package--with-work-buffer archive file ;; Read the retrieved buffer to make sure it is valid (e.g. it ;; may fetch a URL redirect page). (when (listp (read buffer)) @@ -1229,7 +1278,11 @@ 'font-lock-face 'font-lock-builtin-face) " Alternate version available") (insert "Available")) - (insert " from " archive) + (insert " from " (if (package-archive-signed-p + (assoc archive package-archives)) + "signed" + "unsigned") + " " archive) (insert " -- ") (let ((button-text (if (display-graphic-p) "Install" "[Install]")) (button-face (if (display-graphic-p) @@ -1287,7 +1340,7 @@ ;; For elpa packages, try downloading the commentary. If that ;; fails, try an existing readme file in `package-user-dir'. (cond ((condition-case nil - (package--with-work-buffer (package-archive-base package) + (package--with-work-buffer (package-archive-for package) (concat package-name "-readme.txt") (setq buffer-file-name (expand-file-name readme package-user-dir))