[bug#78477] teams: Add script to refresh GNOME core packages.
Commit Message
* etc/teams/gnome/gnome-core-refresh: New file.
Change-Id: I7c7de6ce4689cef9c51d357e6ea3d16468078013
---
etc/teams/gnome/gnome-core-refresh | 120 +++++++++++++++++++++++++++++
1 file changed, 120 insertions(+)
create mode 100755 etc/teams/gnome/gnome-core-refresh
base-commit: 6b5fc4812981f2cadffcc5d39e48cd8e02ee73af
new file mode 100755
@@ -0,0 +1,120 @@
+#!/usr/bin/env -S guix repl --
+!# ;-*- mode: scheme; -*-
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Maxim Cournoyer <maxim.cournoyer@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/>.
+
+;;; Commentary:
+;;;
+;;; This is a wrapper of 'guix refresh' that refreshes all the GNOME core
+;;; packages listed in their release engineering (releng) list to their stable
+;;; version. Set the PARTIAL_VERSIONS environment variable to update to
+;;; compatible versions instead of exact ones. The GNOME_RELENG_VERSIONS_URI
+;;; environment variable can also point to a different URL or file, for
+;;; example to update to a past GNOME version. The script can be invoked as:
+;;;
+;;; $ ./pre-inst-env etc/teams/gnome/gnome-core-refresh --update
+;;; or
+;;; $ ./pre-inst-env env PARTIAL_VERSIONS=1 etc/teams/gnome/gnome-core-refresh -u
+;;;
+;;; Code:
+
+(use-modules (gnu packages)
+ (guix diagnostics)
+ (guix http-client)
+ (guix scripts refresh)
+ (guix utils)
+ (ice-9 format)
+ (ice-9 exceptions)
+ (ice-9 match)
+ (ice-9 peg)
+ (ice-9 textual-ports)
+ (srfi srfi-1))
+
+(define %gnome-releng-versions-uri
+ (make-parameter
+ (or (getenv "GNOME_RELENG_VERSIONS_URI")
+ "https://gitlab.gnome.org/GNOME/releng/-/raw/master/\
+tools/versions-stable")))
+
+(define (fetch-releng-content)
+ "Return an input port to the %GNOME-RELENG-VERSIONS-URI file."
+ (call-with-port (http-fetch/cached (%gnome-releng-versions-uri))
+ get-string-all))
+
+(define-exception-type &releng-parser-error &error
+ make-releng-parser-error releng-parser-error?)
+
+(define-peg-string-patterns "\
+releng <-- (comment / entry)* !.
+entry <-- suite C name C version C subdir NL
+suite <-- text
+name <-- text
+version <-- text
+subdir <-- text?
+text <- (!NL !C .)*
+comment < '#' (!NL .)* NL
+C < ':'
+NL < '\n'")
+
+(define %names
+ '(("adwaita-fonts" . "font-adwaita")))
+
+(define (parse-releng data)
+ "Return DATA, a string representing the content of a GNOME releng file, and
+return the complete parse tree."
+ (let ((tree (peg:tree (match-pattern releng data))))
+ (match tree
+ (#f (raise-exception (make-releng-parser-error)))
+ (_ tree))))
+
+(define (check-package-name name)
+ "Return #t if a package corresponding to NAME exists, else #f."
+ (catch 'quit
+ (lambda ()
+ (parameterize ((guix-warning-port (%make-void-port "w")))
+ (specification->package name)
+ #t))
+ (lambda _
+ (format (current-error-port) "TODO: package ~a~%" name)
+ #f)))
+
+(define* (releng-tree->update-specs tree #:key (partial-versions?
+ (getenv "PARTIAL_VERSIONS")))
+ "Take TREE and return a list of package specifications. If
+PARTIAL-VERSIONS? is true, the least significant digit in version is
+stripped and the version is prefixed with the '~' character, so that 'guix
+refresh' can automatically find the newest compatible version."
+ (match tree
+ (('releng ('entry ('suite "core") ('name name) ('version version) _) ...)
+ (filter-map (lambda (name version)
+ (let ((name (or (assoc-ref %names name) name)))
+ (and (check-package-name name)
+ (if partial-versions?
+ (let* ((parts (string-split version #\.))
+ (num-parts (length parts)))
+ (if (> num-parts 1)
+ (format #f "~a=~~~a" name
+ (version-prefix version
+ (1- num-parts)))
+ (format #f "~a=~a" name version)))
+ (format #f "~a=~a" name version)))))
+ name version))))
+
+(apply guix-refresh (append (cdr (command-line))
+ (releng-tree->update-specs
+ (parse-releng (fetch-releng-content)))))