guix_mirror_bot pushed a commit to branch version-1.5.0 in repository guix.
commit 2d4ed08662714ea46cfe0b41ca195d1ef845fd1b Author: Rutherther <[email protected]> AuthorDate: Tue Dec 16 12:26:57 2025 +0100 etc: release: Switch to Guile declaration of artifacts. This is a rewrite of the bash commands for generation of guix binary tarballs and system images to Guile. I am expecting this will help us significantly with getting the same derivations locally and from Cuirass, instead of relying on images/tarball job specifications and trying to tweak it locally to have the same ones. Implements: #4347, #4348. * etc/teams/release/artifacts-manifest.scm: Make a manifest with release artifacts for all supported systems. * etc/teams/release/artifacts.scm: Collect artifacts for all supported systems into a union with proper names for the release artifacts. * Makefile.am (release): Use time-machine instead of pre-inst-env; Switch to building new artifacts.scm Change-Id: I71a6a27e6f315dd31b91c49e71dff2d09695c0dc Signed-off-by: Rutherther <[email protected]> --- Makefile.am | 55 +---- etc/teams/release/artifacts-manifest.scm | 412 +++++++++++++++++++++++++++++++ etc/teams/release/artifacts.scm | 26 ++ 3 files changed, 451 insertions(+), 42 deletions(-) diff --git a/Makefile.am b/Makefile.am index cca120baa1..dabceddf2a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1177,49 +1177,20 @@ prepare-release: dist-with-updated-version all @echo "Now push the resulting commit and run `make release`." @echo +# Make sure you've ran prepare-release prior to running release and pushed +# the commit to Guix. It might be pushed to any branch, such as version-X.Y.Z. release: all -# Generate the binary release tarballs. - rm -f $(BINARY_TARBALLS) - $(MAKE) $(BINARY_TARBALLS) - for system in $(SUPPORTED_SYSTEMS) ; do \ - mv "guix-binary.$$system.tar.xz" \ - "$(releasedir)/guix-binary-$(PACKAGE_VERSION).$$system.tar.xz" ; \ - done -# Build 'current-guix' to speed things up for the next step. - $(top_builddir)/pre-inst-env guix build \ - -e '((@ (gnu packages package-management) current-guix))' \ - $(call system_flags,$(GUIX_SYSTEM_INSTALLER_SYSTEMS)) \ - -v1 --no-grafts --fallback -# Generate the ISO installation images. - for system in $(GUIX_SYSTEM_INSTALLER_SYSTEMS) ; do \ - GUIX_DISPLAYED_VERSION="`git describe --match=v* | sed -'es/^v//'`" ; \ - image=`$(top_builddir)/pre-inst-env \ - guix system image -t iso9660 \ - --label="GUIX_$${system}_$(VERSION)" \ - --system=$$system --fallback \ - gnu/system/install.scm` ; \ - if [ ! -f "$$image" ] ; then \ - echo "failed to produce Guix installation image for $$system" >&2 ; \ - exit 1 ; \ - fi ; \ - cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" ; \ - mv "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" \ - "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso" ; \ - done -# Generate the VM images. - for system in $(GUIX_SYSTEM_VM_SYSTEMS) ; do \ - GUIX_DISPLAYED_VERSION="`git describe --match=v* | sed -'es/^v//'`" ; \ - image=`$(top_builddir)/pre-inst-env \ - guix system image -t qcow2 $(GUIX_SYSTEM_VM_IMAGE_FLAGS) \ - --save-provenance \ - --system=$$system --fallback \ - gnu/system/examples/vm-image.tmpl` ; \ - if [ ! -f "$$image" ] ; then \ - echo "failed to produce Guix VM image for $$system" >&2 ; \ - exit 1 ; \ - fi ; \ - cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_VM_IMAGE_BASE).$$system.qcow2"; \ - done +# Build the artifacts for current commit. +# Use time-machine for provenance. + $(MKDIR_P) "$(releasedir)" + @echo "Building guix inferior for current commit." + COMMIT="$$(git rev-parse HEAD)" && \ + GUIX="$$(guix time-machine --commit=$$COMMIT)/bin/guix" && \ + echo "Building artifacts for current commit: $$COMMIT." && \ + ARTIFACTS="$$($$GUIX build --no-grafts \ + -f ./etc/teams/release/artifacts.scm)" && \ + echo "Artifacts built! Copying to $(releasedir)" && \ + cp -f "$$ARTIFACTS"/* "$(releasedir)" @echo @echo "Congratulations! All the release files are now in $(releasedir)." @echo diff --git a/etc/teams/release/artifacts-manifest.scm b/etc/teams/release/artifacts-manifest.scm new file mode 100644 index 0000000000..7b8c942c79 --- /dev/null +++ b/etc/teams/release/artifacts-manifest.scm @@ -0,0 +1,412 @@ +;;; GNU Guix --- Functional package management for GNU +;;; +;;; 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/>. + +;;; This manifest returns build artfacts for all supported systems. This can be +;;; controlled by SUPPORTED_SYSTEMS environment variable. For the list of +;;; artifacts produced, see artifacts-for-system and the `<thing>-for-system?` +;;; procedures. NOTE: the --system argument does not change the system for which +;;; the resulting package is built. They return different definitions of the +;;; images. To change the system, pass different SUPPORTED_SYSTEMS. + +(use-modules (gnu compression) + (gnu image) + (gnu packages graphviz) + (gnu packages imagemagick) + (gnu packages package-management) + (gnu packages perl) + (gnu services) + (gnu system image) + (gnu system install) + (gnu system) + (guix build-system gnu) + (guix build-system trivial) + (guix channels) + (guix gexp) + (guix git) + (guix grafts) + (guix memoization) + (guix monads) + (guix packages) + (guix profiles) + (guix records) + (guix scripts pack) + (guix store) + (guix ui) + (guix utils) + (ice-9 format) + (ice-9 match) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-35)) + +;; For easier testing, use (snapshot) guix package from (gnu packages +;; package-management). Otherwise, the package is updated to current commit and +;; might not be substitutable, leading to longer build times. +(define %use-snapshot-package? + (string=? (or (getenv "GUIX_USE_SNAPSHOT_PACKAGE") "no") "yes")) + +(define (%guix-version) + ;; NOTE: while package-version guix is not correct in general, + ;; it is correct for the release itself. At that time, the + ;; guix package is updated to vX.Y.Z and it's the version + ;; we want to use. + (package-version guix)) + +(define (%vm-image-path) + (search-path %load-path "gnu/system/examples/vm-image.tmpl")) + +(define (%vm-image-efi-path) + (search-path %load-path "gnu/system/examples/vm-image-efi.tmpl")) + +;; monadic record and gexp-compiler +;; taken from Inria +;; https://gitlab.inria.fr/numpex-pc5/wp3/guix-images/-/blob/17bf4585abc2d637faa5d339436e778b7c9fb1ce/modules/guix-hpc/packs.scm + +;; XXX: The <monadic> hack below will hopefully become unnecessary once the +;; (guix scripts pack) interface switches to declarative style--i.e., +;; file-like objects. + +(define-record-type <monadic> + (monadic->declarative mvalue) + monadic? + (mvalue monadic-value)) + +(define-gexp-compiler (monadic-compiler (monadic <monadic>) system target) + (monadic-value monadic)) + +;; The tarball should be the same for every system. +;; Still, we need to decide what system to build it +;; for, so use the one that CI has most resources for. +(define (source-tarball-for-system? system) + (member system + '("x86_64-linux"))) + +(define (iso-for-system? system) + (member system + '("x86_64-linux" "i686-linux" "aarch64-linux"))) + +(define (qcow2-for-system? system) + (member system + '("x86_64-linux" "aarch64-linux"))) + +(define* (qcow2-gpt-for-system? system) + (string=? system "aarch64-linux")) + +(define (copy-/etc/config.scm config) + "Copy the configuration.scm of the operating system to /etc/config.scm, for +user's convenience. The file has to be writable, not a link to the store, so +etc-service-type can't be used here. CONFIG is a pair of strings, (FROM . TO). +The config will be copied from FROM to TO." + (match config + ((from . to) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (when (not (file-exists? #$to)) + (copy-file #$from #$to) + (make-file-writable #$to))))) + (_ (raise + (formatted-message-string + (G_ "unexpected config parameter, should be pair of strings: ~a" + config)))))) + +(define copy-/etc/config.scm-service-type + (service-type (name 'copy-/etc/config.scm) + (description + "Copy the system configuration file to /etc/config.scm.") + (extensions (list (service-extension activation-service-type + copy-/etc/config.scm))) + (default-value (cons "/run/current-system/configuration.scm" + "/etc/config.scm")))) + +(define (operating-system-with-/etc/config.scm os) + "Copy the system configuration file to writable /etc/config.scm on first boot." + (operating-system + (inherit os) + (services (cons (service copy-/etc/config.scm-service-type) + (operating-system-user-services os))))) + +(define (simple-provenance-entry config-file) + "Return system entries describing the operating system config, provided +through CONFIG-FILE." + (mbegin %store-monad + (return `(("configuration.scm" + ,(local-file (assume-valid-file-name config-file) + "configuration.scm")))))) + +;; This is mostly taken from provenance-service-type from (gnu services), +;; but it provides only configuration.scm, not channels.scm. This is +;; to get the same derivations for both Cuirass and local builds. +;; In the future, provenance-service-type could be adapted to support +;; this use case as well. +(define simple-provenance-service-type + (service-type (name 'provenance) + (extensions + (list (service-extension system-service-type + simple-provenance-entry))) + (default-value #f) ;the OS config file + (description + "Store configuration.scm of the system in the system +itself."))) + +(define* (operating-system-with-simple-provenance + os + #:optional + (config-file + (operating-system-configuration-file + os))) + "Return a variant of OS that stores its CONFIG-FILE. This is similar to +`operating-system-with-provenance`, but it does copy only the +configuration.scm." + (operating-system + (inherit os) + (services (cons (service simple-provenance-service-type config-file) + (operating-system-user-services os))))) + +(define (guix-package-commit guix) + ;; Extract the commit of the GUIX package. + (match (package-source guix) + ((? channel? source) + (channel-commit source)) + (_ + (apply (lambda* (#:key commit #:allow-other-keys) commit) + (package-arguments guix))))) + +;; NOTE: Normally, we would use (current-guix), along with url +;; overriden to the upstream repository to not leak our local checkout. +;; But currently, the (current-guix) derivation has to be computed through +;; QEMU for systems other than your host system. This takes a lot of time, +;; it takes at least half an hour to get the derivations. +(define (guix-package/with-commit guix commit) + "Use the guix from (gnu packages package-management), +but override its commit to the specified version. Make sure +to also override the channel commit to have the correct +provenance." + (let ((scm-version (car (string-split (package-version guix) #\-)))) + (package + (inherit guix) + (version (string-append scm-version "." (string-take commit 7))) + (source (git-checkout + (url (channel-url %default-guix-channel)) + (commit commit))) + (arguments + (substitute-keyword-arguments (package-arguments guix) + ((#:configure-flags flags '()) + #~(cons* + (string-append "--with-channel-commit=" #$commit) + (filter (lambda (flag) + (not (string-prefix? "--with-channel-commit=" flag))) + #$flags)))))))) + +(define guix-for-images + (mlambda (system) + (cond + ;; For testing purposes, use the guix package directly. + (%use-snapshot-package? guix) + ;; Normally, update the guix package to current commit. + (else + (guix-package/with-commit guix (guix-package-commit (current-guix))))))) + +(define %binary-tarball-compression "xz") + +;; Like guix pack -C xz -s --localstatedir --profile-name=current-guix guix +(define* (binary-tarball-for-system system #:key (extra-packages '())) + (let* ((base-name (string-append "guix-binary-" (%guix-version) "." system)) + (manifest (packages->manifest (cons* guix extra-packages))) + (profile (profile (content manifest))) + (inputs `(("profile" ,profile))) + (compression %binary-tarball-compression)) + (manifest-entry + (name (string-append base-name ".tar." compression)) + (version (%guix-version)) + (item (monadic->declarative + (self-contained-tarball + base-name profile + #:profile-name "current-guix" + #:compressor (lookup-compressor compression) + #:localstatedir? #t)))))) + +;; Like guix system image -t iso9660 \ +;; --label="GUIX_$${system}_$(VERSION)" gnu/system/install.scm +(define* (iso-for-system system) + (let* ((name (string-append + "guix-system-install-" (%guix-version) "." system ".iso")) + (base-os (make-installation-os + #:grub-displayed-version (%guix-version) + #:efi-only? (string=? system "aarch64-linux"))) + (base-image (os->image base-os #:type iso-image-type)) + (label (string-append "GUIX_" system "_" + (if (> (string-length (%guix-version)) 7) + (string-take (%guix-version) 7) + (%guix-version))))) + (manifest-entry + (name name) + (version (%guix-version)) + (item (system-image + (image-with-label + (image + (inherit base-image) + (name (string->symbol name))) + label)))))) + +;; Like guix system image -t qcow2 gnu/system/examples/vm-image.tmpl +(define* (qcow2-for-system system) + (let* ((name (string-append + "guix-system-vm-image-" (%guix-version) "." system ".qcow2")) + (base-os-path + (if (qcow2-gpt-for-system? system) + (%vm-image-efi-path) + (%vm-image-path))) + (target-image-type + (if (qcow2-gpt-for-system? system) + qcow2-gpt-image-type + qcow2-image-type)) + (base-os + (operating-system-with-/etc/config.scm + (operating-system-with-simple-provenance + (load base-os-path) base-os-path))) + (base-image (os->image base-os #:type target-image-type))) + (manifest-entry + (name name) + (version (%guix-version)) + (item (system-image + (image + (inherit base-image) + (volatile-root? #f) + (name (string->symbol name)))))))) + +(define* (guix-source-tarball) + (let ((guix (package + (inherit guix) + (native-inputs + (modify-inputs (package-native-inputs guix) + ;; graphviz-minimal -> graphviz + (replace "graphviz" graphviz) + (append imagemagick) + (append perl)))))) + (manifest-entry + (name (string-append "guix-" (%guix-version) ".tar.gz")) + (version (package-version guix)) + (item (dist-package + guix + ;; Guix is built from git source, not from tarball. + ;; So it's fine to use its source directly. + (package-source guix)))))) + +(define* (manifest-entry-with-parameters system entry + #:key + (guix-for-images-proc guix-for-images)) + (manifest-entry + (inherit entry) + (item + (with-parameters + ((%current-system system) + (%current-target-system #f) + (current-guix-package (guix-for-images-proc system))) + (manifest-entry-item entry))))) + +(define* (manifest-with-parameters system manifest + #:key + (guix-for-images-proc guix-for-images)) + "Returns entries in the manifest accompanied with %current-system, +%current-target-sytem and current-guix-package parameters." + (make-manifest + (map (cut manifest-entry-with-parameters system <> + #:guix-for-images-proc guix-for-images-proc) + (manifest-entries manifest)))) + +(define (artifacts-for-system/nonparameterized system) + "Get all artifacts for given system. This will always include the +guix-binary tarball and optionally iso and/or qcow2 images." + (manifest + (append + (list + (binary-tarball-for-system system)) + ;; TODO: After source tarball generation is ready, uncomment. + ;; (if (source-tarball-for-system? system) + ;; (list (guix-source-tarball)) + ;; '()) + (if (iso-for-system? system) + (list (iso-for-system system)) + '()) + (if (qcow2-for-system? system) + (list (qcow2-for-system system)) + '())))) + +(define* (artifacts-for-system system + #:key + (guix-for-images-proc guix-for-images)) + "Collects all artifacts for a system. Gives them the proper %current-system +and %current-target-system parameters, so the --system passed on CLI is +irrelevant." + ;; NOTE: parameterizing current system, because the tarball seems to somehow + ;; depend on it early on. I haven't investigated it, but seems like a bug. Could + ;; it be the gexp->derivation + monadic->declarative, not passing down the + ;; system? Symptom: guix build --system=x86_64 -m artifacts-manifest.scm and + ;; guix build --system=i686-linux -m artifacts-manifest.scm gives out different + ;; results without the parameterization. + (parameterize + ((%current-system system) + (%current-target-system #f) + (current-guix-package (guix-for-images-proc system))) + (manifest-with-parameters + system + (artifacts-for-system/nonparameterized system) + #:guix-for-images-proc guix-for-images-proc))) + +(define (manifest->union manifest) + "Makes a union that will be a folder with all the entries symlinked. This +is different from a profile as it expects the entries are just simple files +and symlinks them by their manifest-entry-name." + (let ((entries (manifest-entries manifest))) + (computed-file + "artifacts-union" + (with-imported-modules '((guix build union) + (guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (mkdir-p #$output) + + (for-each + (lambda* (entry) + (symlink (cdr entry) + (string-append #$output "/" (car entry)))) + (list #$@(map (lambda (entry) + #~(cons + #$(manifest-entry-name entry) + #$(manifest-entry-item entry))) + entries)))))))) + +(define %supported-systems + (or (and + (getenv "SUPPORTED_SYSTEMS") + (string-split (getenv "SUPPORTED_SYSTEMS") #\ )) + '("x86_64-linux" "i686-linux" + "armhf-linux" "aarch64-linux" + "powerpc64le-linux" "riscv64-linux"))) + +(define supported-systems-union-manifest + (concatenate-manifests + (map artifacts-for-system + %supported-systems))) + +(when %use-snapshot-package? + (warning (G_ "building images using the 'guix' package (snapshot)~%"))) +(info (G_ "producing artifacts for the following systems: ~a~%") + %supported-systems) +supported-systems-union-manifest diff --git a/etc/teams/release/artifacts.scm b/etc/teams/release/artifacts.scm new file mode 100644 index 0000000000..095df709de --- /dev/null +++ b/etc/teams/release/artifacts.scm @@ -0,0 +1,26 @@ +;;; GNU Guix --- Functional package management for GNU +;;; +;;; 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/>. + +;;; Produce a single directory with all the artifacts inside of it, with proper +;;; names. They can then be easily copied to releasedir in Makefile. The files are +;;; symlinked to save space, but they should be copied out of the store as regular +;;; files. + +(load "artifacts-manifest.scm") + +(manifest->union + supported-systems-union-manifest)
