;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020, 2024 Ludovic Courtès ;;; ;;; 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 . (define-module (guix scripts git authenticate) #:use-module (git) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix git-authenticate) #:autoload (guix openpgp) (openpgp-format-fingerprint openpgp-public-key-fingerprint) #:use-module ((guix channels) #:select (openpgp-fingerprint)) #:use-module ((guix git) #:select (with-git-error-handling)) #:use-module (guix progress) #:use-module (guix base64) #:autoload (rnrs bytevectors) (bytevector-length) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-71) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (guix-git-authenticate)) ;;; Commentary: ;;; ;;; Authenticate a Git checkout by reading '.guix-authorizations' files and ;;; following the "authorizations invariant" also used by (guix channels). ;;; ;;; Code: (define %options ;; Specifications of the command-line options. (list (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix git authenticate"))) (option '(#\r "repository") #t #f (lambda (opt name arg result) (alist-cons 'directory arg result))) (option '(#\e "end") #t #f (lambda (opt name arg result) (alist-cons 'end-commit (string->oid arg) result))) (option '(#\k "keyring") #t #f (lambda (opt name arg result) (alist-cons 'keyring-reference arg result))) (option '("cache-key") #t #f (lambda (opt name arg result) (alist-cons 'cache-key arg result))) (option '("historical-authorizations") #t #f (lambda (opt name arg result) (alist-cons 'historical-authorizations arg result))) (option '("stats") #f #f (lambda (opt name arg result) (alist-cons 'show-stats? #t result))))) (define %default-options '()) (define (config-value config key) "Return the config value associated with KEY, or #f if no such config was found." (catch 'git-error (lambda () (config-entry-value (config-get-entry config key))) (const #f))) (define (configured-introduction repository) "Return two values: the commit and signer fingerprint (strings) as configured in REPOSITORY. Error out if one or both were missing." (let* ((config (repository-config repository)) (commit (config-value config "guix.authentication.introduction-commit")) (signer (config-value config "guix.authentication.introduction-signer"))) (unless (and commit signer) (leave (G_ "unknown introductory commit and signer~%"))) (values commit signer))) (define (configured-keyring-reference repository) "Return the keyring reference configured in REPOSITORY or #f if missing." (let ((config (repository-config repository))) (config-value config "guix.authentication.keyring"))) (define (configured? repository) "Return true if REPOSITORY already container introduction info in its 'config' file." (let ((config (repository-config repository))) (and (config-value config "guix.authentication.introduction-commit") (config-value config "guix.authentication.introduction-signer")))) (define* (record-configuration repository #:key commit signer keyring-reference) "Record COMMIT, SIGNER, and KEYRING-REFERENCE in the 'config' file of REPOSITORY." (define directory (repository-directory repository)) (define config-file (in-vicinity directory "config")) (call-with-port (open-file config-file "a") (lambda (port) (format port " # Added by 'guix git authenticate'. [guix \"authentication\"] introduction-commit = ~a introduction-signer = ~a keyring = ~a~%" commit signer keyring-reference))) (info (G_ "introduction and keyring configuration recorded in '~a'~%") config-file)) (define (show-stats stats) "Display STATS, an alist containing commit signing stats as returned by 'authenticate-repository'." (format #t (G_ "Signing statistics:~%")) (for-each (match-lambda ((signer . count) (format #t " ~a ~10d~%" (openpgp-format-fingerprint (openpgp-public-key-fingerprint signer)) count))) (sort stats (match-lambda* (((_ . count1) (_ . count2)) (> count1 count2)))))) (define (show-help) (display (G_ "Usage: guix git authenticate COMMIT SIGNER [OPTIONS...] Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n")) (display (G_ " -r, --repository=DIRECTORY open the Git repository at DIRECTORY")) (display (G_ " -k, --keyring=REFERENCE load keyring from REFERENCE, a Git branch")) (display (G_ " --stats display commit signing statistics upon completion")) (display (G_ " --cache-key=KEY cache authenticated commits under KEY")) (display (G_ " --historical-authorizations=FILE read historical authorizations from FILE")) (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) ;;; ;;; Entry point. ;;; (define (guix-git-authenticate . args) (define options (parse-command-line args %options (list %default-options) #:build-options? #f)) (define (command-line-arguments lst) (reverse (filter-map (match-lambda (('argument . arg) arg) (_ #f)) lst))) (define commit-short-id (compose (cut string-take <> 7) oid->string commit-id)) (define (openpgp-fingerprint* str) (unless (string-every (char-set-union char-set:hex-digit char-set:whitespace) str) (leave (G_ "~a: invalid OpenPGP fingerprint~%") str)) (let ((fingerprint (openpgp-fingerprint str))) (unless (= 20 (bytevector-length fingerprint)) (leave (G_ "~a: wrong length for OpenPGP fingerprint~%") str)) fingerprint)) (define (make-reporter start-commit end-commit commits) (format (current-error-port) (G_ "Authenticating commits ~a to ~a (~h new \ commits)...~%") (commit-short-id start-commit) (commit-short-id end-commit) (length commits)) (if (isatty? (current-error-port)) (progress-reporter/bar (length commits)) progress-reporter/silent)) (define (missing-arguments) (leave (G_ "wrong number of arguments; \ expected COMMIT and SIGNER~%"))) (with-error-handling (with-git-error-handling (let* ((show-stats? (assoc-ref options 'show-stats?)) (repository (repository-open (or (assoc-ref options 'directory) (repository-discover ".")))) (commit signer (match (command-line-arguments options) ((commit signer) (values commit signer)) (() (configured-introduction repository)) (_ (missing-arguments)))) (keyring (or (assoc-ref options 'keyring-reference) (configured-keyring-reference repository) "keyring")) (end (match (assoc-ref options 'end-commit) (#f (reference-target (repository-head repository))) (oid oid))) (history (match (assoc-ref options 'historical-authorizations) (#f '()) (file (call-with-input-file file read-authorizations)))) (cache-key (or (assoc-ref options 'cache-key) (repository-cache-key repository)))) (define stats (authenticate-repository repository (string->oid commit) (openpgp-fingerprint* signer) #:end end #:keyring-reference keyring #:historical-authorizations history #:cache-key cache-key #:make-reporter make-reporter)) (unless (configured? repository) (record-configuration repository #:commit commit #:signer signer #:keyring-reference keyring)) (when (and show-stats? (not (null? stats))) (show-stats stats))))))