Merge branch 'master' into staging

6 files changed, 375 insertions, 23 deletions

diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index ca104f7c75..1077215671 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -129,6 +129,7 @@
                              (phases '(@ (guix build linux-module-build-system)
                                          %standard-phases))
                              (outputs '("out"))
+                             (make-flags ''())
                              (system (%current-system))
                              (guile #f)
                              (substitutable? #t)
@@ -156,6 +157,7 @@
                      #:arch ,(system->arch (or target system))
                      #:tests? ,tests?
                      #:outputs %outputs
+                     #:make-flags ,make-flags
                      #:inputs %build-inputs)))
 
   (define guile-for-build
@@ -181,6 +183,7 @@
           target native-drvs target-drvs
           (guile #f)
           (outputs '("out"))
+          (make-flags ''())
           (search-paths '())
           (native-search-paths '())
           (tests? #f)
@@ -228,6 +231,7 @@
                              #:target ,target
                              #:arch ,(system->arch (or target system))
                              #:outputs %outputs
+                             #:make-flags ,make-flags
                              #:inputs %build-target-inputs
                              #:native-inputs %build-host-inputs
                              #:search-paths
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 73d6b101f6..d51d76f94b 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -58,12 +58,13 @@
 
 ;; This block was copied from make-linux-libre--only took the "modules_install"
 ;; part.
-(define* (install #:key inputs native-inputs outputs #:allow-other-keys)
+(define* (install #:key make-flags inputs native-inputs outputs
+                  #:allow-other-keys)
   (let* ((out (assoc-ref outputs "out"))
          (moddir (string-append out "/lib/modules")))
     ;; Install kernel modules
     (mkdir-p moddir)
-    (invoke "make" "-C"
+    (apply invoke "make" "-C"
             (string-append (assoc-ref inputs "linux-module-builder")
                            "/lib/modules/build")
             (string-append "M=" (getcwd))
@@ -76,7 +77,8 @@
             (string-append "INSTALL_PATH=" out)
             (string-append "INSTALL_MOD_PATH=" out)
             "INSTALL_MOD_STRIP=1"
-            "modules_install")))
+            "modules_install"
+            (or make-flags '()))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
@@ -84,7 +86,8 @@
     (replace 'build build)
     (replace 'install install)))
 
-(define* (linux-module-build #:key inputs (phases %standard-phases)
+(define* (linux-module-build #:key inputs
+                             (phases %standard-phases)
                              #:allow-other-keys #:rest args)
   "Build the given package, applying all of PHASES in order, with a Linux
 kernel in attendance."
diff --git a/guix/combinators.scm b/guix/combinators.scm
index 11cad62ccf..4707b59363 100644
--- a/guix/combinators.scm
+++ b/guix/combinators.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,7 +57,7 @@
            (call-with-values
                (lambda () (proc (car lst1) (car lst2) result1 result2))
              (lambda (result1 result2)
-               (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
+               (loop result1 result2 (cdr lst1) (cdr lst2)))))))))
 
 (define (fold-tree proc init children roots)
   "Call (PROC NODE RESULT) for each node in the tree that is reachable from
diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm
new file mode 100644
index 0000000000..b73f957105
--- /dev/null
+++ b/guix/git-authenticate.scm
@@ -0,0 +1,282 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix git-authenticate)
+  #:use-module (git)
+  #:use-module (guix base16)
+  #:use-module (guix i18n)
+  #:use-module (guix openpgp)
+  #:use-module ((guix utils)
+                #:select (cache-directory with-atomic-file-output))
+  #:use-module ((guix build utils)
+                #:select (mkdir-p))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match)
+  #:autoload   (ice-9 pretty-print) (pretty-print)
+  #:export (read-authorizations
+            commit-signing-key
+            commit-authorized-keys
+            authenticate-commit
+            authenticate-commits
+            load-keyring-from-reference
+            previously-authenticated-commits
+            cache-authenticated-commit
+
+            git-authentication-error?
+            git-authentication-error-commit
+            unsigned-commit-error?
+            unauthorized-commit-error?
+            unauthorized-commit-error-signing-key
+            signature-verification-error?
+            signature-verification-error-keyring
+            signature-verification-error-signature
+            missing-key-error?
+            missing-key-error-signature))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to authenticate a range of Git commits.  A
+;;; commit is considered "authentic" if and only if it is signed by an
+;;; authorized party.  Parties authorized to sign a commit are listed in the
+;;; '.guix-authorizations' file of the parent commit.
+;;;
+;;; Code:
+
+(define-condition-type &git-authentication-error &error
+  git-authentication-error?
+  (commit  git-authentication-error-commit))
+
+(define-condition-type &unsigned-commit-error &git-authentication-error
+  unsigned-commit-error?)
+
+(define-condition-type &unauthorized-commit-error &git-authentication-error
+  unauthorized-commit-error?
+  (signing-key unauthorized-commit-error-signing-key))
+
+(define-condition-type &signature-verification-error &git-authentication-error
+  signature-verification-error?
+  (signature signature-verification-error-signature)
+  (keyring   signature-verification-error-keyring))
+
+(define-condition-type &missing-key-error &git-authentication-error
+  missing-key-error?
+  (signature missing-key-error-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)))))
+    (unless signature
+      (raise (condition
+              (&unsigned-commit-error (commit commit-id))
+              (&message
+               (message (format #f (G_ "commit ~a lacks a signature")
+                                (oid->string 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
+                     (&signature-verification-error (commit commit-id)
+                                                    (signature signature)
+                                                    (keyring keyring))
+                     (&message
+                      (message (format #f (G_ "signature verification failed \
+for commit ~a")
+                                       (oid->string commit-id)))))))
+            ('missing-key
+             (raise (condition
+                     (&missing-key-error (commit commit-id)
+                                         (signature signature))
+                     (&message
+                      (message (format #f (G_ "could not authenticate \
+commit ~a: key ~a is missing")
+                                       (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
+                              #:key (default-authorizations '()))
+  "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
+Raise an error when authentication fails.  If one of the parent commits does
+not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
+  (define id
+    (commit-id commit))
+
+  (define signing-key
+    (commit-signing-key repository id keyring))
+
+  (unless (member (openpgp-public-key-fingerprint signing-key)
+                  (commit-authorized-keys repository commit
+                                          default-authorizations))
+    (raise (condition
+            (&unauthorized-commit-error (commit id)
+                                        (signing-key signing-key))
+            (&message
+             (message (format #f (G_ "commit ~a not signed by an authorized \
+key: ~a")
+                              (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 reference BRANCH-ALL))
+         (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
+                               (default-authorizations '())
+                               (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.
+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
+                                             #:default-authorizations
+                                             default-authorizations)))
+            (match (assq signer stats)
+              (#f          (cons `(,signer . 1) stats))
+              ((_ . count) (cons `(,signer . ,(+ count 1))
+                                 (alist-delete signer stats))))))
+        '()
+        commits))
+
+
+;;;
+;;; Caching.
+;;;
+
+(define (authenticated-commit-cache-file)
+  "Return the name of the file that contains the cache of
+previously-authenticated commits."
+  (string-append (cache-directory) "/authentication/channels/guix"))
+
+(define (previously-authenticated-commits)
+  "Return the previously-authenticated commits as a list of commit IDs (hex
+strings)."
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file (authenticated-commit-cache-file)
+        read))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          '()
+          (apply throw args)))))
+
+(define (cache-authenticated-commit commit-id)
+  "Record in ~/.cache COMMIT-ID and its closure as authenticated (only
+COMMIT-ID is written to cache, though)."
+  (define %max-cache-length
+    ;; Maximum number of commits in cache.
+    200)
+
+  (let ((lst  (delete-duplicates
+               (cons commit-id (previously-authenticated-commits))))
+        (file (authenticated-commit-cache-file)))
+    (mkdir-p (dirname file))
+    (with-atomic-file-output file
+      (lambda (port)
+        (let ((lst (if (> (length lst) %max-cache-length)
+                       (take lst %max-cache-length) ;truncate
+                       lst)))
+          (chmod port #o600)
+          (display ";; List of previously-authenticated commits.\n\n"
+                   port)
+          (pretty-print lst port))))))
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
index 566660e85e..c77c544e03 100644
--- a/guix/tests/git.scm
+++ b/guix/tests/git.scm
@@ -21,6 +21,7 @@
   #:use-module ((guix git) #:select (with-repository))
   #:use-module (guix utils)
   #:use-module (guix build utils)
+  #:use-module ((guix tests gnupg) #:select (with-environment-variables))
   #:use-module (ice-9 match)
   #:use-module (ice-9 control)
   #:export (git-command
@@ -30,24 +31,6 @@
 (define git-command
   (make-parameter "git"))
 
-(define (call-with-environment-variables variables thunk)
-  "Call THUNK with the environment VARIABLES set."
-  (let ((environment (environ)))
-    (dynamic-wind
-      (lambda ()
-        (for-each (match-lambda
-                    ((variable value)
-                     (setenv variable value)))
-                  variables))
-      thunk
-      (lambda ()
-        (environ environment)))))
-
-(define-syntax-rule (with-environment-variables variables exp ...)
-  "Evaluate EXP with the given environment VARIABLES set."
-  (call-with-environment-variables variables
-                                   (lambda () exp ...)))
-
 (define (populate-git-repository directory directives)
   "Initialize a new Git checkout and repository in DIRECTORY and apply
 DIRECTIVES.  Each element of DIRECTIVES is an sexp like:
@@ -97,6 +80,9 @@ Return DIRECTORY on success."
       ((('commit text) rest ...)
        (git "commit" "-m" text)
        (loop rest))
+      ((('commit text ('signer fingerprint)) rest ...)
+       (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint))
+       (loop rest))
       ((('tag name) rest ...)
        (git "tag" name)
        (loop rest))
@@ -108,6 +94,10 @@ Return DIRECTORY on success."
        (loop rest))
       ((('merge branch message) rest ...)
        (git "merge" branch "-m" message)
+       (loop rest))
+      ((('merge branch message ('signer fingerprint)) rest ...)
+       (git "merge" branch "-m" message
+            (string-append "--gpg-sign=" fingerprint))
        (loop rest)))))
 
 (define (call-with-temporary-git-repository directives proc)
diff --git a/guix/tests/gnupg.scm b/guix/tests/gnupg.scm
new file mode 100644
index 0000000000..6e7fdbcf65
--- /dev/null
+++ b/guix/tests/gnupg.scm
@@ -0,0 +1,72 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests gnupg)
+  #:use-module (guix utils)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:export (gpg-command
+            gpgconf-command
+            with-fresh-gnupg-setup
+
+            with-environment-variables))
+
+(define (call-with-environment-variables variables thunk)
+  "Call THUNK with the environment VARIABLES set."
+  (let ((environment (environ)))
+    (dynamic-wind
+      (lambda ()
+        (for-each (match-lambda
+                    ((variable value)
+                     (setenv variable value)))
+                  variables))
+      thunk
+      (lambda ()
+        (environ environment)))))
+
+(define-syntax-rule (with-environment-variables variables exp ...)
+  "Evaluate EXP with the given environment VARIABLES set."
+  (call-with-environment-variables variables
+                                   (lambda () exp ...)))
+
+(define gpg-command
+  (make-parameter "gpg"))
+
+(define gpgconf-command
+  (make-parameter "gpgconf"))
+
+(define (call-with-fresh-gnupg-setup imported thunk)
+  (call-with-temporary-directory
+   (lambda (home)
+     (with-environment-variables `(("GNUPGHOME" ,home))
+       (dynamic-wind
+         (lambda ()
+           (for-each (lambda (file)
+                       (invoke (gpg-command) "--import" file))
+                     imported))
+         thunk
+         (lambda ()
+           ;; Terminate 'gpg-agent' & co.
+           (invoke (gpgconf-command) "--kill" "all")))))))
+
+(define-syntax-rule (with-fresh-gnupg-setup imported exp ...)
+  "Evaluate EXP in the context of a fresh GnuPG setup where all the files
+listed in IMPORTED, and only them, have been imported.  This sets 'GNUPGHOME'
+such that the user's real GnuPG files are left untouched.  The 'gpg-agent'
+process is terminated afterwards."
+  (call-with-fresh-gnupg-setup imported (lambda () exp ...)))