Merge branch 'master' into staging

2 files changed, 131 insertions, 73 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index f86c79f0d0..e2495919d5 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -384,11 +384,11 @@ interface (FFI) of Guile.")
                 #:key verbose? (version (date-version-string)) system
                 (pull-version 0)
 
-                ;; For the standalone Guix, default to Guile 2.2.  For old
+                ;; For the standalone Guix, default to Guile 3.0.  For old
                 ;; versions of 'guix pull' (pre-0.15.0), we have to use the
                 ;; same Guile as the current one.
                 (guile-version (if (> pull-version 0)
-                                   "2.2"
+                                   "3.0"
                                    (effective-version)))
 
                 #:allow-other-keys
diff --git a/build-aux/git-authenticate.scm b/build-aux/git-authenticate.scm
index bb48dddc59..ab50459369 100644
--- a/build-aux/git-authenticate.scm
+++ b/build-aux/git-authenticate.scm
@@ -23,8 +23,10 @@
 
 (use-modules (git)
              (guix git)
-             (guix gnupg)
-             (guix utils)
+             (guix openpgp)
+             (guix base16)
+             ((guix utils)
+              #:select (cache-directory with-atomic-file-output))
              ((guix build utils) #:select (mkdir-p))
              (guix i18n)
              (guix progress)
@@ -33,6 +35,7 @@
              (srfi srfi-26)
              (srfi srfi-34)
              (srfi srfi-35)
+             (rnrs bytevectors)
              (rnrs io ports)
              (ice-9 match)
              (ice-9 format)
@@ -215,7 +218,8 @@
   ;; Fingerprint of authorized signing keys.
   (map (match-lambda
          ((name fingerprint)
-          (string-filter char-set:graphic fingerprint)))
+          (base16-string->bytevector
+           (string-downcase (string-filter char-set:graphic fingerprint)))))
        %committers))
 
 (define %commits-with-bad-signature
@@ -226,93 +230,148 @@
   ;; Commits lacking a signature.
   '())
 
-(define-syntax-rule (with-temporary-files file1 file2 exp ...)
-  (call-with-temporary-output-file
-   (lambda (file1 port1)
-     (call-with-temporary-output-file
-      (lambda (file2 port2)
-        exp ...)))))
-
-(define (commit-signing-key repo commit-id)
-  "Return the OpenPGP key ID that signed COMMIT-ID (an OID).  Raise an
-exception if the commit is unsigned or has an invalid signature."
+(define (commit-signing-key repo commit-id keyring)
+  "Return the OpenPGP key that signed COMMIT-ID (an OID).  Raise an exception
+if the commit is unsigned, has an invalid signature, or if its signing key is
+not in KEYRING."
   (let-values (((signature signed-data)
                 (catch 'git-error
                   (lambda ()
                     (commit-extract-signature repo commit-id))
                   (lambda _
                     (values #f #f)))))
-    (if (not signature)
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "commit ~a lacks a signature")
-                                  commit-id)))))
-        (begin
-          (with-fluids ((%default-port-encoding "UTF-8"))
-            (with-temporary-files data-file signature-file
-              (call-with-output-file data-file
-                (cut display signed-data <>))
-              (call-with-output-file signature-file
-                (cut display signature <>))
-
-              (let-values (((status data)
-                            (with-error-to-port (%make-void-port "w")
-                              (lambda ()
-                                (gnupg-verify* signature-file data-file
-                                               #:key-download 'always)))))
-                (match status
-                  ('invalid-signature
-                   ;; There's a signature but it's invalid.
-                   (raise (condition
-                           (&message
-                            (message (format #f (G_ "signature verification failed \
+    (unless signature
+      (raise (condition
+              (&message
+               (message (format #f (G_ "commit ~a lacks a signature")
+                                commit-id))))))
+
+    (let ((signature (string->openpgp-packet signature)))
+      (with-fluids ((%default-port-encoding "UTF-8"))
+        (let-values (((status data)
+                      (verify-openpgp-signature signature keyring
+                                                (open-input-string signed-data))))
+          (match status
+            ('bad-signature
+             ;; There's a signature but it's invalid.
+             (raise (condition
+                     (&message
+                      (message (format #f (G_ "signature verification failed \
 for commit ~a")
-                                             (oid->string commit-id)))))))
-                  ('missing-key
-                   (raise (condition
-                           (&message
-                            (message (format #f (G_ "could not authenticate \
+                                       (oid->string commit-id)))))))
+            ('missing-key
+             (raise (condition
+                     (&message
+                      (message (format #f (G_ "could not authenticate \
 commit ~a: key ~a is missing")
-                                             (oid->string commit-id)
-                                             data))))))
-                  ('valid-signature
-                   (match data
-                     ((fingerprint . user)
-                      fingerprint)))))))))))
-
-(define (authenticate-commit repository commit)
+                                       (oid->string commit-id)
+                                       data))))))
+            ('good-signature data)))))))
+
+(define (read-authorizations port)
+  "Read authorizations in the '.guix-authorizations' format from PORT, and
+return a list of authorized fingerprints."
+  (match (read port)
+    (('authorizations ('version 0)
+                      (((? string? fingerprints) _ ...) ...)
+                      _ ...)
+     (map (lambda (fingerprint)
+            (base16-string->bytevector
+             (string-downcase (string-filter char-set:graphic fingerprint))))
+          fingerprints))))
+
+(define* (commit-authorized-keys repository commit
+                                 #:optional (default-authorizations '()))
+  "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
+authorizations listed in its parent commits.  If one of the parent commits
+does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
+  (define (commit-authorizations commit)
+    (catch 'git-error
+      (lambda ()
+        (let* ((tree  (commit-tree commit))
+               (entry (tree-entry-bypath tree ".guix-authorizations"))
+               (blob  (blob-lookup repository (tree-entry-id entry))))
+          (read-authorizations
+           (open-bytevector-input-port (blob-content blob)))))
+      (lambda (key error)
+        (if (= (git-error-code error) GIT_ENOTFOUND)
+            default-authorizations
+            (throw key error)))))
+
+  (apply lset-intersection bytevector=?
+         (map commit-authorizations (commit-parents commit))))
+
+(define (authenticate-commit repository commit keyring)
   "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
 Raise an error when authentication fails."
   (define id
     (commit-id commit))
 
   (define signing-key
-    (commit-signing-key repository id))
+    (commit-signing-key repository id keyring))
 
-  (unless (member signing-key %authorized-signing-keys)
+  (unless (member (openpgp-public-key-fingerprint signing-key)
+                  (commit-authorized-keys repository commit
+                                          %authorized-signing-keys))
     (raise (condition
             (&message
              (message (format #f (G_ "commit ~a not signed by an authorized \
 key: ~a")
-                              (oid->string id) signing-key))))))
+                              (oid->string id)
+                              (openpgp-format-fingerprint
+                               (openpgp-public-key-fingerprint
+                                signing-key))))))))
 
   signing-key)
 
+(define (load-keyring-from-blob repository oid keyring)
+  "Augment KEYRING with the keyring available in the blob at OID, which may or
+may not be ASCII-armored."
+  (let* ((blob (blob-lookup repository oid))
+         (port (open-bytevector-input-port (blob-content blob))))
+    (get-openpgp-keyring (if (port-ascii-armored? port)
+                             (open-bytevector-input-port (read-radix-64 port))
+                             port)
+                         keyring)))
+
+(define (load-keyring-from-reference repository reference)
+  "Load the '.key' files from the tree at REFERENCE in REPOSITORY and return
+an OpenPGP keyring."
+  (let* ((reference (branch-lookup repository
+                                   (string-append "origin/" reference)
+                                   BRANCH-REMOTE))
+         (target    (reference-target reference))
+         (commit    (commit-lookup repository target))
+         (tree      (commit-tree commit)))
+    (fold (lambda (name keyring)
+            (if (string-suffix? ".key" name)
+                (let ((entry (tree-entry-bypath tree name)))
+                  (load-keyring-from-blob repository
+                                          (tree-entry-id entry)
+                                          keyring))
+                keyring))
+          %empty-keyring
+          (tree-list tree))))
+
 (define* (authenticate-commits repository commits
-                               #:key (report-progress (const #t)))
+                               #:key
+                               (keyring-reference "keyring")
+                               (report-progress (const #t)))
   "Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for
-each of them.  Return an alist showing the number of occurrences of each key."
-  (parameterize ((current-keyring (string-append (config-directory)
-                                                 "/keyrings/channels/guix.kbx")))
-    (fold (lambda (commit stats)
-            (report-progress)
-            (let ((signer (authenticate-commit repository commit)))
-              (match (assoc signer stats)
-                (#f          (cons `(,signer . 1) stats))
-                ((_ . count) (cons `(,signer . ,(+ count 1))
-                                   (alist-delete signer stats))))))
-          '()
-          commits)))
+each of them.  Return an alist showing the number of occurrences of each key.
+The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY."
+  (define keyring
+    (load-keyring-from-reference repository keyring-reference))
+
+  (fold (lambda (commit stats)
+          (report-progress)
+          (let ((signer (authenticate-commit repository commit keyring)))
+            (match (assq signer stats)
+              (#f          (cons `(,signer . 1) stats))
+              ((_ . count) (cons `(,signer . ,(+ count 1))
+                                 (alist-delete signer stats))))))
+        '()
+        commits))
 
 (define commit-short-id
   (compose (cut string-take <> 7) oid->string commit-id))
@@ -409,7 +468,10 @@ COMMIT-ID is written to cache, though)."
            (format #t (G_ "Signing statistics:~%"))
            (for-each (match-lambda
                        ((signer . count)
-                        (format #t "  ~a ~10d~%" signer count)))
+                        (format #t "  ~a ~10d~%"
+                                (openpgp-format-fingerprint
+                                 (openpgp-public-key-fingerprint signer))
+                                count)))
                      (sort stats
                            (match-lambda*
                              (((_ . count1) (_ . count2))
@@ -423,7 +485,3 @@ COMMIT-ID is written to cache, though)."
                (G_ "Usage: git-authenticate START [END]
 
 Authenticate commits START to END or the current head.\n"))))))
-
-;;; Local Variables:
-;;; eval: (put 'with-temporary-files 'scheme-indent-function 2)
-;;; End: