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

Message ID 590b269995eb83d8fe2b584a40a58fa9ed473c54.1738408683.git.45mg.writes@gmail.com
State New
Headers
Series Add 'guix fork'. |

Commit Message

45mg Feb. 1, 2025, 11:43 a.m. UTC
  * 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
  

Comments

Maxim Cournoyer Feb. 2, 2025, 3:01 p.m. UTC | #1
Hi,

My first thought was similar to Liliana's reply in the other
issue thread: putting lots of energy into making it convenient to fork
Guix instead of contributing to the review process (described as slow
and erratic, which appears to be the motivation here), appears
counter-productive.

So I'm not even sure this should be incorporated in Guix, especially if
it does touch the sensitive guix authentication mechanism.

I'll still offer a review, given the code looks rather good, and perhaps
being a committer I'm missing part of the picture on why such a
mechanism improves on the status quo of using extensions or channels, or
local unauthenticated forks (for personal use, that was enough for me
when one of my changes didn't make it for a year).  It was rather
inconvenient, but that was a good motivator to keep nudging it into Guix
proper.

And I disagree with your assessment that it takes years to become a Guix
committer.  I think 6 months to a year would be a reasonable time frame
for a dedicated individual.  It's also not the only way to be useful to
the project.  Reviewing the work of others help a lot too (those appear
at https://qa.guix.gnu.org/patches).

Below are some comments on the code.

45mg <45mg.writes@gmail.com> writes:

> * 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.

Touching (guix build utils) is a world rebuild (the module is included
in every build system, including the gnu-build-system).  Perhaps start
its life in (guix utils) with a TODO to move it to (guix build utils)
later along another world-rebuilding change.

Later: I see you changed that in this v1.5 revision: in this case just
update the change log message.

> * guix/utils.scm (chain-cut): New procedure.

Could use 's/New procedure./Likewise./' to avoid repetition.

> * 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.

You can use the ellipsis trick: (openpgp-fingerprint*): "Move to..."
* guix/channels.scm (openpgp-fingerprint*): ... here.

and likewise for the other procedures.

There's a missing entry for adjusting the renamed current-branch
procedure inside the config-value proc.

[...]

> 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))
> +

I'm not convinced having a program-exiting procedure in the public API
makes sense (and these are annoying at the REPL!)  Returning a proper
exception would be better.

[...]

> --- /dev/null
> +++ b/guix/scripts/fork.scm

[...]

> +(define-module (guix scripts fork)
> +  #:use-module (ice-9 match)
> +  #:use-module (guix ui)
> +  #:use-module (guix scripts)

Please list modules in lexicographic order.

[...]

> 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

[...]

> +
> +;;;
> +;;; 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

If there are no key for FINGERPRINT, `first' will fail with a cryptic
error here.  It should ideally throw a useful exception.

[...]

> +
> +;;;
> +;;; Entry point.
> +;;;
> +
> +(define (guix-fork-create . args)
> +  (define options
> +    (parse-command-line args %options (list %default-options)
> +                        #:build-options? #f))

I think you could provide a proc to set the default value of the
DIRECTORY positional argument via #:argument-handler...

> +
> +  (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))))

Avoiding the command-line-arguments proc as well as the match above.

> +           (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)))

You have enough horizontal space to (append opts ...) on a single line I
think.

> +                        (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)))

We prefer to use guile-git throughout Guix, as it has a proper Scheme
interface.  Have you tried using it instead of shelling out to git?
Perhaps it was missing some features you needed?

> +      (unless use-existing?
> +        (info (G_ "Cloning from upstream ~a...~%") upstream)
> +        (invoke "git" "clone" upstream directory))

Why not using the above defined invoke-git here?

> +
> +      (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"

Break the line to place "git" below invoke/stdout, to avoid busting our
80 columns max convention a bit below.

> +                            "-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.

Phew!

> +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))

Please watch the 80 columns limit :-).

>    #: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))
> -

If that's only ever used here, I'd leave it here, as as I said earlier,
it's not a great API (and having confusing asterisk suffixes variants in
the public API should be limited to cases that truly matter, in my
opinion).

[...]

>  
> @@ -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* ...)))))

I'm not 100% convince on the above, as it seems it leads to bunching a
whole lot of procedures together and not paying attention to potential
exceptions/errors returned.  But maybe that's OK if the whole form is
wrapped in an error handler.

That's it!  This adding a whole new command line, and to get everyone
aware, I think going through the new GCD (Guix Common Document/RFC)
process is warranted before it is to be accepted/included in
Guix.
  
Attila Lendvai Feb. 2, 2025, 8:56 p.m. UTC | #2
> My first thought was similar to Liliana's reply in the other
> issue thread: putting lots of energy into making it convenient to fork
> Guix instead of contributing to the review process (described as slow
> and erratic, which appears to be the motivation here), appears
> counter-productive.


FWIW, i have long-lived patches that will never be incorporated into guix proper. some are simply kludges that enable me to do proceed, while some others are rejected by the maintainers.

none of the above is solved by a better review process.

for the curious, here are the patches that i'm currently dragging along guix HEAD:

https://codeberg.org/attila-lendvai-patches/guix/commits/branch/attila

--
• attila lendvai
• PGP: 963F 5D5F 45C7 DFCD 0A39
--
“To eliminate statism is not to physically subdue the rulers, but to mentally liberate the ruled.”
	— Jakub Bożydar Wiśniewski
  
Simon Streit Feb. 2, 2025, 10:24 p.m. UTC | #3
Hello Maxim,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

> My first thought was similar to Liliana’s reply in the other issue
> thread: putting lots of energy into making it convenient to fork Guix
> instead of contributing to the review process (described as slow and
> erratic, which appears to be the motivation here), appears
> counter-productive.

I am all for contributing to the review process.  It is only through
recent discussions on this subject that I am forcing myself to be a bit
more active within the community again.  Thanks for getting me back in.
I am also at fault my self.  I have a personal channel running and the
list is getting longer on patches that rather be submitted.

I am nowhere close to be a contributor (yet).  I simply don’t have time
and resources to be more active at the moment.  At the same time I also
don’t want to wait for months until certain patches – which have been
submitted for review – are pushed upstream.

I do keep patches running on top of local branches that are constantly
being re-based from upstream.  While time consuming, it seems to be the
most convenient at the moment.

I don’t even want maintain a local fork.  It is not that I really need
one.  I use it for development, thus many branches are just dead ends
that are kept for archival reasons.  I have a local central repository
where I usually push my work to be more independent from my devices –
which is my issue.  And here I only recently realised that I can’t even
push these branches to my central repository any more.

Then I tried it the other day to set up a modified keyring and
authenticate with my key and push it to my local repository as described
in the manual.  I failed for some reason and probably missed something.
This time I felt it: The bar is now seriously high to work on Guix at
the moment.

While the authentication mechanism is useful and necessary to prove what
is from Guix, it defeats the point to use Git as a decentralised tool.
It should be possible to allow local modifications for personal use,
also as unauthorised contributors.

I am for it.  Including a warning that I am pulling an unauthenticated
fork.


Kind regards
  
Simon Tournier Feb. 3, 2025, 3:15 p.m. UTC | #4
Hi,

On Sat, 01 Feb 2025 at 17:13, 45mg <45mg.writes@gmail.com> wrote:
> * guix/scripts/fork.scm, guix/scripts/fork/create.scm: New files.

[...]

> * guix/scripts/git/authenticate.scm

I think this fork “feature” should not be yet another subcommand but
this must be another subsubcommand: ’guix git fork’.

It would make more sense, IMHO.

Cheers,
simon
  
Maxim Cournoyer Feb. 4, 2025, 5:38 a.m. UTC | #5
Hi Simon,

Simon Streit <simon@netpanic.org> writes:

> Hello Maxim,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
>
>> My first thought was similar to Liliana’s reply in the other issue
>> thread: putting lots of energy into making it convenient to fork Guix
>> instead of contributing to the review process (described as slow and
>> erratic, which appears to be the motivation here), appears
>> counter-productive.
>
> I am all for contributing to the review process.  It is only through
> recent discussions on this subject that I am forcing myself to be a bit
> more active within the community again.  Thanks for getting me back in.
> I am also at fault my self.  I have a personal channel running and the
> list is getting longer on patches that rather be submitted.

I didn't mean to make anyone feel bad for having a channel, just to
state that if someone wants to have an impact on the slow review
process, the direction should be contributing toward that goal by
providing more eyes and hands, not providing more tools to more
comfortably doing our own things in our sandbox without interacting.  So
I'm glad if the result was to nudge you toward joining the review party ;-).

> I am nowhere close to be a contributor (yet).  I simply don’t have time
> and resources to be more active at the moment.  At the same time I also
> don’t want to wait for months until certain patches – which have been
> submitted for review – are pushed upstream.

There's no hiding it: reviewing is a (very) time consuming process, and
is currently done by volunteers, so on their own limited time they
probably would rather use to hack on things that personally matter more
to them :-).  The more hands we throw at it, the less time individual
reviewers have to spend on it to keep the community happy and running
smoothly.

> I do keep patches running on top of local branches that are constantly
> being re-based from upstream.  While time consuming, it seems to be the
> most convenient at the moment.

> I don’t even want maintain a local fork.  It is not that I really need
> one.  I use it for development, thus many branches are just dead ends
> that are kept for archival reasons.  I have a local central repository
> where I usually push my work to be more independent from my devices –
> which is my issue.  And here I only recently realised that I can’t even
> push these branches to my central repository any more.

For development, I simply use git checkouts and force-push them around
when I have to, or use './pre-inst-env guix deploy'.  It's not as
seamless as simply using 'guix', but it did the job when I needed it.  I
feel this feature here caters to more long-term forks that could have
multiple users, thus requiring authentication.

> Then I tried it the other day to set up a modified keyring and
> authenticate with my key and push it to my local repository as described
> in the manual.  I failed for some reason and probably missed something.
> This time I felt it: The bar is now seriously high to work on Guix at
> the moment.

I feel perhaps people are trying to replace Git by Guix :-).  Or are
operating outside what I'd call 'development', and want some
fancier/better integrated distribution means for Guix as a whole.

> While the authentication mechanism is useful and necessary to prove what
> is from Guix, it defeats the point to use Git as a decentralised tool.
> It should be possible to allow local modifications for personal use,
> also as unauthorised contributors.
>
> I am for it.  Including a warning that I am pulling an unauthenticated
> fork.

What do you mean unauthenticated?  The point of this feature is to make
authenticated forks easier to setup/work with, so you wouldn't get any
warning, unless I'm missing something.

Thanks for sharing your thoughts.
  

Patch

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 <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~%")))))))
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 <~@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
+                                       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 <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.
 ;;;
@@ -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.