[PATCHv2] package.el: check tarball signature

[Daiki Ueno]

Hi,

Thanks for the suggestion.

(Sorry for the delay, I'm just back from Boston ;-)

Eli Zaretskii <address@hidden> writes:

> Thanks, but please add a defcustom to disable this check (e.g.,
> because gnupg isn't installed, and isn't going to be).

Done.  Now it has package-check-signature option, which can be set
either: nil (no signature verification), t (always check signature), or
allow-unsigned (skip signature verification if no .sig file is provided,
default).

Actually I wondered whether it should be a per-archive option rather
than a global option.  But I'd leave it as global, for simplicity.

> In general, I think .sig files are there for those who want to verify
> the packages, but users should not be forced to do that as a
> prerequisite for downloading.  (And no, the y-or-n-p question doesn't
> cut it: it's a nuisance to have to answer that question every time.)

Agreed.  Removed the y-or-n-p question.

Other than those, I changed a bit:

* display "unsigned" status on the package listing and the description
  buffer.

* fixed the verification logic.  The .sig file might contain multiple
  signatures and it should be considered as verified when one of those
  is good.

* import the default keyring from <data-directory>/package-keyring.gpg.

=== modified file 'lisp/emacs-lisp/package.el'
--- lisp/emacs-lisp/package.el  2013-10-01 15:52:53 +0000
+++ lisp/emacs-lisp/package.el  2013-10-02 05:48:13 +0000
@@ -206,6 +206,7 @@
 (defvar Info-directory-list)
 (declare-function info-initialize "info" ())
 (declare-function url-http-parse-response "url-http" ())
+(declare-function url-http-file-exists-p "url-http" (url))
 (declare-function lm-header "lisp-mnt" (header))
 (declare-function lm-commentary "lisp-mnt" (&optional file))
 (defvar url-http-end-of-headers)
@@ -285,6 +286,15 @@
   :group 'package
   :version "24.1")
 
+(defcustom package-check-signature 'allow-unsigned
+  "Whether to check package signatures when installing."
+  :type '(choice (const nil :tag "Never")
+                (const allow-unsigned :tag "Allow unsigned")
+                (const t :tag "Check always"))
+  :risky t
+  :group 'package
+  :version "24.1")
+
 (defvar package--default-summary "No description available.")
 
 (cl-defstruct (package-desc
@@ -340,7 +350,9 @@
 `dir'  The directory where the package is installed (if installed),
        `builtin' if it is built-in, or nil otherwise.
 
-`extras' Optional alist of additional keyword-value pairs."
+`extras' Optional alist of additional keyword-value pairs.
+
+`signed' Flag to indicate that the package is signed by provider."
   name
   version
   (summary package--default-summary)
@@ -348,7 +360,8 @@
   kind
   archive
   dir
-  extras)
+  extras
+  signed)
 
 ;; Pseudo fields.
 (defun package-desc-full-name (pkg-desc)
@@ -428,7 +441,8 @@
 (defun package-load-descriptor (pkg-dir)
   "Load the description file in directory PKG-DIR."
   (let ((pkg-file (expand-file-name (package--description-file pkg-dir)
-                                    pkg-dir)))
+                                    pkg-dir))
+       (signed-file (concat pkg-dir ".signed")))
     (when (file-exists-p pkg-file)
       (with-temp-buffer
         (insert-file-contents pkg-file)
@@ -436,6 +450,8 @@
         (let ((pkg-desc (package-process-define-package
                          (read (current-buffer)) pkg-file)))
           (setf (package-desc-dir pkg-desc) pkg-dir)
+         (if (file-exists-p signed-file)
+             (setf (package-desc-signed pkg-desc) t))
           pkg-desc)))))
 
 (defun package-load-all-descriptors ()
@@ -766,13 +782,90 @@
       (error "Error during download request:%s"
             (buffer-substring-no-properties (point) (line-end-position))))))
 
+(defun package--archive-file-exists-p (location file)
+  (let ((http (string-match "\\`https?:" location)))
+    (if http
+       (progn
+         (require 'url-http)
+         (url-http-file-exists-p (concat location file)))
+      (file-exists-p (expand-file-name location file)))))
+
+(declare-function epg-make-context "epg"
+                 (&optional protocol armor textmode include-certs
+                            cipher-algorithm
+                            digest-algorithm
+                            compress-algorithm))
+(declare-function epg-context-set-home-directory "epg" (context directory))
+(declare-function epg-verify-string "epg" (context signature
+                                                  &optional signed-text))
+(declare-function epg-context-result-for "epg" (context name))
+(declare-function epg-signature-status "epg" (signature))
+(declare-function epg-signature-to-string "epg" (signature))
+
+(defun package--check-signature (pkg-desc)
+  "Check signature of a package.
+GnuPG keyring is located under \"gnupg\" in `package-user-dir'."
+  (let ((location (package-archive-base pkg-desc))
+       (context (epg-make-context 'OpenPGP))
+       (homedir (expand-file-name "gnupg" package-user-dir))
+       (sig-file (concat (package-desc-full-name pkg-desc)
+                         (package-desc-suffix pkg-desc)
+                         ".sig"))
+       sig-content
+       good-signatures)
+    (condition-case-unless-debug error
+       (setq sig-content (package--with-work-buffer location sig-file
+                           (buffer-string)))
+      (error "Failed to download %s: %S" sig-file (cdr error)))
+    (epg-context-set-home-directory context homedir)
+    (epg-verify-string context sig-content (buffer-string))
+    ;; The .sig file may contain multiple signatures.  Success if one
+    ;; of the signatures is good.
+    (setq good-signatures
+         (delq nil (mapcar (lambda (sig)
+                             (if (eq (epg-signature-status sig) 'good)
+                                 sig))
+                           (epg-context-result-for context 'verify))))
+    (if (null good-signatures)
+       (error "Failed to verify signature %s: %S"
+              sig-file
+              (mapcar #'epg-signature-to-string
+                      (epg-context-result-for context 'verify))))))
+
 (defun package-install-from-archive (pkg-desc)
   "Download and install a tar package."
   (let ((location (package-archive-base pkg-desc))
        (file (concat (package-desc-full-name pkg-desc)
-                      (package-desc-suffix pkg-desc))))
+                      (package-desc-suffix pkg-desc)))
+       (sig-file (concat (package-desc-full-name pkg-desc)
+                         (package-desc-suffix pkg-desc)
+                         ".sig"))
+       signed pkg-descs)
     (package--with-work-buffer location file
-      (package-unpack pkg-desc))))
+      (if package-check-signature
+         (if (package--archive-file-exists-p location sig-file)
+             (progn
+               (package--check-signature pkg-desc)
+               (setq signed t))
+           (unless (eq package-check-signature 'allow-unsigned)
+             (error "Unsigned package: `%s'"
+                    (package-desc-name pkg-desc)))))
+      (package-unpack pkg-desc))
+    ;; Here the package has been installed successfully, mark it as
+    ;; signed if appropriate.
+    (when signed
+      ;; Create an empty NAME-VERSION.signed file, which indicates the
+      ;; signature of the package was verified on installation.
+      (write-region "" nil (expand-file-name
+                           (concat (package-desc-full-name pkg-desc)
+                                   ".signed")
+                           package-user-dir))
+      ;; Update the old pkg-desc which will be shown on the description buffer.
+      (setf (package-desc-signed pkg-desc) t)
+      ;; Update the new (activated) pkg-desc as well.
+      (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))
+      (if pkg-descs
+         (setf (package-desc-signed (car pkg-descs)) t)))))
 
 (defvar package--initialized nil)
 
@@ -1145,6 +1238,21 @@
                      (car archive)))))
   (package-read-all-archive-contents))
 
+(declare-function epg-check-configuration "epg-config"
+                 (config &optional minimum-version))
+(declare-function epg-configuration "epg-config" ())
+(declare-function epg-import-keys-from-file "epg" (context keys))
+
+(defun package--import-default-keyring ()
+  (let* ((context (epg-make-context 'OpenPGP))
+        (homedir (expand-file-name "gnupg" package-user-dir))
+        (default-keyring (expand-file-name "package-keyring.gpg"
+                                           data-directory)))
+    (when (file-exists-p default-keyring)
+      (make-directory homedir t)
+      (epg-context-set-home-directory context homedir)
+      (epg-import-keys-from-file context default-keyring))))
+
 ;;;###autoload
 (defun package-initialize (&optional no-activate)
   "Load Emacs Lisp packages, and activate them.
@@ -1157,6 +1265,11 @@
   (unless no-activate
     (dolist (elt package-alist)
       (package-activate (car elt))))
+  (condition-case-unless-debug nil
+      (progn
+       (epg-check-configuration (epg-configuration))
+       (package--import-default-keyring))
+    (error (message "Cannot import default keyring")))
   (setq package--initialized t))
 
 
@@ -1209,7 +1322,8 @@
          (homepage (if desc (cdr (assoc :url (package-desc-extras desc)))))
          (built-in (eq pkg-dir 'builtin))
          (installable (and archive (not built-in)))
-         (status (if desc (package-desc-status desc) "orphan")))
+         (status (if desc (package-desc-status desc) "orphan"))
+         (signed (if desc (package-desc-signed desc))))
     (prin1 name)
     (princ " is ")
     (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a "))
@@ -1233,9 +1347,11 @@
                     (not (package-built-in-p name version)))
               (insert "',\n             shadowing a "
                       (propertize "built-in package"
-                                  'font-lock-face 'font-lock-builtin-face)
-                      ".")
-            (insert "'.")))
+                                  'font-lock-face 'font-lock-builtin-face))
+            (insert "'"))
+          (if signed
+              (insert ".")
+            (insert " (unsigned).")))
          (installable
            (insert (capitalize status))
           (insert " from " (format "%s" archive))
@@ -1449,7 +1565,8 @@
          (dir (package-desc-dir pkg-desc))
          (lle (assq name package-load-list))
          (held (cadr lle))
-         (version (package-desc-version pkg-desc)))
+         (version (package-desc-version pkg-desc))
+         (signed (package-desc-signed pkg-desc)))
     (cond
      ((eq dir 'builtin) "built-in")
      ((and lle (null held)) "disabled")
@@ -1463,7 +1580,9 @@
      (dir                               ;One of the installed packages.
       (cond
        ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted")
-       ((eq pkg-desc (cadr (assq name package-alist))) "installed")
+       ((eq pkg-desc (cadr (assq name package-alist))) (if signed
+                                                          "installed"
+                                                        "unsigned"))
        (t "obsolete")))
      (t
       (let* ((ins (cadr (assq name package-alist)))
@@ -1473,7 +1592,9 @@
           (if (memq name package-menu--new-package-list)
               "new" "available"))
          ((version-list-< version ins-v) "obsolete")
-         ((version-list-= version ins-v) "installed")))))))
+         ((version-list-= version ins-v) (if signed
+                                            "installed"
+                                          "unsigned"))))))))
 
 (defun package-menu--refresh (&optional packages)
   "Re-populate the `tabulated-list-entries'.
@@ -1532,6 +1653,7 @@
                (`"held"      'font-lock-constant-face)
                (`"disabled"  'font-lock-warning-face)
                (`"installed" 'font-lock-comment-face)
+               (`"unsigned"  'font-lock-warning-face)
                (_            'font-lock-warning-face)))) ; obsolete.
     (list pkg-desc
          (vector (list (symbol-name (package-desc-name pkg-desc))
@@ -1570,7 +1692,7 @@
 (defun package-menu-mark-delete (&optional _num)
   "Mark a package for deletion and move to the next line."
   (interactive "p")
-  (if (member (package-menu-get-status) '("installed" "obsolete"))
+  (if (member (package-menu-get-status) '("installed" "obsolete" "unsigned"))
       (tabulated-list-put-tag "D" t)
     (forward-line)))
 
@@ -1738,6 +1860,8 @@
          ((string= sB "available") nil)
          ((string= sA "installed") t)
          ((string= sB "installed") nil)
+         ((string= sA "unsigned") t)
+         ((string= sB "unsigned") nil)
          ((string= sA "held") t)
          ((string= sB "held") nil)
          ((string= sA "built-in") t)

Regards,
-- 
Daiki Ueno