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

Message ID 20c828d43d189914c7a5a3de58831f74b134e796.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/update.scm: New file.
* Makefile.am (MODULES): Add the new file.
* guix/scripts/fork.scm
(show-help): Mention new command.
(%sub-commands): Add new command.

Change-Id: I2017eb9a9286c02ca8bdf962bcbfe89d7607c413
---
 Makefile.am                  |   1 +
 guix/scripts/fork.scm        |   4 +-
 guix/scripts/fork/update.scm | 182 +++++++++++++++++++++++++++++++++++
 3 files changed, 186 insertions(+), 1 deletion(-)
 create mode 100644 guix/scripts/fork/update.scm
  

Comments

Maxim Cournoyer Feb. 2, 2025, 4:21 p.m. UTC | #1
Hi,

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

> * guix/scripts/fork/update.scm: New file.
> * Makefile.am (MODULES): Add the new file.

Or, "Register it."

> * guix/scripts/fork.scm
> (show-help): Mention new command.
> (%sub-commands): Add new command.

OK.

[...]

> +(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 '( "fork-branch") #t #f

Extraneous space in list.

> +                (lambda (opt name arg result)
> +                  (alist-cons 'fork-branch-name arg result)))
> +        (option '(#\r "repository") #t #f
> +                (lambda (opt name arg result)
> +                  (alist-cons 'directory arg result)))))
> +
> +(define %default-options
> +  '())
> +
> +(define %usage
> +  (G_ "Usage: guix fork update [OPTIONS...]
> +Pull into this Guix fork's configured upstream branch, then apply new commits
> +onto the current branch.

I'd reword the beginning to "Pull into this Guix fork its configured
upstream branch [...]"

> +
> +  -r, --repository=DIRECTORY
> +                         Act in the Git repository in DIRECTORY

Maybe, "Work on the Git repository in DIRECTORY"

> +      --fork-branch=BRANCH
> +                         Apply new commits onto BRANCH instead of the current
> +                         branch
> +
> +  -h, --help             display this help and exit
> +  -V, --version          display version information and exit
> +"))
> +
> +(define (show-help)
> +  (display %usage)
> +  (newline)
> +  (show-bug-report-information))
> +
> +(define (missing-arguments)
> +    (leave (G_ "wrong number of arguments; \
> +required ~%")))
> +
> +
> +;;;
> +;;; Entry point.
> +;;;
> +
> +(define (guix-fork-update . 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)))
> +
> +  (define-syntax invoke-git
> +    (lambda (x)
> +      (syntax-case x ()
> +        ((_ args ...)
> +         #`(invoke "git" "-C" #,(datum->syntax x 'directory) args ...)))))
> +
> +  (define-syntax invoke-git/stdout
> +    (lambda (x)
> +      (syntax-case x ()
> +        ((_ args ...)
> +         #`(string-trim-right
> +            (invoke/stdout "git" "-C" #,(datum->syntax x 'directory) args ...))))))
> +
> +  (with-error-handling
> +    (let* ((directory (or (assoc-ref options 'directory) "."))
> +           (current-branch-name (invoke-git/stdout
> +                                 "branch"
> +                                 "--show-current"))
> +           (current-head-location (invoke-git/stdout
> +                                   "rev-parse"
> +                                   "HEAD"))
> +           (fork-branch-name (or (assoc-ref options 'fork-branch-name)
> +                                 (if (string= current-branch-name "")
> +                                     (leave (G_ "no current branch and --fork-branch not given"))

Too wide.  You can always break a string with a \ escape.

> +                                     current-branch-name)))
> +
> +           (repository (repository-open directory))
> +           (upstream-branch-name introduction-commit introduction-signer
> +                                 (if (fork-configured? repository)
> +                                     (fork-configured-introduction
> +                                      (repository-open directory))
> +                                     (leave (G_ "fork not fully configured.
> +(Did you remember to run `guix fork authenticate` first?)%~"))))

'leave' prints errors, which conventionally should be brief and not
complete sentence. I think you could get a nicer result by using a
compound condition combining a &message and &fix-hint conditions; which
the `with-error-handling' handler will correcly format with colors and
all.

> +           (upstream-branch-commit
> +            (invoke-git/stdout "rev-parse" upstream-branch-name))
> +           (new-upstream-branch-commit "")
> +           (config (repository-config repository))
> +           (signing-key
> +            (or
> +             (catch 'git-error
> +               (lambda ()
> +                 (config-entry-value
> +                  (config-get-entry config "user.signingkey")))
> +               (const #f))
> +             (begin
> +               (info (G_ "user.signingkey not set for this repository.~%"))
> +               (info (G_ "Will attempt to sign commits with fork introduction key.~%"))

Max width busted :-)

> +               introduction-signer))))
> +
> +      (info (G_ "Pulling into '~a'...~%") upstream-branch-name)
> +      (invoke-git "switch" upstream-branch-name)
> +      (invoke-git "pull")
> +      (set! new-upstream-branch-commit
> +            (invoke-git/stdout "rev-parse" upstream-branch-name))

I think you can use (define new-upstream-branch-commit ...) and avoid
its let-bound variable (set to the empty string).

> +
> +      (info (G_ "Rebasing commits from '~a' to '~a' onto fork branch '~a'...~%")
> +            upstream-branch-commit
> +            new-upstream-branch-commit
> +            fork-branch-name)
> +      (invoke-git "rebase" "--rebase-merges"
> +                  (string-append "--gpg-sign=" signing-key)
> +                  fork-branch-name new-upstream-branch-commit)
> +
> +      (info (G_ "Resetting fork branch '~a' to latest rebased commit...~%")
> +            fork-branch-name)
> +      (invoke-git "branch" "--force" fork-branch-name "HEAD")
> +
> +      (invoke-git "checkout" (or current-branch-name current-head-location))
> +
> +      (info (G_ "Successfully updated Guix fork in ~a~%")
> +            directory))))

Phew!  LGTM.  So the idea is to avoid rewriting the fork's introductory
commit and instead rewriting (rebasing) the Guix upstream commits on
top, which will resign them with the fork's authorized key, IIUC?

That's clever, but personally I much prefer to keep any work I've done
*rebased* on upstream so they are easily (re-)submitted, and it's clear
what extra work my fork has.  Seems like a good way for "forks" to hide
potentially bad commits hidden under thousands of rust commits,
obscuring them.

I think Liliana had that remark as well in the associated issue.
  
Liliana Marie Prikler Feb. 2, 2025, 6:23 p.m. UTC | #2
Am Montag, dem 03.02.2025 um 01:21 +0900 schrieb Maxim Cournoyer:
> So the idea is to avoid rewriting the fork's introductory
> commit and instead rewriting (rebasing) the Guix upstream commits on
> top, which will resign them with the fork's authorized key, IIUC?
> 
> That's clever, but personally I much prefer to keep any work I've
> done *rebased* on upstream so they are easily (re-)submitted, and
> it's clear what extra work my fork has.  Seems like a good way for
> "forks" to hide potentially bad commits hidden under thousands of
> rust commits, obscuring them.
> 
> I think Liliana had that remark as well in the associated issue.
I did remark that, yet :)

The problem with rebasing on Guix is that you will have to update the
introduction on each rebase (or indeed use an unauthenticated fork). 
If you do record the introduction, say, in your own channels.scm, `guix
pull` will break, which 45mg wants to avoid.

As you wrote in your first message, it appears somewhat counter-
productive to offer `guix fork` as a means of authoring such long-lived
forks, but sentiments aside, that's precisely the goal of this series.

Cheers
  
Liliana Marie Prikler Feb. 2, 2025, 6:24 p.m. UTC | #3
Am Sonntag, dem 02.02.2025 um 19:23 +0100 schrieb Liliana Marie
Prikler:
> > I think Liliana had that remark as well in the associated issue.
> I did remark that, yet :)
s/yet/yes/
  

Patch

diff --git a/Makefile.am b/Makefile.am
index 1c1f5d84fd..8edd371ccd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -380,6 +380,7 @@  MODULES =					\
   guix/scripts/fork.scm			\
   guix/scripts/fork/create.scm			\
   guix/scripts/fork/authenticate.scm			\
+  guix/scripts/fork/update.scm			\
   guix/scripts/graph.scm			\
   guix/scripts/weather.scm			\
   guix/scripts/container.scm			\
diff --git a/guix/scripts/fork.scm b/guix/scripts/fork.scm
index c5c7a59ba7..bf9c86e0aa 100644
--- a/guix/scripts/fork.scm
+++ b/guix/scripts/fork.scm
@@ -32,6 +32,8 @@  (define (show-help)
    create          set up a fork of Guix\n"))
   (display (G_ "\
    authenticate    authenticate a fork of Guix\n"))
+  (display (G_ "\
+   update          update a fork of Guix\n"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -40,7 +42,7 @@  (define (show-help)
   (newline)
   (show-bug-report-information))
 
-(define %sub-commands '("create" "authenticate"))
+(define %sub-commands '("create" "authenticate" "update"))
 
 (define (resolve-sub-command name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/fork/update.scm b/guix/scripts/fork/update.scm
new file mode 100644
index 0000000000..4223b9855c
--- /dev/null
+++ b/guix/scripts/fork/update.scm
@@ -0,0 +1,182 @@ 
+;;; 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 update)
+  #:use-module (guix scripts fork authenticate)
+  #:use-module (git repository)
+  #:use-module (git structs)
+  #:use-module (git config)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module ((guix utils) #:select (invoke/stdout))  ;TODO move invoke/stdout 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-update))
+
+;;; Commentary:
+;;;
+;;; Update a fork of Guix created via `guix fork create` and authenticated via
+;;; `guix fork authenticate`, by applying new commits from the upstream branch
+;;; onto it.
+;;;
+;;; 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 '( "fork-branch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'fork-branch-name arg result)))
+        (option '(#\r "repository") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'directory arg result)))))
+
+(define %default-options
+  '())
+
+(define %usage
+  (G_ "Usage: guix fork update [OPTIONS...]
+Pull into this Guix fork's configured upstream branch, then apply new commits
+onto the current branch.
+
+  -r, --repository=DIRECTORY
+                         Act in the Git repository in DIRECTORY
+      --fork-branch=BRANCH
+                         Apply new commits onto BRANCH instead of the current
+                         branch
+
+  -h, --help             display this help and exit
+  -V, --version          display version information and exit
+"))
+
+(define (show-help)
+  (display %usage)
+  (newline)
+  (show-bug-report-information))
+
+(define (missing-arguments)
+    (leave (G_ "wrong number of arguments; \
+required ~%")))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-fork-update . 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)))
+
+  (define-syntax invoke-git
+    (lambda (x)
+      (syntax-case x ()
+        ((_ args ...)
+         #`(invoke "git" "-C" #,(datum->syntax x 'directory) args ...)))))
+
+  (define-syntax invoke-git/stdout
+    (lambda (x)
+      (syntax-case x ()
+        ((_ args ...)
+         #`(string-trim-right
+            (invoke/stdout "git" "-C" #,(datum->syntax x 'directory) args ...))))))
+
+  (with-error-handling
+    (let* ((directory (or (assoc-ref options 'directory) "."))
+           (current-branch-name (invoke-git/stdout
+                                 "branch"
+                                 "--show-current"))
+           (current-head-location (invoke-git/stdout
+                                   "rev-parse"
+                                   "HEAD"))
+           (fork-branch-name (or (assoc-ref options 'fork-branch-name)
+                                 (if (string= current-branch-name "")
+                                     (leave (G_ "no current branch and --fork-branch not given"))
+                                     current-branch-name)))
+
+           (repository (repository-open directory))
+           (upstream-branch-name introduction-commit introduction-signer
+                                 (if (fork-configured? repository)
+                                     (fork-configured-introduction
+                                      (repository-open directory))
+                                     (leave (G_ "fork not fully configured.
+(Did you remember to run `guix fork authenticate` first?)%~"))))
+           (upstream-branch-commit
+            (invoke-git/stdout "rev-parse" upstream-branch-name))
+           (new-upstream-branch-commit "")
+           (config (repository-config repository))
+           (signing-key
+            (or
+             (catch 'git-error
+               (lambda ()
+                 (config-entry-value
+                  (config-get-entry config "user.signingkey")))
+               (const #f))
+             (begin
+               (info (G_ "user.signingkey not set for this repository.~%"))
+               (info (G_ "Will attempt to sign commits with fork introduction key.~%"))
+               introduction-signer))))
+
+      (info (G_ "Pulling into '~a'...~%") upstream-branch-name)
+      (invoke-git "switch" upstream-branch-name)
+      (invoke-git "pull")
+      (set! new-upstream-branch-commit
+            (invoke-git/stdout "rev-parse" upstream-branch-name))
+
+      (info (G_ "Rebasing commits from '~a' to '~a' onto fork branch '~a'...~%")
+            upstream-branch-commit
+            new-upstream-branch-commit
+            fork-branch-name)
+      (invoke-git "rebase" "--rebase-merges"
+                  (string-append "--gpg-sign=" signing-key)
+                  fork-branch-name new-upstream-branch-commit)
+
+      (info (G_ "Resetting fork branch '~a' to latest rebased commit...~%")
+            fork-branch-name)
+      (invoke-git "branch" "--force" fork-branch-name "HEAD")
+
+      (invoke-git "checkout" (or current-branch-name current-head-location))
+
+      (info (G_ "Successfully updated Guix fork in ~a~%")
+            directory))))