M Makefile.am => Makefile.am +29 -45
@@ 1142,12 1142,18 @@ system_flags = $(foreach system,$(1),-s $(system))
# 5. Build the installation and VM images. The images will run 'guix'
# corresponding to 'vX.Y.Z' + 1 commit, and they will install 'vX.Y.Z'.
#
-# This 'release' target takes care of everything and copies the resulting
-# files to $(releasedir).
+# This is split into two targets, because a commit is made that has to be
+# pushed to Guix.
+# First, 'prepare-release' should be run, doing steps 1 and 2.
+# Then, the resulting commit should be pushed so that it's available
+# to be downloaded for the system images.
+# Afterwards, the 'release' target takes care of the rest. This 'release'
+# target takes care of everything and copies the resulting files to
+# $(releasedir).
#
# XXX: Depend on 'dist' rather than 'distcheck' to work around the Gettext
# issue described at <https://savannah.gnu.org/bugs/index.php?51027>.
-release: dist-with-updated-version all
+prepare-release: dist-with-updated-version all
@if ! git diff-index --quiet HEAD; then \
echo "There are uncommitted changes; stopping." >&2 ; \
exit 1 ; \
@@ 1165,48 1171,26 @@ release: dist-with-updated-version all
$(top_builddir)/pre-inst-env guix build guix \
$(call system_flags,$(SUPPORTED_SYSTEMS)) \
-v1 --no-grafts --fallback
-# 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
+
+ @echo
+ @echo "First step done! Source tarball is ready in $(releasedir)"
+ @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
+# 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
M doc/guix.texi => doc/guix.texi +15 -2
@@ 47841,7 47841,9 @@ machine. The @code{grub-bootloader} bootloader is always used
independently of what is declared in the @code{operating-system} file
passed as argument. This is to make it easier to work with QEMU, which
uses the SeaBIOS BIOS by default, expecting a bootloader to be installed
-in the Master Boot Record (MBR).
+in the Master Boot Record (MBR). In case the virtual machine is
+going to be AArch64, you might want to take a look at @code{qcow2-gpt}
+image type that installs bootloader only in EFI.
@cindex docker-image, creating docker images
When using the @code{docker} image type, a Docker image is produced.
@@ 54765,7 54767,18 @@ Build an image based on the @code{efi32-disk-image} image.
@defvar qcow2-image-type
Build an image based on the @code{mbr-disk-image} image but with the
-@code{compressed-qcow2} image format.
+@code{compressed-qcow2} image format. The resulting image will have
+an MBR embedded bootloader as well as an EFI bootloader. This image
+is not suitable for architectures that do not support `grub-pc`,
+such as AArch64. See @code{qcow2-gpt-image-type} for an alternative.
+@end defvar
+
+@defvar qcow2-gpt-image-type
+Build an image based on the @code{efi-disk-image} image but with the
+@code{compressed-qcow2} image format. The resulting image will have
+only EFI bootloader, unlike @code{qcow2-image-type}. This image
+is suitable for architectures that do not support `grub-pc`, such
+as AArch64.
@end defvar
@defvar iso-image-type
M etc/manifests/cross-compile.scm => etc/manifests/cross-compile.scm +9 -5
@@ 71,18 71,21 @@ TARGET."
"connman" "network-manager" "wpa-supplicant" "isc-dhcp" "cups"
"linux-libre" "grub-hybrid")))
-(define %system-gui-packages
+(define (%system-gui-packages target)
;; Key packages proposed by the Guix System installer.
(append (map specification->package
'(;; build system `python' does not support cross builds
- ;"gnome" "xfce" "mate" "openbox"
+ ;"gnome" "xfce" "mate" "openbox"
"awesome"
"i3-wm" "i3status" "dmenu" "st"
"ratpoison" "xterm"
;; build system `emacs' does not support cross builds
- ;"emacs-exwm" "emacs-desktop-environment"
+ ;"emacs-exwm" "emacs-desktop-environment"
"emacs"))
- %default-xorg-modules))
+ ;; NOTE: %default-xorg-modules depends on system.
+ (parameterize
+ ((%current-target-system target))
+ %default-xorg-modules)))
(define %packages-to-cross-build
;; Packages that must be cross-buildable from x86_64-linux.
@@ 151,7 154,8 @@ TARGET."
;; With a graphical environment:
(if (or (target-x86-32? target)
(target-aarch64? target))
- %system-gui-packages
+ ;; %system-gui-packages depends on the system.
+ (%system-gui-packages target)
'()))))
(fold delete (map platform-system->target (systems))
'(;; Disable cross-compilation to self:
A etc/teams/release/artifacts-manifest.scm => etc/teams/release/artifacts-manifest.scm +412 -0
@@ 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
A etc/teams/release/artifacts.scm => etc/teams/release/artifacts.scm +26 -0
@@ 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)
M gnu/build/image.scm => gnu/build/image.scm +5 -1
@@ 428,7 428,11 @@ GRUB configuration and OS-DRV as the stuff in it."
"-not" "-wholename" "/System/*"
"-not" "-name" "unicode.pf2"
"-not" "-name" "bzImage"
- "-not" "-name" "*.gz" ; initrd & all man pages
+ "-not" "-name" "zImage"
+ "-not" "-name" "Image"
+ "-not" "-name" "vmlinuz"
+ "-not" "-name" "*.gz" ; initrd
+ "-not" "-name" "*.zst" ; all man pages
"-not" "-name" "*.png" ; includes grub-image.png
"-exec" "set_filter" "--zisofs"
"--")
M gnu/installer.scm => gnu/installer.scm +6 -7
@@ 367,14 367,13 @@ purposes."
'unknown)
((channels ...)
(map (lambda (channel)
- (let* ((uri (string->uri (channel-url channel)))
- (url (if (or (not uri) (eq? 'file (uri-scheme uri)))
- "local checkout"
- (channel-url channel))))
- `(channel ,(channel-name channel) ,url ,(channel-commit channel))))
+ ;; NOTE: URL is not logged to synchronize the derivations
+ ;; coming out of pre-inst-env, time-machine and Cuirass
+ ;; for generating release artifacts.
+ `(channel ,(channel-name channel) ,(channel-commit channel)))
channels))))
-(define* (installer-program #:key dry-run?)
+(define* (installer-program #:key dry-run? (guix-for-installer (current-guix)))
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
;; Initialize gettext support, so that installer messages can be
@@ 423,7 422,7 @@ purposes."
guile-gnutls
guile-zlib ;for (gnu build linux-modules)
guile-zstd ;for (gnu build linux-modules)
- (current-guix))
+ guix-for-installer)
(with-imported-modules `(,@(source-module-closure
`(,@modules
(gnu services herd)
M gnu/packages/package-management.scm => gnu/packages/package-management.scm +7 -8
@@ 197,9 197,9 @@
;; Latest version of Guix, which may or may not correspond to a release.
;; Note: the 'update-guix-package.scm' script expects this definition to
;; start precisely like this.
- (let ((version "1.4.0")
- (commit "21ce6b392ace4c4d22543abc41bd7c22596cd6d2")
- (revision 47))
+ (let ((version "1.5.0rc1")
+ (commit "2d4ed08662714ea46cfe0b41ca195d1ef845fd1b")
+ (revision 0))
(package
(name "guix")
@@ 215,7 215,7 @@
(commit commit)))
(sha256
(base32
- "0q4f5aiqld1smjmq0k0y96wrrvn7pizsx8xzqk6m7f9f2qm7pdhc"))
+ "0z1ixlkzsaj978nh57179871xkzbf8zsf10xkcfs2647iznkx7az"))
(file-name (string-append "guix-" version "-checkout"))))
(build-system gnu-build-system)
(arguments
@@ 234,10 234,9 @@
(string-append "--with-bash-completion-dir="
(assoc-ref %outputs "out")
"/etc/bash_completion.d")
- ;; TODO: Uncomment after guix is updated.
- ;; (string-append "--with-apparmor-profile-dir="
- ;; (assoc-ref %outputs "out")
- ;; "/etc/apparmor.d")
+ (string-append "--with-apparmor-profile-dir="
+ (assoc-ref %outputs "out")
+ "/etc/apparmor.d")
;; Set 'DOT_USER_PROGRAM' to the empty string so
;; we don't keep a reference to Graphviz, whose
M gnu/services/xorg.scm => gnu/services/xorg.scm +31 -19
@@ 64,6 64,7 @@
#:use-module ((guix modules) #:select (source-module-closure))
#:use-module (guix packages)
#:use-module (guix derivations)
+ #:use-module (guix platform)
#:use-module (guix records)
#:use-module (guix deprecation)
#:use-module (guix utils)
@@ 148,25 149,36 @@
;;;
;;; Code:
-(define %default-xorg-modules
- ;; Default list of modules loaded by the server. When multiple drivers
- ;; match, the first one in the list is loaded.
- (list xf86-video-vesa
- xf86-video-fbdev
- xf86-video-amdgpu
- xf86-video-ati
- xf86-video-cirrus
- xf86-video-intel
- xf86-video-mach64
- xf86-video-nouveau
- xf86-video-nv
- xf86-video-sis
-
- ;; Libinput is the new thing and is recommended over evdev/synaptics:
- ;; <http://who-t.blogspot.fr/2015/01/xf86-input-libinput-compatibility-with.html>.
- xf86-input-libinput
- xf86-input-evdev
- xf86-input-mouse))
+(define* (default-xorg-modules
+ #:optional
+ (system (or (and=>
+ (%current-target-system)
+ platform-target->system)
+ (%current-system))))
+ "Default list of modules loaded by the server. When multiple drivers match,
+the first one in the list is loaded."
+ ;; Return only supported packages, because some aren't supported
+ ;; on all architectures.
+ (filter (cut supported-package? <> system)
+ (list xf86-video-vesa
+ xf86-video-fbdev
+ xf86-video-amdgpu
+ xf86-video-ati
+ xf86-video-cirrus
+ xf86-video-intel
+ xf86-video-mach64
+ xf86-video-nouveau
+ xf86-video-nv
+ xf86-video-sis
+
+ ;; Libinput is the new thing and is recommended over evdev/synaptics:
+ ;; <http://who-t.blogspot.fr/2015/01/xf86-input-libinput-compatibility-with.html>.
+ xf86-input-libinput
+ xf86-input-evdev
+ xf86-input-mouse)))
+
+(define-syntax %default-xorg-modules
+ (identifier-syntax (default-xorg-modules)))
(define %default-xorg-fonts
;; Default list of fonts available to the X server.
A gnu/system/examples/vm-image-efi.tmpl => gnu/system/examples/vm-image-efi.tmpl +145 -0
@@ 0,0 1,145 @@
+;; -*- mode: scheme; -*-
+;; This is an operating system configuration for a VM image.
+;; Modify it as you see fit and instantiate the changes by running:
+;;
+;; guix system reconfigure /etc/config.scm
+;;
+
+(use-modules (gnu)
+ (guix)
+ (srfi srfi-1)
+ (ice-9 match)
+ (guix channels)
+ (gnu system image))
+(use-service-modules desktop mcron networking spice ssh xorg sddm)
+(use-package-modules bootloaders fonts
+ package-management xdisorg xorg)
+
+(define vm-image-motd (plain-file "motd" "
+\x1b[1;37mThis is the GNU system. Welcome!\x1b[0m
+
+This instance of Guix is a template for virtualized environments.
+You can reconfigure the whole system by adjusting /etc/config.scm
+and running:
+
+ guix system reconfigure /etc/config.scm
+
+Run '\x1b[1;37minfo guix\x1b[0m' to browse documentation.
+
+\x1b[1;33mConsider setting a password for the 'root' and 'guest' \
+accounts.\x1b[0m
+"))
+
+(operating-system
+ (host-name "gnu")
+ (timezone "Etc/UTC")
+ (locale "en_US.utf8")
+ (keyboard-layout (keyboard-layout "us" "altgr-intl"))
+
+ ;; Label for the GRUB boot menu.
+ (label (string-append "GNU Guix "
+ (or (getenv "GUIX_DISPLAYED_VERSION")
+ (package-version guix))))
+
+ (firmware '())
+
+ ;; On AArch64, support SCSI CDROMs and HDs.
+ (initrd-modules (cons* "sd_mod" "sr_mod"
+ %base-initrd-modules))
+
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ (targets '("/boot/efi"))
+ (terminal-outputs '(console))))
+ (file-systems (cons* (file-system
+ (mount-point "/")
+ (device (file-system-label root-label))
+ (type "ext4"))
+ (file-system
+ (mount-point "/boot/efi")
+ (device (file-system-label "GNU-ESP"))
+ (type "vfat"))
+ %base-file-systems))
+
+ (users (cons (user-account
+ (name "guest")
+ (comment "GNU Guix Live")
+ (password "") ;no password
+ (group "users")
+ (supplementary-groups '("wheel" "netdev"
+ "audio" "video")))
+ %base-user-accounts))
+
+ ;; Our /etc/sudoers file. Since 'guest' initially has an empty password,
+ ;; allow for password-less sudo.
+ (sudoers-file (plain-file "sudoers" "\
+root ALL=(ALL) ALL
+%wheel ALL=NOPASSWD: ALL\n"))
+
+ (pam-services
+ ;; Explicitly allow for empty passwords.
+ (base-pam-services #:allow-empty-passwords? #t))
+
+ (packages
+ (append (list font-bitstream-vera
+ ;; Auto-started script providing SPICE dynamic resizing for
+ ;; Xfce (see:
+ ;; https://gitlab.xfce.org/xfce/xfce4-settings/-/issues/142).
+ x-resize)
+ %base-packages))
+
+ (services
+ (append (list (service xfce-desktop-service-type)
+
+ ;; Choose SLiM, which is lighter than the default GDM.
+ (service slim-service-type
+ (slim-configuration
+ (auto-login? #t)
+ (default-user "guest")
+ (xorg-configuration
+ (xorg-configuration
+ ;; The QXL virtual GPU driver is added to provide
+ ;; a better SPICE experience.
+ (modules (cons xf86-video-qxl
+ %default-xorg-modules))
+ (keyboard-layout keyboard-layout)))))
+
+ ;; Uncomment the line below to add an SSH server.
+ ;;(service openssh-service-type)
+
+ ;; Add support for the SPICE protocol, which enables dynamic
+ ;; resizing of the guest screen resolution, clipboard
+ ;; integration with the host, etc.
+ (service spice-vdagent-service-type)
+
+ ;; Use the DHCP client service rather than NetworkManager.
+ (service dhcpcd-service-type))
+
+ ;; Remove some services that don't make sense in a VM.
+ (remove (lambda (service)
+ (let ((type (service-kind service)))
+ (or (memq type
+ (list gdm-service-type
+ sddm-service-type
+ wpa-supplicant-service-type
+ cups-pk-helper-service-type
+ network-manager-service-type
+ modem-manager-service-type))
+ (eq? 'network-manager-applet
+ (service-type-name type)))))
+ (modify-services %desktop-services
+ (login-service-type config =>
+ (login-configuration
+ (inherit config)
+ (motd vm-image-motd)))
+
+ ;; Install and run the current Guix rather than an older
+ ;; snapshot.
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (guix (current-guix))))))))
+
+ ;; Allow resolution of '.local' host names with mDNS.
+ (name-service-switch %mdns-host-lookup-nss))
M gnu/system/examples/vm-image.tmpl => gnu/system/examples/vm-image.tmpl +2 -17
@@ 10,6 10,7 @@
(srfi srfi-1)
(ice-9 match)
(guix channels)
+ (gnu packages package-management)
(gnu system image))
(use-service-modules desktop mcron networking spice ssh xorg sddm)
(use-package-modules bootloaders fonts
@@ 30,15 31,6 @@ Run '\x1b[1;37minfo guix\x1b[0m' to browse documentation.
accounts.\x1b[0m
"))
-(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)))))
-
(operating-system
(host-name "gnu")
(timezone "Etc/UTC")
@@ 141,14 133,7 @@ root ALL=(ALL) ALL
(guix-service-type config =>
(guix-configuration
(inherit config)
- (guix
- (let ((guix (current-guix)))
- (package
- (inherit guix)
- ;; Do not leak the local checkout URL.
- (source (channel
- (inherit %default-guix-channel)
- (commit (guix-package-commit guix)))))))))))))
+ (guix (current-guix))))))))
;; Allow resolution of '.local' host names with mDNS.
(name-service-switch %mdns-host-lookup-nss))
M gnu/system/image.scm => gnu/system/image.scm +66 -19
@@ 98,6 98,7 @@
efi-raw-image-type
efi32-raw-image-type
qcow2-image-type
+ qcow2-gpt-image-type
iso-image-type
uncompressed-iso-image-type
docker-image-type
@@ 265,6 266,16 @@ set to the given OS."
(format 'compressed-qcow2))
<>))))
+(define qcow2-gpt-image-type
+ (image-type
+ (name 'qcow2-gpt)
+ (constructor (cut image-with-os
+ (image
+ (inherit efi-disk-image)
+ (name 'image.qcow2)
+ (format 'compressed-qcow2))
+ <>))))
+
(define iso-image-type
(image-type
(name 'iso9660)
@@ 352,16 363,27 @@ set to the given OS."
(guix build utils))
gexp* ...))))
+(define (partition-has-flag? partition flag)
+ "Return true if PARTITION's flags include FLAG."
+ (member flag (partition-flags partition)))
+
+(define (find-partition-with-flag image flag)
+ "Return partition of the given IMAGE that has FLAG, or #f if not found."
+ (srfi-1:find (cut partition-has-flag? <> flag)
+ (image-partitions image)))
+
(define (root-partition? partition)
"Return true if PARTITION is the root partition, false otherwise."
- (member 'boot (partition-flags partition)))
+ (partition-has-flag? partition 'boot))
(define (find-root-partition image)
- "Return the root partition of the given IMAGE."
- (or (srfi-1:find root-partition? (image-partitions image))
+ (or (find-partition-with-flag image 'boot)
(raise (formatted-message
(G_ "image lacks a partition with the 'boot' flag")))))
+(define (find-esp-partition image)
+ (find-partition-with-flag image 'esp))
+
(define (root-partition-index image)
"Return the index of the root partition of the given IMAGE."
(1+ (srfi-1:list-index root-partition? (image-partitions image))))
@@ 652,6 674,10 @@ used in the image. "
(uuid-bytevector (partition-uuid partition)))))
(let* ((os (image-operating-system image))
+ (image-name (image-name image))
+ (name (if image-name
+ (symbol->string image-name)
+ name))
(bootloader (bootloader-package bootloader))
(compression? (image-compression? image))
(substitutable? (image-substitutable? image))
@@ 969,6 995,19 @@ it can be used for bootloading."
(let* ((root-file-system-type (image->root-file-system image))
(base-os (image-operating-system image))
+ (esp-partition (find-esp-partition image))
+ ;; In case the user has added /boot/efi file-system,
+ ;; try to respect it and add a file-system pointing
+ ;; to the correct esp.
+ (wants-boot-efi? (and
+ (srfi-1:any
+ (lambda (fs)
+ (let ((mount-point (file-system-mount-point fs)))
+ (string=? mount-point "/boot/efi")))
+ (operating-system-file-systems base-os))
+ esp-partition))
+ ;; Replace root file system with one with proper UUID that the
+ ;; target image will have. Similarly for /boot/efi.
(file-systems-to-keep
(srfi-1:remove
(lambda (fs)
@@ 985,24 1024,32 @@ it can be used for bootloading."
file-systems
#:volatile-root? volatile-root?
rest)))
- (bootloader (if (eq? format 'iso9660)
+ ;; Only replace with grub-mkrescue-bootloader if grub-pc
+ ;; is supported. AArch64 doesn't support it. In such
+ ;; cases, respect bootloader of the system. Still,
+ ;; for now make-iso9660-image installs only GRUB.
+ (bootloader (if (and (eq? format 'iso9660)
+ (supported-package? grub-hybrid))
(bootloader-configuration
- (inherit
- (operating-system-bootloader base-os))
- (bootloader grub-mkrescue-bootloader))
- (operating-system-bootloader base-os)))
- (file-systems (cons (file-system
- (mount-point "/")
- (device "/dev/placeholder")
- (type root-file-system-type))
- file-systems-to-keep))))
+ (inherit
+ (operating-system-bootloader base-os))
+ (bootloader grub-mkrescue-bootloader))
+ (operating-system-bootloader base-os)))))
(uuid (root-uuid os)))
- (operating-system
- (inherit os)
- (file-systems (cons (file-system
- (mount-point "/")
- (device uuid)
- (type root-file-system-type))
+ (operating-system
+ (inherit os)
+ (file-systems (append
+ (list (file-system
+ (mount-point "/")
+ (device uuid)
+ (type root-file-system-type)))
+ (if wants-boot-efi?
+ (list (file-system
+ (mount-point "/boot/efi")
+ (type "vfat")
+ (device (file-system-label
+ (partition-label esp-partition)))))
+ '())
file-systems-to-keep)))))
(define* (system-image image)
M gnu/system/install.scm => gnu/system/install.scm +76 -47
@@ 28,6 28,7 @@
#:use-module (gnu)
#:use-module (gnu system)
#:use-module (gnu system privilege)
+ #:use-module (gnu bootloader)
#:use-module (gnu bootloader u-boot)
#:use-module (guix gexp)
#:use-module (guix store)
@@ 64,6 65,7 @@
#:use-module (gnu packages xorg)
#:use-module (ice-9 match)
#:export (installation-os
+ make-installation-os
a20-olinuxino-lime-installation-os
a20-olinuxino-lime2-emmc-installation-os
a20-olinuxino-micro-installation-os
@@ 334,10 336,13 @@ templates under @file{/etc/configuration}.")))
"Load the @code{uvesafb} kernel module with the right options.")
(default-value #t)))
-(define* (%installation-services #:key (system (or (and=>
- (%current-target-system)
- platform-target->system)
- (%current-system))))
+(define* (%installation-services
+ #:key
+ (system (or (and=>
+ (%current-target-system)
+ platform-target->system)
+ (%current-system)))
+ (guix-for-system (current-guix)))
;; List of services of the installation system.
(let ((motd (plain-file "motd" "
\x1b[1;37mWelcome to the installation of GNU Guix!\x1b[0m
@@ 355,15 360,6 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
(define bare-bones-os
(load "examples/bare-bones.tmpl"))
- (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)))))
-
(append
;; Generic services
(list (service virtual-terminal-service-type)
@@ 371,7 367,8 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
(service kmscon-service-type
(kmscon-configuration
(virtual-terminal "tty1")
- (login-program (installer-program))))
+ (login-program (installer-program
+ #:guix-for-installer guix-for-system))))
(service login-service-type
(login-configuration
@@ 408,13 405,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
;; Install and run the current Guix rather than an older
;; snapshot.
- (guix (let ((guix (current-guix)))
- (package
- (inherit guix)
- ;; Do not leak the local checkout URL.
- (source (channel
- (inherit %default-guix-channel)
- (commit (guix-package-commit guix)))))))))
+ (guix guix-for-system)))
;; Start udev so that useful device nodes are available.
;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
@@ 525,19 516,52 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
jfsutils
xfsprogs))
-(define installation-os
+(define* (%installation-initrd-modules
+ #:key
+ (system (or (and=>
+ (%current-target-system)
+ platform-target->system)
+ (%current-system))))
+ ;; AArch64 currently lacks a lot of modules necessary
+ ;; for booting from USB sticks, hard disks or
+ ;; CDROMs. Those are built-in in x86_64 kernel.
+ `(,@(if (target-aarch64? system)
+ '("sr_mod" "sd_mod"
+ "usb_common" "usbcore"
+ ;; USB 3.0
+ "xhci_pci" "xhci_hcd"
+ ;; embedded USB 3.0
+ "xhci_plat_hcd"
+ ;; USB 2.0
+ "ehci_pci" "ehci_hcd")
+ '())
+ ,@%base-initrd-modules))
+
+(define* (make-installation-os #:key
+ ;; Version displayed in the GRUB entry name.
+ (grub-displayed-version
+ (package-version guix))
+ ;; Whether to use efi-only installation.
+ ;; When #f, use hybrid grub that sets up
+ ;; both legacy boot and efi.
+ (efi-only? #f))
;; The operating system used on installation images for USB sticks etc.
(operating-system
(host-name "gnu")
(timezone "Europe/Paris")
(locale "en_US.utf8")
(name-service-switch %mdns-host-lookup-nss)
- (bootloader (bootloader-configuration
- (bootloader grub-bootloader)
- (targets '("/dev/sda"))))
- (label (string-append "GNU Guix installation "
- (or (getenv "GUIX_DISPLAYED_VERSION")
- (package-version guix))))
+
+ (initrd-modules (%installation-initrd-modules))
+
+ (bootloader (if efi-only?
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ (targets '("/boot/efi")))
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets '("/dev/sda")))))
+ (label (string-append "GNU Guix installation " grub-displayed-version))
;; XXX: The AMD Radeon driver is reportedly broken, which makes kmscon
;; non-functional:
@@ 550,19 574,19 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
;; the appropriate one.
(append %base-live-file-systems
- ;; XXX: This should be %BASE-FILE-SYSTEMS but we don't need
- ;; elogind's cgroup file systems.
- (list %pseudo-terminal-file-system
- %shared-memory-file-system
- %efivars-file-system
- %immutable-store)))
+ ;; XXX: This should be %BASE-FILE-SYSTEMS but we don't need
+ ;; elogind's cgroup file systems.
+ (list %pseudo-terminal-file-system
+ %shared-memory-file-system
+ %efivars-file-system
+ %immutable-store)))
(users (list (user-account
- (name "guest")
- (group "users")
- (supplementary-groups '("wheel")) ; allow use of sudo
- (password "")
- (comment "Guest of GNU"))))
+ (name "guest")
+ (group "users")
+ (supplementary-groups '("wheel")) ; allow use of sudo
+ (password "")
+ (comment "Guest of GNU"))))
(issue %issue)
(services (%installation-services))
@@ 570,20 594,25 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
;; We don't need setuid programs, except for 'passwd', which can be handy
;; if one is to allow remote SSH login to the machine being installed.
(privileged-programs (list (privileged-program
- (program (file-append shadow "/bin/passwd"))
- (setuid? #t))))
+ (program (file-append shadow "/bin/passwd"))
+ (setuid? #t))))
(pam-services
;; Explicitly allow for empty passwords.
(base-pam-services #:allow-empty-passwords? #t))
(packages (append
- (list glibc ; for 'tzselect' & co.
- fontconfig
- font-dejavu font-gnu-unifont
- grub) ; mostly so xrefs to its manual work
- %installer-disk-utilities
- %base-packages))))
+ (list glibc ; for 'tzselect' & co.
+ fontconfig
+ font-dejavu font-gnu-unifont
+
+ ;; Mostly so xrefs to its manual work.
+ (bootloader-package
+ (bootloader-configuration-bootloader bootloader)))
+ %installer-disk-utilities
+ %base-packages))))
+
+(define installation-os (make-installation-os))
(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")
(triplet "arm-linux-gnueabihf"))
M gnu/system/linux-initrd.scm => gnu/system/linux-initrd.scm +1 -1
@@ 366,7 366,7 @@ FILE-SYSTEMS."
(define virtio-modules
;; Modules for Linux para-virtualized devices, for use in QEMU guests.
'("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
- "virtio_console" "virtio-rng"))
+ "virtio_console" "virtio-rng" "virtio_mmio" "virtio_scsi"))
`("ahci" ;for SATA controllers
"usb-storage" "uas" ;for the installation image etc.