Subject: [PATCH (WIP) v1.5 2/4] Add 'guix fork authenticate'.

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

* guix/scripts/fork/authenticate.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: Ic34a1b3d1642cedce8d1ff5bae825df30e47755c
---
 Makefile.am                        |   1 +
 guix/scripts/fork.scm              |   6 +-
 guix/scripts/fork/authenticate.scm | 331 +++++++++++++++++++++++++++++
 3 files changed, 336 insertions(+), 2 deletions(-)
 create mode 100644 guix/scripts/fork/authenticate.scm

diff --git a/Makefile.am b/Makefile.am
index c628450a5a..1c1f5d84fd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -379,6 +379,7 @@ MODULES =					\
   guix/scripts/git/authenticate.scm		\
   guix/scripts/fork.scm			\
   guix/scripts/fork/create.scm			\
+  guix/scripts/fork/authenticate.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 2d97bcb93f..c5c7a59ba7 100644
--- a/guix/scripts/fork.scm
+++ b/guix/scripts/fork.scm
@@ -29,7 +29,9 @@ (define (show-help)
   (display (G_ "The valid values for ACTION are:\n"))
   (newline)
   (display (G_ "\
-   create    set up a fork of Guix\n"))
+   create          set up a fork of Guix\n"))
+  (display (G_ "\
+   authenticate    authenticate a fork of Guix\n"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -38,7 +40,7 @@ (define (show-help)
   (newline)
   (show-bug-report-information))
 
-(define %sub-commands '("create"))
+(define %sub-commands '("create" "authenticate"))
 
 (define (resolve-sub-command name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/fork/authenticate.scm b/guix/scripts/fork/authenticate.scm
new file mode 100644
index 0000000000..83d9d87d44
--- /dev/null
+++ b/guix/scripts/fork/authenticate.scm
@@ -0,0 +1,331 @@
+;;; 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 authenticate)
+  #:use-module (git)
+  #:use-module (guix git)
+  #:use-module (guix git-authenticate)
+  #:use-module (guix base16)
+  #:use-module (guix ui)
+  #:use-module (guix progress)
+  #:use-module (guix scripts)
+  #:use-module (guix build utils)
+  #:use-module (guix channels)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 format)
+  #: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-authenticate
+
+            fork-config-value
+            fork-configured?
+            fork-configured-keyring-reference
+            fork-configured-introduction))
+
+;;; Commentary:
+;;;
+;;; Authenticate a fork of Guix, in the same manner as `guix git
+;;; authenticate`.
+;;;
+;;; 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 authenticate")))
+
+        (option '(#\r "repository") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'directory arg result)))
+        (option '("upstream-commit") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'upstream-commit (string->oid arg) result)))
+        (option '("upstream-signer") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'upstream-signer (openpgp-fingerprint* arg) result)))
+
+        (option '(#\e "end") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'end-commit (string->oid arg) result)))
+        (option '("upstream-end") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'upstream-end-commit (string->oid arg) result)))
+        (option '(#\k "keyring") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'keyring-reference arg result)))
+        (option '("upstream-keyring") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'upstream-keyring arg result)))
+        (option '("cache-key") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'cache-key arg result)))
+        (option '("historical-authorizations") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'historical-authorizations arg
+                              result)))
+        (option '("stats") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'show-stats? #t result)))))
+
+(define %default-options
+  (let ((introduction (channel-introduction %default-guix-channel)))
+    `((upstream-commit
+       . ,(string->oid (channel-introduction-first-signed-commit introduction)))
+      (upstream-signer
+       . ,(openpgp-fingerprint
+           (string-upcase
+            (bytevector->base16-string
+             (channel-introduction-first-commit-signer introduction)))))
+      (upstream-keyring
+       . "keyring"))))
+
+(define %usage
+  (format #f (G_ "Usage: guix fork authenticate UPSTREAM COMMIT SIGNER [OPTIONS...]
+Authenticate a fork of Guix, using COMMIT/SIGNER as the fork introduction.
+
+First, authenticate new commits from UPSTREAM, using Guix's default
+introduction. Then authenticate the remaining commits using the fork
+introduction.
+
+  -r, --repository=DIRECTORY
+                         Authenticate the Git repository in DIRECTORY
+
+      --upstream-commit=COMMIT
+      --upstream-signer=SIGNER
+                         Use COMMIT/SIGNER as the introduction for upstream
+                         Guix, overriding the default values
+                         ~a
+                        /~a
+                         (Guix's default introduction).
+
+  -k, --keyring=REFERENCE
+                         load keyring for fork commits from REFERENCE, a Git
+                         branch (default \"keyring\")
+      --upstream-keyring=REFERENCE
+                         load keyring for upstream commits from REFERENCE, a
+                         Git branch (default \"keyring\")
+      --end=COMMIT       authenticate fork commits up to COMMIT
+      --cache-key=KEY    cache authenticated commits under KEY
+      --historical-authorizations=FILE
+                         read historical authorizations from FILE
+      --stats            Display commit signing statistics upon completion
+
+  -h, --help             display this help and exit
+  -V, --version          display version information and exit
+")
+          (assoc-ref %default-options 'upstream-commit)
+          (assoc-ref %default-options 'upstream-signer)))
+
+(define (show-help)
+  (display %usage)
+  (newline)
+  (show-bug-report-information))
+
+(define (missing-arguments)
+  (leave (G_ "wrong number of arguments; \
+required UPSTREAM, COMMIT and SIGNER~%")))
+
+
+;;;
+;;; Helper prodecures.
+;;;
+
+(define (fork-config-value repository key)
+  "Return the config value associated with KEY in the
+'guix.fork-authentication' namespace in REPOSITORY, or #f if no such config
+was found."
+  (let* ((config (repository-config repository))
+         (branch (repository-current-branch repository)))
+    (catch 'git-error
+      (lambda ()
+        (config-entry-value
+         (config-get-entry config
+                           (string-append "guix.fork-authentication."
+                                          key))))
+      (const #f))))
+
+(define (fork-configured-introduction repository)
+  "Return three values: the upstream branch name, introductory commit, and
+signer fingerprint (strings) for this fork, as configured in REPOSITORY.
+Error out if any were missing."
+  (let* ((upstream-branch (fork-config-value repository "upstream-branch"))
+         (commit (fork-config-value repository "introduction-commit"))
+         (signer (fork-config-value repository "introduction-signer")))
+    (unless (and upstream-branch commit signer)
+      (leave (G_ "fork information in .git/config is incomplete;
+missing at least one of
+introduction-commit, introduction-signer, upstream-branch
+under [guix \"fork-authentication\"]")))
+    (values upstream-branch commit signer)))
+
+(define (fork-configured-keyring-reference repository)
+  "Return the keyring reference configured in REPOSITORY or #f if missing."
+  (fork-config-value repository "keyring"))
+
+(define (fork-configured? repository)
+  "Return true if REPOSITORY already contains fork introduction info in its
+'config' file."
+  (and (fork-config-value repository "upstream-branch")
+       (fork-config-value repository "introduction-commit")
+       (fork-config-value repository "introduction-signer")))
+
+(define* (record-fork-configuration
+          repository
+          #:key commit signer upstream-branch keyring-reference)
+  "Record COMMIT, SIGNER, UPSTREAM-BRANCH and KEYRING-REFERENCE in the
+'config' file of REPOSITORY."
+  (define config
+    (repository-config repository))
+
+  ;; Guile-Git < 0.7.0 lacks 'set-config-string'.
+  (if (module-defined? (resolve-interface '(git)) 'set-config-string)
+      (begin
+        (set-config-string config "guix.fork-authentication.introduction-commit"
+                           commit)
+        (set-config-string config "guix.fork-authentication.introduction-signer"
+                           signer)
+        (set-config-string config "guix.fork-authentication.upstream-branch"
+                           upstream-branch)
+        (set-config-string config "guix.fork-authentication.keyring"
+                           keyring-reference)
+        (info (G_ "introduction, upstream branch and keyring recorded \
+in repository configuration file~%")))
+      (warning (G_ "could not record introduction and keyring configuration\
+ (Guile-Git too old?)~%"))))
+
+
+(define (guix-fork-authenticate . 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 (make-reporter start-commit end-commit commits)
+    (format (current-error-port)
+            (G_ "Authenticating commits ~a to ~a (~h new \
+commits)...~%")
+            (commit-short-id start-commit)
+            (commit-short-id end-commit)
+            (length commits))
+    (if (isatty? (current-error-port))
+        (progress-reporter/bar (length commits))
+        progress-reporter/silent))
+
+  (with-error-handling
+    (with-git-error-handling
+     ;; TODO: BUG: it doesn't recognize '~' in paths
+     ;; How to do 'realpath' in Guile?
+     (let* ((repository (repository-open (or (assoc-ref options 'directory)
+                                             (repository-discover "."))))
+            (upstream commit signer (match (command-line-arguments options)
+                                      ((upstream commit signer)
+                                       (values
+                                        (branch-lookup repository upstream)
+                                        (string->oid commit)
+                                        (openpgp-fingerprint* signer)))
+                                      (()
+                                       (receive (upstream commit signer)
+                                           (fork-configured-introduction repository)
+                                         (values
+                                          (branch-lookup repository upstream)
+                                          (string->oid commit)
+                                          (openpgp-fingerprint* signer))))
+                                      (_
+                                       (missing-arguments))))
+            (upstream-commit (assoc-ref options 'upstream-commit))
+            (upstream-signer (assoc-ref options 'upstream-signer))
+            (history (match (assoc-ref options 'historical-authorizations)
+                       (#f '())
+                       (file (call-with-input-file file
+                               read-authorizations))))
+            (keyring (or (assoc-ref options 'keyring-reference)
+                         (fork-configured-keyring-reference repository)
+                         "keyring"))
+            (upstream-keyring (assoc-ref options 'upstream-keyring))
+            (end (match (assoc-ref options 'end-commit)
+                   (#f  (reference-target
+                         (repository-head repository)))
+                   (oid oid)))
+            (upstream-end (match (assoc-ref options 'upstream-end-commit)
+                            (#f
+                             (reference-target upstream))
+                            (oid oid)))
+            (cache-key (or (assoc-ref options 'cache-key)
+                           (repository-cache-key repository)))
+            (show-stats? (assoc-ref options 'show-stats?)))
+
+       (define upstream-authentication-args
+         (filter identity
+                 (list
+                  (oid->string upstream-commit)
+                  (bytevector->base16-string upstream-signer)
+                  (string-append "--repository="
+                                 (repository-directory repository))
+                  (string-append "--end="
+                                 (oid->string upstream-end))
+                  (and upstream-keyring
+                       (string-append "--keyring="
+                                      upstream-keyring))
+                  (and show-stats? "--stats"))))
+
+       (info (G_ "calling `guix git authenticate` for branch ~a...~%")
+             (branch-name upstream))
+
+       (apply run-guix-command 'git "authenticate"
+              upstream-authentication-args)
+
+       (define fork-stats
+         (authenticate-repository
+          repository commit signer
+          #:end end
+          #:keyring-reference keyring
+          #:historical-authorizations history
+          #:cache-key cache-key
+          #:make-reporter make-reporter))
+
+       (unless (fork-configured? repository)
+         (record-fork-configuration repository
+                               #:commit (oid->string commit)
+                               #:signer (bytevector->base16-string signer)
+                               #:upstream-branch (branch-name upstream)
+                               #:keyring-reference keyring))
+
+       (when (and show-stats? (not (null? fork-stats)))
+         (show-authentication-stats fork-stats))
+
+       (info (G_ "successfully authenticated commit ~a~%")
+             (oid->string end))))))
-- 
2.48.1