summaryrefslogtreecommitdiff
path: root/guix/git-authenticate.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-06-01 17:48:11 +0200
committerLudovic Courtès <ludo@gnu.org>2020-06-05 22:54:06 +0200
commit41f443c90af57f9537eccb1a1a45c6e11b377a32 (patch)
tree99e5855f87e72d71b74f5fe0d6152c1848158208 /guix/git-authenticate.scm
parentecab53c320b1584a08f811b17a92bd9a50a50ff3 (diff)
Add (guix git-authenticate).
* build-aux/git-authenticate.scm (commit-signing-key) (read-authorizations, commit-authorized-keys, authenticate-commit) (load-keyring-from-blob, load-keyring-from-reference) (authenticate-commits, authenticated-commit-cache-file) (previously-authenticated-commits, cache-authenticated-commit): Remove. * build-aux/git-authenticate.scm (git-authenticate): Pass #:default-authorizations to 'authenticate-commits'. * guix/git-authenticate.scm: New file, with code taken from 'build-aux/git-authenticate.scm'. Remove references to '%historical-authorized-signing-keys' and add #:default-authorizations parameter instead. * Makefile.am (MODULES): Add it. (authenticate): Depend on guix/git-authenticate.go.
Diffstat (limited to 'guix/git-authenticate.scm')
-rw-r--r--guix/git-authenticate.scm244
1 files changed, 244 insertions, 0 deletions
diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm
new file mode 100644
index 0000000000..4df56fab59
--- /dev/null
+++ b/guix/git-authenticate.scm
@@ -0,0 +1,244 @@
+;;; 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))
+
+;;; 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 (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
+ (&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 \
+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
+ (&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
+ (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
+ (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))))))