Subject: [bug#75981] [PATCH (WIP) v1.5 1/4] Add 'guix fork create'.

From: 45mg <[email-masked]>
Date: Sat, 1 Feb 2025 17:13:23 +0530

* 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/channels.scm                 |  13 ++
 guix/git-authenticate.scm         |  17 ++
 guix/git.scm                      |  10 ++
 guix/scripts/fork.scm             |  67 ++++++++
 guix/scripts/fork/create.scm      | 258 ++++++++++++++++++++++++++++++
 guix/scripts/git/authenticate.scm |  45 +-----
 guix/utils.scm                    |  61 +++++++
 8 files changed, 432 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/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 <[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/>.
+
+(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..a9de204f23
--- /dev/null
+++ b/guix/scripts/fork/create.scm
@@ -0,0 +1,258 @@
+;;; 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/>.
+
+(define-module (guix scripts fork create)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module ((guix utils) #:select (chain-cut
+                                       invoke/stdout))  ;TODO move to (guix build utils)
+  #: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..0d023e7729 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.
-- 
2.48.1