@@ -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 \
@@ -10,6 +10,8 @@
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
;;; Copyright © 2023 Carlo Zancanaro <carlo@zancanaro.id.au>
+;;; 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).
@@ -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'
@@ -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))))))
@@ -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))
new file mode 100644
@@ -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 <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~%")))))))
new file mode 100644
@@ -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 <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))
+ #: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))))
@@ -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))))))
@@ -21,6 +21,8 @@
;;; Copyright © 2023 Zheng Junjie <873216071@qq.com>
;;; Copyright © 2023 Foundation Devices, Inc. <hello@foundationdevices.com>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
+;;; 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.