From patchwork Fri Jan 31 21:18:44 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: 45mg <45mg.writes@gmail.com> X-Patchwork-Id: 38071 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id D931527BBE2; Fri, 31 Jan 2025 21:20:23 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.6 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_SIGNED,DKIM_VALID,FREEMAIL_FROM,MAILING_LIST_MULTI, RCVD_IN_DNSWL_BLOCKED,RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL, RCVD_IN_VALIDITY_SAFE,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id BD30F27BBEA for ; Fri, 31 Jan 2025 21:20:20 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tdyQq-0007s4-8K; Fri, 31 Jan 2025 16:20:08 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tdyQo-0007rW-6R for guix-patches@gnu.org; Fri, 31 Jan 2025 16:20:06 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tdyQk-0002QB-MX for guix-patches@gnu.org; Fri, 31 Jan 2025 16:20:05 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=8Qcfzz6WaLO9QLkrmpAvxsmLkRJTSrWMDKbZ/+TnOvc=; b=nO/TaKbEy3Dubuqn/haXacUqJTtJiMimm3IbQON9YWdGnk+CsjLw1gUj/EUjM49cFrd4Uh6QiXAiMDiwU+QRco7D7VEYHGhPQ5DyNY8skav3S+QPz2Y0eQ5x52ht3FCLfFd1c7apjhBQqFDZ76qtpb2ZeJzUuxdzT3PmNbmSv4C00tJoTXzoFxjM5HwA/CKnu1glNSncW0HPMRepH2ABy6ftEQnbi/o5GO0QSQ2r2/52qp56fkL/90AUxX735go+wjxWcOEkb3CEXiPlfycLS5JfpY4Iv1nuMfOqgKzw6KfsFE2jTaE0P9PXXqImfxX2uXmUyWaqZX/+L+NHIZNiYw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tdyQk-0005k6-FR for guix-patches@gnu.org; Fri, 31 Jan 2025 16:20:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75981] [PATCH (WIP) v1 1/4] Add 'guix fork create'. Resent-From: 45mg <45mg.writes@gmail.com> Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 31 Jan 2025 21:20:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75981 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75981@debbugs.gnu.org Cc: Nicolas Graves , Tomas Volf <~@wolfsden.cz>, 45mg <45mg.writes@gmail.com>, Liliana Marie Prikler , Ricardo Wurmus , Attila Lendvai Received: via spool by 75981-submit@debbugs.gnu.org id=B75981.173835839722044 (code B ref 75981); Fri, 31 Jan 2025 21:20:02 +0000 Received: (at 75981) by debbugs.gnu.org; 31 Jan 2025 21:19:57 +0000 Received: from localhost ([127.0.0.1]:54945 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tdyQd-0005jT-AO for submit@debbugs.gnu.org; Fri, 31 Jan 2025 16:19:56 -0500 Received: from mail-pl1-x642.google.com ([2607:f8b0:4864:20::642]:49434) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.84_2) (envelope-from <45mg.writes@gmail.com>) id 1tdyQU-0005iu-HS for 75981@debbugs.gnu.org; Fri, 31 Jan 2025 16:19:48 -0500 Received: by mail-pl1-x642.google.com with SMTP id d9443c01a7336-2166f1e589cso61998635ad.3 for <75981@debbugs.gnu.org>; Fri, 31 Jan 2025 13:19:46 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1738358380; x=1738963180; darn=debbugs.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=8Qcfzz6WaLO9QLkrmpAvxsmLkRJTSrWMDKbZ/+TnOvc=; b=PaSP6/kCIzounG1PmRU/tWofxWsgeqGUUXE1B2VNXPORa04ArwzZ7FmFlEp/leJ01m MuZ0XdU571pFYBVOv3Yw4iRsxGoxdMI9H5KTsyZ0xWSXn+txJ/VrZWS72i7PbyMW3aXj 4oY+QhscyicR1hBVyHcmWh6gCjk/gndHcH7U9vIm0wgcBHTlQKwiH87+U7PAks/8bsaW e5e5o3NTJPwu0p+qYwgic5iNGHEnzJQfrFCLCYXiDeoCPQojewZnQav+8wPaZTiA7ntH MlrlEzgZeNkjTi6do2361fPkcPnI0Yj20Rcj8HxPrjuHusskpAGZsryCu38y2lUM0e/1 BZSA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1738358380; x=1738963180; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=8Qcfzz6WaLO9QLkrmpAvxsmLkRJTSrWMDKbZ/+TnOvc=; b=r/R+YfC/wC+WL6S+fv/WJWE7bRQ9l4hmkdTOuvr8ZPgm3WbJ823HT7cFZOtyaqxZE9 56nQzBDbVj2zD5cvf7a0u8wOizQJgnhfZIW/dQBmYWjCXBo7yzGixnxJ4RUtLeNEPTt4 qMx1XXN8hZPVgY3NuCw+zqVJAxO+qa0331q5d5TG/ospuA0x43B3nez6q7ixei8V/I1f HvWrZM77AoTaJyUFz8JRc4eZzM0N/ziaONz3RsM6hP6zPIgC8xn/ns2mkFSvN1AorSy0 YDMHRWlLhowSfR03zePJZ7q7CLIVpIXif83A6GuHcT4rw3k6p0CGZ212VFNn5Eii0Wbj T52Q== X-Gm-Message-State: AOJu0Yz19tA4FoCGpMTidTEnIy7k7Bzm3zPGkIsRsBH4PskFw2tqHMsn U5bV4se8TKzjxYp+46kiAbr0djc+PzM7unjHHo6c3y5WMY4dW/9TzuGbDR9y X-Gm-Gg: ASbGncsawGnTOOPyaVMVs+VuIRPK/XU6imH7wd+2dQVbyvDnN4X298nTT8QrXt7yWJ6 SCX7Veg6gFnlOBIruLAjzBiRYRllifax3Pfjrwf2teRrqtaYV+6pFbUyWKiNOoX5ZX8m0c/9p/5 usxxtoyFpZoehg0XicJYId05IYUqHIDMbnkeXOenG4R6UHEz80PRdHeF7HrcRw2vh95GM6pXZCg iOVUetGL03FAo76XnyYZQm6Ehh7QtI7UIRiADxU0s8PDKk39S3dK6RFzFAbsbIzJIV/mqH9cGTc dLgPCAJZxd2DU4Iep3G44p5BZ4fb9yVo5qrwBQ== X-Google-Smtp-Source: AGHT+IFNyH2mrVud6EfDqapYhA/0wbOGhaCg5lWXJSbIQwOZvMADNKjWNsOrxYmBxBybvr6PfESCGg== X-Received: by 2002:a05:6a00:4acc:b0:72a:8cc8:34aa with SMTP id d2e1a72fcca58-72fd097948emr19238636b3a.0.1738358379320; Fri, 31 Jan 2025 13:19:39 -0800 (PST) Received: from localhost.localdomain (utm3.nitt.edu. [14.139.162.2]) by smtp.gmail.com with ESMTPSA id d2e1a72fcca58-72fe64275c4sm3924008b3a.61.2025.01.31.13.19.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 31 Jan 2025 13:19:39 -0800 (PST) From: 45mg <45mg.writes@gmail.com> Date: Sat, 1 Feb 2025 02:48:44 +0530 Message-ID: <2a950d7e5c42768724d1c8fe3bcea3ff54fb81bd.1738357415.git.45mg.writes@gmail.com> X-Mailer: git-send-email 2.48.1 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * guix/scripts/fork.scm, guix/scripts/fork/create.scm: New files. * Makefile.am (MODULES): Add the new files. * guix/build/utils.scm (invoke/stdout): New procedure. * guix/utils.scm (chain-cut): New procedure. * guix/scripts/git/authenticate.scm (commit-short-id): Remove procedure, and use its existing duplicate in guix/channels.scm. (openpgp-fingerprint*, current-branch, show-stats): Move procedures to the files below. * guix/channels.scm (openpgp-fingerprint*): Moved here. * guix/git.scm (repository-current-branch): Moved here and renamed from 'current-branch'. * guix/git-authenticate.scm (show-authentication-stats): Moved here and renamed from 'show-stats'. Change-Id: I45ba37f434e136f6d496c741d9a933280f9ccf88 --- Makefile.am | 2 + guix/build/utils.scm | 20 +++ guix/channels.scm | 13 ++ guix/git-authenticate.scm | 17 ++ guix/git.scm | 10 ++ guix/scripts/fork.scm | 67 ++++++++ guix/scripts/fork/create.scm | 257 ++++++++++++++++++++++++++++++ guix/scripts/git/authenticate.scm | 45 +----- guix/utils.scm | 33 ++++ 9 files changed, 423 insertions(+), 41 deletions(-) create mode 100644 guix/scripts/fork.scm create mode 100644 guix/scripts/fork/create.scm diff --git a/Makefile.am b/Makefile.am index f759803b8b..c628450a5a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -377,6 +377,8 @@ MODULES = \ guix/scripts/size.scm \ guix/scripts/git.scm \ guix/scripts/git/authenticate.scm \ + guix/scripts/fork.scm \ + guix/scripts/fork/create.scm \ guix/scripts/graph.scm \ guix/scripts/weather.scm \ guix/scripts/container.scm \ diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 94714bf397..e8bd39f5de 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -10,6 +10,8 @@ ;;; Copyright © 2021, 2022 Maxime Devos ;;; Copyright © 2021 Brendan Tildesley ;;; Copyright © 2023 Carlo Zancanaro +;;; Copyright © 2025 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2025 45mg <45mg.writes@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +41,7 @@ (define-module (guix build utils) #:use-module (ice-9 rdelim) #:use-module (ice-9 format) #:use-module (ice-9 threads) + #:use-module (ice-9 popen) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:re-export (alist-cons @@ -128,6 +131,7 @@ (define-module (guix build utils) report-invoke-error invoke/quiet + invoke/stdout make-desktop-entry-file @@ -889,6 +893,22 @@ (define (invoke/quiet program . args) (line (loop (cons line lines))))))) +(define (invoke/stdout program . args) + "Invoke PROGRAM with ARGS and capture PROGRAM's standard output. If PROGRAM +succeeds, return its standard output as a string. Otherwise, raise an +'&invoke-error' condition." + (let* ((port (apply open-pipe* OPEN_READ program args)) + (data (get-string-all port)) + (code (close-pipe port))) + (unless (zero? code) + (raise (condition (&invoke-error + (program program) + (arguments args) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code)))))) + data)) + ;;; ;;; Text substitution (aka. sed). diff --git a/guix/channels.scm b/guix/channels.scm index 4700f7a45d..6ca8e64881 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -47,6 +47,7 @@ (define-module (guix channels) #:use-module (guix packages) #:use-module (guix progress) #:use-module (guix derivations) + #:autoload (rnrs bytevectors) (bytevector-length) #:use-module (guix diagnostics) #:use-module (guix sets) #:use-module (guix store) @@ -81,6 +82,7 @@ (define-module (guix channels) openpgp-fingerprint->bytevector openpgp-fingerprint + openpgp-fingerprint* %default-guix-channel %default-channels @@ -171,6 +173,17 @@ (define-syntax openpgp-fingerprint ((_ str) #'(openpgp-fingerprint->bytevector str))))) +(define (openpgp-fingerprint* str) + "Like openpgp-fingerprint, but with error handling from (guix diagnostics)." + (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 %guix-channel-introduction ;; Introduction of the official 'guix channel. The chosen commit is the ;; first one that introduces '.guix-authorizations' on the 'staging' diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 37c69d0880..8bc7fb6fb3 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -40,6 +40,7 @@ (define-module (guix git-authenticate) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:autoload (ice-9 pretty-print) (pretty-print) #:export (read-authorizations commit-signing-key @@ -52,6 +53,7 @@ (define-module (guix git-authenticate) repository-cache-key authenticate-repository + show-authentication-stats git-authentication-error? git-authentication-error-commit @@ -449,3 +451,18 @@ (define* (authenticate-repository repository start signer (oid->string (commit-id end-commit))) stats)))) + +(define (show-authentication-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)))))) diff --git a/guix/git.scm b/guix/git.scm index 6ac6e4e3a2..afeacb53aa 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -59,6 +59,7 @@ (define-module (guix git) with-git-error-handling false-if-git-not-found repository-info + repository-current-branch update-cached-checkout url+commit->name latest-repository-commit @@ -401,6 +402,15 @@ (define (repository-info directory) (lambda _ (values #f #f #f)))) +(define (repository-current-branch repository) + "Return the name of the checked out branch of REPOSITORY or #f if it could +not be determined." + (and (not (repository-head-detached? repository)) + (let* ((head (repository-head repository)) + (name (reference-name head))) + (and (string-prefix? "refs/heads/" name) + (string-drop name (string-length "refs/heads/")))))) + (define* (update-submodules repository #:key (log-port (current-error-port)) (fetch-options #f)) diff --git a/guix/scripts/fork.scm b/guix/scripts/fork.scm new file mode 100644 index 0000000000..2d97bcb93f --- /dev/null +++ b/guix/scripts/fork.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 45mg <45mg.writes@gmail.com> +;;; +;;; 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 fork) + #:use-module (ice-9 match) + #:use-module (guix ui) + #:use-module (guix scripts) + #:export (guix-fork)) + +(define (show-help) + (display (G_ "Usage: guix fork ACTION ARGS... +Create and manage authenticated forks of Guix.\n")) + (newline) + (display (G_ "The valid values for ACTION are:\n")) + (newline) + (display (G_ "\ + create set up a fork of Guix\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %sub-commands '("create")) + +(define (resolve-sub-command name) + (let ((module (resolve-interface + `(guix scripts fork ,(string->symbol name)))) + (proc (string->symbol (string-append "guix-fork-" name)))) + (module-ref module proc))) + +(define-command (guix-fork . args) + (category plumbing) + (synopsis "operate on Guix forks") + + (with-error-handling + (match args + (() + (format (current-error-port) + (G_ "guix fork: missing sub-command~%"))) + ((or ("-h") ("--help")) + (leave-on-EPIPE (show-help)) + (exit 0)) + ((or ("-V") ("--version")) + (show-version-and-exit "guix fork")) + ((sub-command args ...) + (if (member sub-command %sub-commands) + (apply (resolve-sub-command sub-command) args) + (format (current-error-port) + (G_ "guix fork: invalid sub-command~%"))))))) diff --git a/guix/scripts/fork/create.scm b/guix/scripts/fork/create.scm new file mode 100644 index 0000000000..8b5555947b --- /dev/null +++ b/guix/scripts/fork/create.scm @@ -0,0 +1,257 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2025 45mg <45mg.writes@gmail.com> +;;; +;;; 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 fork create) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module ((guix utils) #:select (chain-cut)) + #:use-module (guix build utils) + #:use-module (guix channels) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:export (guix-fork-create)) + +;;; Commentary: +;;; +;;; Create a fork of Guix, by running a series of git commands. +;;; +;;; 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 fork create"))) + (option '("upstream") #t #f + (lambda (opt name arg result) + (alist-cons 'upstream arg result))) + (option '("channel-url") #t #f + (lambda (opt name arg result) + (alist-cons 'channel-url arg result))) + (option '("use-existing") #f #f + (lambda (opt name arg result) + (alist-cons 'use-existing? #t result))) + (option '("git-parameter") #t #f + (lambda (opt name arg result) + (let ((git-parameters (assoc-ref result 'git-parameters))) + (if git-parameters + (alist-cons 'git-parameters (cons arg git-parameters) result) + (alist-cons 'git-parameters (list arg) result))))))) + +(define %default-options + `((upstream . ,(channel-url %default-guix-channel)))) + +(define %usage + (format #f (G_ "Usage: guix fork create SIGNING_KEY [DIRECTORY OPTIONS...] +Create a fork of Guix in DIRECTORY, using SIGNING_KEY to sign the introductory +commit. +DIRECTORY defaults to ./guix. + + --upstream=URI the repository to clone from + (defaults to ~a) + --channel-url=URI optional URI, used to replace the channel URL + and the existing 'origin' remote (which is + renamed to 'upstream') + --use-existing Use existing clone of Guix in DIRECTORY + --git-parameter PARAMETER + Specify configuration PARAMETER for git, via + '-c' option (can pass multiple times) + + -h, --help display this help and exit + -V, --version display version information and exit +") + (channel-url %default-guix-channel))) + +(define (show-help) + (display %usage) + (newline) + (show-bug-report-information)) + +(define (missing-arguments) + (leave (G_ "wrong number of arguments; \ +required SIGNING_KEY~%"))) + + +;;; +;;; Helper prodecures. +;;; + +(define (fingerprint->key-file-name fingerprint) + (let* ((listing (invoke/stdout "gpg" "--list-key" "--with-colons" fingerprint)) + (uid (chain-cut listing + (string-split <> #\newline) + (filter (cut string-prefix? "uid:" <>) <>) + first + (string-split <> #\:) + tenth)) + (email-name (string-delete + (cut eq? <> #\.) + (substring uid + (1+ (or (string-index-right uid #\<) + -1)) ;no name in uid + (string-index uid #\@)))) + (key-id (chain-cut listing + (string-split <> #\newline) + (filter (cut string-prefix? "pub:" <>) <>) + car + (string-split <> #\:) + fifth + (string-take-right <> 8)))) + (string-append email-name "-" key-id ".key"))) + +(define (update-channel-url file channel-url) + "Modify .guix_channel FILE. +Change the channel url to CHANNEL-URL." + (let ((channel-data (call-with-input-file file read))) + (assq-set! (cdr channel-data) 'url (list channel-url)) + (call-with-output-file file + (lambda (file) + (display ";; This is a Guix channel.\n\n" file) + (pretty-print channel-data file))))) + +(define (rewrite-authorizations file name fingerprint) + "Rewrite .guix-authorizations FILE to contain a single authorization +consisting of NAME and FINGERPRINT." + (let ((auth-data (call-with-input-file file read))) + (list-set! auth-data (1- (length auth-data)) + `((,fingerprint (name ,name)))) + (call-with-output-file file + (lambda (file) + (display ";; This file, which is best viewed as -*- Scheme -*-, lists the OpenPGP keys +;; currently authorized to sign commits in this fork branch. + +" file) + (pretty-print auth-data file))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-fork-create . 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))) + + (with-error-handling + (let* ((signing-key directory (match (command-line-arguments options) + ((signing-key directory) + (values signing-key directory)) + ((signing-key) + (values signing-key "guix")) + (_ (missing-arguments)))) + (upstream (assoc-ref options 'upstream)) + (channel-url (assoc-ref options 'channel-url)) + (use-existing? (assoc-ref options 'use-existing?)) + (git-parameters (assoc-ref options 'git-parameters)) + (git-c-options ;'("-c" "param1" "-c" "param2" ...) + (let loop ((opts '()) (params git-parameters)) + (if (or (not params) (null-list? params)) + opts + (loop (append + opts (list "-c" (first params))) + (drop params 1))))) + + (key-file-name (fingerprint->key-file-name signing-key)) + (introduction-name (car (string-split key-file-name #\-))) + + (upstream-branch-name "master")) + + (define (invoke-git . args) + (apply invoke `("git" ,@git-c-options "-C" ,directory ,@args))) + + (unless use-existing? + (info (G_ "Cloning from upstream ~a...~%") upstream) + (invoke "git" "clone" upstream directory)) + + (info (G_ "Authenticating upstream commits...~%")) + + (when channel-url + (info (G_ "Renaming existing 'origin' remote to 'upstream'...~%")) + (invoke-git "remote" "rename" "origin" "upstream") + (info (G_ "Using provided channel URL for new 'origin' remote...~%")) + (invoke-git "remote" "add" "origin" channel-url)) + + (set! upstream-branch-name + (chain-cut + (invoke/stdout "git" + "-C" directory + "symbolic-ref" + (string-append "refs/remotes/" + (if channel-url "upstream" "origin") + "/HEAD")) + string-trim-right + (string-split <> #\/) + last)) + + (info (G_ "Adding key to keyring branch...~%")) + (invoke-git "switch" "keyring") + (invoke "gpg" + "--armor" "--export" + "-o" (string-append directory "/" key-file-name) + signing-key) + (invoke-git "add" "--" key-file-name) + (invoke-git "commit" "-m" "Add key for fork introduction.") + + (info (G_ "Setting up fork branch...~%")) + (invoke-git "switch" "--create" "fork" "master") + (when channel-url + (update-channel-url (string-append directory "/.guix-channel") + channel-url)) + (rewrite-authorizations (string-append directory "/.guix-authorizations") + introduction-name signing-key) + (invoke-git "add" "--" + (string-append directory "/.guix-authorizations") + (string-append directory "/.guix-channel")) + (invoke-git "commit" + (string-append "--gpg-sign=" signing-key) + "-m" + (string-append + "Initial fork commit.\n\n" + ".guix-authorizations: Allow only " introduction-name "'s key." + (if channel-url + "\n.guix-channels: Update channel URL." + ""))) + + (info (G_ "Successfully created Guix fork in ~a. +You should run the following command next: +guix fork authenticate ~a ~a ~a~%") + directory + upstream-branch-name + (string-trim-right (invoke/stdout "git" "-C" directory "rev-parse" "HEAD")) + signing-key)))) diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm index e3ecb67c89..154aae9b14 100644 --- a/guix/scripts/git/authenticate.scm +++ b/guix/scripts/git/authenticate.scm @@ -23,8 +23,8 @@ (define-module (guix scripts git authenticate) #: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 channels) #:select (openpgp-fingerprint*)) + #:use-module ((guix git) #:select (with-git-error-handling commit-short-id repository-current-branch)) #:use-module (guix progress) #:use-module (guix base64) #:autoload (rnrs bytevectors) (bytevector-length) @@ -76,15 +76,6 @@ (define %options (define %default-options '()) -(define (current-branch repository) - "Return the name of the checked out branch of REPOSITORY or #f if it could -not be determined." - (and (not (repository-head-detached? repository)) - (let* ((head (repository-head repository)) - (name (reference-name head))) - (and (string-prefix? "refs/heads/" name) - (string-drop name (string-length "refs/heads/")))))) - (define (config-value repository key) "Return the config value associated with KEY in the 'guix.authentication' or 'guix.authentication-BRANCH' name space in REPOSITORY, or #f if no such config @@ -94,7 +85,7 @@ (define (config-value repository key) ((_ exp) (catch 'git-error (lambda () exp) (const #f)))))) (let* ((config (repository-config repository)) - (branch (current-branch repository))) + (branch (repository-current-branch repository))) ;; First try the BRANCH-specific value, then the generic one.` (or (and branch (false-if-git-error @@ -194,21 +185,6 @@ (define (install-hooks repository) (warning (G_ "cannot determine where to install hooks\ (Guile-Git too old?)~%")))) -(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")) @@ -251,19 +227,6 @@ (define (guix-git-authenticate . args) (_ #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 \ @@ -321,7 +284,7 @@ (define (guix-git-authenticate . args) (install-hooks repository)) (when (and show-stats? (not (null? stats))) - (show-stats stats)) + (show-authentication-stats stats)) (info (G_ "successfully authenticated commit ~a~%") (oid->string end)))))) diff --git a/guix/utils.scm b/guix/utils.scm index b6cf5aea4f..e07e89c321 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -21,6 +21,8 @@ ;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2023 Foundation Devices, Inc. ;;; Copyright © 2024 Herman Rimm +;;; Copyright © 2025 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2025 45mg <45mg.writes@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,6 +165,8 @@ (define-module (guix utils) call-with-compressed-output-port canonical-newline-port + chain-cut + string-distance string-closest @@ -1193,6 +1197,35 @@ (define-syntax current-source-directory ;; raising an error would upset Geiser users #f)))))) + +;;; +;;; Higher-order functions. +;;; + +(define-syntax chain-cut + (lambda (x) + "Apply each successive form to the result of evaluating the previous one. +Before applying, expand each form (op ...) to (cut op ...). + +Examples: + + (chain-cut '(1 2 3) cdr car) + => (car (cdr '(1 2 3))) + + (chain-cut 2 (- 3 <>) 1+) + => (1+ ((cut - 3 <>) 2)) + => (1+ (- 3 2)) +" + (syntax-case x () + ((chain-cut init op) (identifier? #'op) + #'(op init)) + ((chain-cut init (op ...)) + #'((cut op ...) init)) + ((chain-cut init op op* ...) (identifier? #'op) + #'(chain-cut (op init) op* ...)) + ((chain-cut init (op ...) op* ...) + #'(chain-cut ((cut op ...) init) op* ...))))) + ;;; ;;; String comparison.