Subject: [bug#75981] [PATCH v2 1/2] etc: Add fork.scm.

From: 45mg <[email-masked]>
Date: Sun, 23 Feb 2025 18:50:48 +0530

* guix/utils.scm (chain-cut, invoke/stdout): New procedures.
* etc/fork.scm: New script.
* tests/etc-fork.sh: Test it.
* Makefile.am: Add etc-fork.sh.
* doc/contributing.texi (Using Your Own Patches): New node.

Change-Id: Ifcba59ac6b6a330056bcfd51f7b1b7f790f95cc8
---
 Makefile.am           |   3 +-
 doc/contributing.texi |  63 ++++++++++
 etc/fork.scm          | 286 ++++++++++++++++++++++++++++++++++++++++++
 guix/utils.scm        |  61 +++++++++
 tests/fork.sh         | 135 ++++++++++++++++++++
 5 files changed, 547 insertions(+), 1 deletion(-)
 create mode 100755 etc/fork.scm
 create mode 100644 tests/fork.sh

diff --git a/Makefile.am b/Makefile.am
index 8e142a4002..dc4da74334 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -664,7 +664,8 @@ SH_TESTS =					\
   tests/guix-graph.sh				\
   tests/guix-describe.sh			\
   tests/guix-repl.sh     			\
-  tests/guix-lint.sh
+  tests/guix-lint.sh     			\
+  tests/etc-fork.sh
 
 TESTS = $(SCM_TESTS) $(SH_TESTS)
 
diff --git a/doc/contributing.texi b/doc/contributing.texi
index ab4f30d54b..121f7eea9d 100644
--- a/doc/contributing.texi
+++ b/doc/contributing.texi
@@ -35,6 +35,7 @@ Contributing
 * Making Decisions::            Collectively choosing the way forward.
 * Commit Access::               Pushing to the official repository.
 * Reviewing the Work of Others::  Some guidelines for sharing reviews.
+* Using Your Own Patches::      Using your own work before it's accepted.
 * Updating the Guix Package::   Updating the Guix package definition.
 * Deprecation Policy::          Commitments and tools for deprecation.
 * Writing Documentation::       Improving documentation in GNU Guix.
@@ -3095,6 +3096,68 @@ Reviewing the Work of Others
 have reviewed more easily by adding a @code{reviewed-looks-good} usertag
 for the @code{guix} user (@pxref{Debbugs Usertags}).
 
+@node Using Your Own Patches
+@section Using Your Own Patches
+
+If you've taken the time to contribute code to Guix, chances are that
+you want the changes you've made to be reflected in your own Guix
+installation as soon as possible.  Maybe you've added a package you want,
+and you want to start using it @emph{right now}.  Or you've fixed a bug
+that affects you, and you want it to @emph{go away}.
+
+As described in the preceding sections, all contributions to Guix first
+go through a review process to ensure code quality.  Sometimes, this can
+take longer than one would like.  Ideally, the pace of the review process
+should not prevent you from benefiting from your own work.
+
+One way to work around this issue is to create an additional channel of
+your own (@pxref{Creating a Channel}), and add your code to it.  For
+certain kinds of contributions, such as adding a new package, this is
+fairly straightforward --- simply copy your new package definition(s)
+into a new file in the channel, and remove them when your contribution
+is accepted.
+
+However, there may be cases where this is not convenient.  Certain kinds
+of changes, such as those that need to modify existing Guix internals,
+may be more challenging to incorporate into a channel.  Moreover, the
+more substantial your contribution is, the more work it will be to do
+so.
+
+@cindex fork, of Guix
+For such cases, there is another option.  Recall that the patch series
+that you sent (@pxref{Sending a Patch Series}) was created from one or
+more commits on a checkout of the Guix repository (@pxref{Building from
+Git}).  You could simply specify this repository (referred to as your
+``Guix fork'', or simply ``fork'', from here onwards), and its relevant
+branch, as your `@code{guix}' channel (@pxref{Using a Custom Guix
+Channel}).  Now `@samp{guix pull}' will fetch your new commits, and
+you'll see the changes you made reflected in your Guix installation!
+
+However, there's a potential complication to this approach - the issue
+of authentication (@pxref{Channel Authentication}).  If your fork only
+exists on your local filesystem (a `local fork'), then you probably
+don't need to worry about this, and can pull without authentication
+(@pxref{Invoking guix pull}).  But other situations, such as a remotely
+hosted fork, may make it important for your fork to be authenticated, in
+the same way that all channels are expected to be.
+
+The steps needed to enable the authentication of a fork branch are:
+
+@itemize
+@item
+Add your public key to the `keyring' branch of the repository. (This is
+the key that all future commits will be signed with).
+
+@item
+Add a commit to the fork branch that modifies the
+@file{.guix_authorizations} file to add your public key. This commit
+will serve as the @dfn{fork introduction}.
+@end itemize
+
+Guix provides a @file{etc/fork.scm} script that can automatically create
+a fork for you, performing these steps as well as taking care of other
+details. Run @samp{etc/fork.scm --help} for details.
+
 @node Updating the Guix Package
 @section Updating the Guix Package
 
diff --git a/etc/fork.scm b/etc/fork.scm
new file mode 100755
index 0000000000..a31300072b
--- /dev/null
+++ b/etc/fork.scm
@@ -0,0 +1,286 @@
+#!/bin/sh
+# -*- mode: scheme; -*-
+# Ensure that this script can run without guix being installed.
+pre_inst_env_maybe=
+command -v guix > /dev/null || pre_inst_env_maybe=./pre-inst-env
+exec $pre_inst_env_maybe guix repl -- "$0" "$@"
+!#
+
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Tomas Volf <[email-masked]>
+;;; Copyright © 2025 45mg <[email-masked]>
+;;;
+;;; 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/>.
+
+;;; Commentary:
+;;;
+;;; Create a fork of Guix, by running a series of git commands.
+;;;
+;;; Code:
+
+(use-modules (guix build utils)
+             (guix channels)
+             (guix scripts)
+             (guix ui)
+             ((guix utils) #:select (chain-cut
+                                     invoke/stdout))  ;TODO move to (guix build utils)
+             (ice-9 exceptions)
+             (ice-9 match)
+             (ice-9 popen)
+             (ice-9 pretty-print)
+             (ice-9 string-fun)
+             (ice-9 textual-ports)
+             (srfi srfi-1)
+             (srfi srfi-13)
+             (srfi srfi-26)
+             (srfi srfi-37)
+             (srfi srfi-71))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '("upstream") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'upstream arg result)))
+        (option '("from") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'start 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)))))
+        (option '("dry-run") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'dry-run? #t result)))))
+
+(define %default-options
+  `((upstream . ,(channel-url %default-guix-channel))
+    (start    . ,(channel-branch %default-guix-channel))))
+
+(define %usage
+  (format #f (G_ "Usage: etc/fork.scm SIGNING_KEY [DIRECTORY OPTIONS...]
+Create a fork of Guix in DIRECTORY, using SIGNING_KEY to sign the introductory
+commit.
+DIRECTORY defaults to ../guix-fork.
+
+      --upstream=URI     the repository to clone from
+                         (defaults to ~a)
+      --from=START       create the fork branch starting from START,
+                         a branch or commit
+                         (defaults to starting from the '~a' branch)
+      --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)
+      --dry-run          Display what would be done, without doing it
+
+  -h, --help             display this help and exit
+")
+          (assoc-ref %default-options 'upstream)
+          (assoc-ref %default-options 'start)))
+
+(define (show-help)
+  (display %usage)
+  (newline)
+  (show-bug-report-information))
+
+(define (missing-arguments)
+  (info (G_ "hint: try etc/fork.scm --help~%"))
+  (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 dry-run?)
+  "Modify .guix_channel FILE.
+Change the channel url to CHANNEL-URL.
+If DRY-RUN? is true, only display what would be done."
+  (let ((channel-data (call-with-input-file file read)))
+    (assq-set! (cdr channel-data) 'url (list channel-url))
+
+    (define (writer port)
+      (display ";; This is a Guix channel.\n\n" port)
+      (pretty-print channel-data port))
+
+    (if dry-run?
+        (begin
+          (display "Modified .guix_channel:\n")
+          (writer (current-output-port)))
+        (call-with-output-file file writer))))
+
+(define (rewrite-authorizations file name fingerprint dry-run?)
+  "Rewrite .guix-authorizations FILE to contain a single authorization
+consisting of NAME and FINGERPRINT.
+If DRY-RUN? is true, only display what would be done."
+  (let ((auth-data (call-with-input-file file read)))
+    (list-set! auth-data (1- (length auth-data))
+               `((,fingerprint (name ,name))))
+
+    (define (writer port)
+      (display "\
+;; This file, which is best viewed as -*- Scheme -*-, lists the OpenPGP keys
+;; currently authorized to sign commits in this fork branch.
+
+" port)
+      (pretty-print auth-data port))
+
+    (if dry-run?
+        (begin
+          (display "Rewritten .guix_authorizations:\n")
+          (writer (current-output-port)))
+        (call-with-output-file file writer))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (main . 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-fork"))
+                                    (_ (missing-arguments))))
+           (upstream (assoc-ref options 'upstream))
+           (start (assoc-ref options 'start))
+           (channel-url (assoc-ref options 'channel-url))
+           (use-existing? (assoc-ref options 'use-existing?))
+           (dry-run? (assoc-ref options 'dry-run?))
+           (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 #\-))))
+
+      (define (invoke* . args)
+        (if dry-run?
+            (display (string-append
+                      (string-join (map (cut format #f "~s" <>)
+                                        args))
+                      "\n"))
+            (apply invoke args)))
+
+      (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))
+
+      (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))
+
+      (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"
+                  ;; This commit does not need to be signed, but we might as
+                  ;; well use the signing key we were given.
+                  (string-append "--gpg-sign=" signing-key)
+                  "-m" "Add key for fork introduction.")
+
+      (info (G_ "Setting up fork branch...~%"))
+      (invoke-git "switch" "--create" "fork" start)
+      (when channel-url
+        (update-channel-url (string-append directory "/.guix-channel")
+                            channel-url
+                            dry-run?))
+      (rewrite-authorizations (string-append directory "/.guix-authorizations")
+                              introduction-name signing-key
+                              dry-run?)
+      (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.~%")
+            directory))))
+
+(apply main (cdr (command-line)))
diff --git a/guix/utils.scm b/guix/utils.scm
index c7c23d9d5b..191d17c570 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -21,6 +21,8 @@
 ;;; Copyright © 2023 Zheng Junjie <[email-masked]>
 ;;; Copyright © 2023 Foundation Devices, Inc. <[email-masked]>
 ;;; Copyright © 2024 Herman Rimm <[email-masked]>
+;;; Copyright © 2025 Tomas Volf <[email-masked]>
+;;; Copyright © 2025 45mg <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -44,6 +46,8 @@ (define-module (guix utils)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-71)
+  #:use-module (srfi srfi-35)  ;TODO remove after moving invoke/stdout
+  #:use-module (ice-9 popen)  ;TODO remove after moving invoke/stdout
   #:use-module (rnrs io ports)                    ;need 'port-position' etc.
   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
   #:use-module (guix memoization)
@@ -163,6 +167,9 @@ (define-module (guix utils)
             call-with-compressed-output-port
             canonical-newline-port
 
+            chain-cut
+            invoke/stdout  ;TODO move to (guix build utils)
+
             string-distance
             string-closest
 
@@ -1193,6 +1200,60 @@ (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* ...)))))
+
+;; Copied from (guix build utils); remove
+(define-condition-type &invoke-error &error
+  invoke-error?
+  (program      invoke-error-program)
+  (arguments    invoke-error-arguments)
+  (exit-status  invoke-error-exit-status)
+  (term-signal  invoke-error-term-signal)
+  (stop-signal  invoke-error-stop-signal))
+;; TODO move to (guix build utils)
+(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))
+
 
 ;;;
 ;;; String comparison.
diff --git a/tests/fork.sh b/tests/fork.sh
new file mode 100644
index 0000000000..f6c72dba73
--- /dev/null
+++ b/tests/fork.sh
@@ -0,0 +1,135 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2020, 2022, 2024 Ludovic Courtès <[email-masked]>
+#
+# 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/>.
+
+#
+# Test forking Guix using the etc/fork.scm script, and fork authentication via
+# `guix git authenticate --branch`.
+#
+
+set -e
+
+gpg_fingerprint() {
+    flag=--list-keys
+    [ "$2" == --file ] && flag=--show-keys
+    gpg --quiet --with-colons "$flag" --with-fingerprint "$1" | awk -F: '$1 == "fpr" {print $10;}'
+}
+
+test_directory="$(mktemp -d)"
+trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
+
+### Sanity checks
+
+# Skip if git is not available.
+command -v git > /dev/null || exit 77
+
+# Skip if gpg is not available.
+command -v gpg > /dev/null || exit 77
+
+# Skip if we're not in a Git checkout.
+[ -d "$abs_top_srcdir/.git" ] || exit 77
+
+# Skip if there's no 'keyring' branch.
+guile -c '(use-modules (git))
+  (member "refs/heads/keyring" (branch-list (repository-open ".")))' || \
+    exit 77
+
+### Create a dummy test key to sign commits with
+
+# Create a temporary substitute for ~/.gnupg
+export GNUPGHOME="$test_directory"/.gnupg
+mkdir -p $GNUPGHOME
+# gpg expects correct perms
+chmod 700 $GNUPGHOME
+chown $(whoami) $GNUPGHOME
+
+# Generate a test key
+gpg --quiet --batch --gen-key <<EOF
+%echo Generating test OpenPGP key...
+Key-Type: DSA
+Name-Real: [email-masked]
+%no-protection
+%commit
+%echo done.
+EOF
+
+# Get the test key fingerprint
+TEST_KEY=$(gpg_fingerprint testuser)
+
+### Clone this repository to the test directory
+git clone --branch master "$abs_top_srcdir" "$test_directory"/guix
+
+### Create the repository.
+# Create the fork branch from a commit that's not too far from Guix's
+# introduction, so that the authentication doesn't take too long.
+FORK_BASE_COMMIT=90c4298eede94cd353fc3dd0e3099af7b5ba7283
+"$abs_top_srcdir"/etc/fork.scm "$TEST_KEY" "$test_directory"/guix --use-existing \
+    --from="$FORK_BASE_COMMIT" \
+    --channel-url=/foo/bar \
+    --git-parameter=user.name=test-user --git-parameter=user.email=[email-masked]
+
+### Tests
+
+cd "$test_directory"/guix || exit 77
+
+#### remotes
+
+# Test that the 'upstream' remote is the one corresponding to where the
+# repository was cloned from.
+test "$(git remote get-url upstream)" == "$abs_top_srcdir"
+
+# Test that the 'origin' remote has the given --channel-url.
+test "$(git remote get-url origin)" == /foo/bar
+
+#### keyring branch
+
+git switch --quiet keyring
+
+# Test that only one new file has been added, and there have been no other
+# changes.
+KEY_FILE_NAME="$(git diff --diff-filter=A --name-only upstream/keyring keyring)"
+test "$KEY_FILE_NAME" = "$(git diff --name-only upstream/keyring keyring)"
+
+# Test that the added file is correctly named.
+CORRECT_KEY_FILE_NAME=testuser-"${TEST_KEY:(-8)}".key
+test "$KEY_FILE_NAME" = "$CORRECT_KEY_FILE_NAME"
+
+# Test that the added file contains the correct key.
+test "$(gpg_fingerprint "$KEY_FILE_NAME" --file)" = "$TEST_KEY"
+
+#### fork authentication
+
+# Test that the 'fork' branch exists.
+git show-ref --verify --quiet refs/heads/fork
+
+git switch --quiet fork
+
+# Test that only .guix_authorizations and .guix_channel have been modified.
+test "$(git diff --name-only "$FORK_BASE_COMMIT" fork)" = "\
+.guix-authorizations
+.guix-channel"
+
+# test that the fork's base commit can be authenticated
+# (authenticating upstream)
+guix git authenticate \
+    9edb3f66fd807b096b48283debdcddccfea34bad \
+    "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA" \
+    --end="$FORK_BASE_COMMIT"
+
+# Test that the fork branch fails to authenticate with the upstream
+# introduction, as it is not signed by an authorized key.
+! guix git authenticate
-- 
2.48.1