gnu: commencement: mes-boot: Use new package style.

* gnu/packages/commencement.scm (mes-boot)[arguments]: Use gexp for modify
phases.

.dir-locals.el

@@ -6,29 +6,15 @@
      (sentence-end-double-space . t)
 
      ;; For use with 'bug-reference-prog-mode'.
+     (bug-reference-url-format . "http://bugs.gnu.org/%s")
      (bug-reference-bug-regexp
-      . "\\(<https?://\\bugs\\.gnu\\.org/\\([0-9]+\\)>\\)")
-     (bug-reference-url-format . "https://bugs.gnu.org/%s")
-
-     (eval . (add-to-list 'completion-ignored-extensions ".go"))
+      . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")
 
      ;; Emacs-Guix
      (eval . (setq-local guix-directory
                          (locate-dominating-file default-directory
                                                  ".dir-locals.el")))
 
-     ;; YASnippet
-     (eval . (with-eval-after-load
-                 'yasnippet
-               (let ((guix-yasnippets
-                      (expand-file-name
-                       "etc/snippets/yas"
-                       (locate-dominating-file default-directory
-                                               ".dir-locals.el"))))
-                 (unless (member guix-yasnippets yas-snippet-dirs)
-                   (add-to-list 'yas-snippet-dirs guix-yasnippets)
-                   (yas-reload-all)))))
-
      ;; Geiser
      ;; This allows automatically setting the `geiser-guile-load-path'
      ;; variable when using various Guix checkouts (e.g., via git worktrees).
@@ -132,11 +118,9 @@
    (eval . (put 'munless 'scheme-indent-function 1))
    (eval . (put 'mlet* 'scheme-indent-function 2))
    (eval . (put 'mlet 'scheme-indent-function 2))
-   (eval . (put 'mparameterize 'scheme-indent-function 2))
    (eval . (put 'run-with-store 'scheme-indent-function 1))
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
-   (eval . (put 'wrap-script 'scheme-indent-function 1))
    (eval . (put 'with-imported-modules 'scheme-indent-function 1))
    (eval . (put 'with-extensions 'scheme-indent-function 1))
    (eval . (put 'with-parameters 'scheme-indent-function 1))
@@ -171,31 +155,7 @@
    ;; preceding symbol is one of these.
    (eval . (modify-syntax-entry ?~ "'"))
    (eval . (modify-syntax-entry ?$ "'"))
-   (eval . (modify-syntax-entry ?+ "'"))
-
-   ;; Emacs 28 changed the behavior of 'lisp-fill-paragraph', which causes the
-   ;; first line of package descriptions to extrude past 'fill-column', and
-   ;; somehow that is deemed more correct upstream (see:
-   ;; https://issues.guix.gnu.org/56197).
-   (eval . (progn
-             (require 'lisp-mode)
-             (defun emacs27-lisp-fill-paragraph (&optional justify)
-               (interactive "P")
-               (or (fill-comment-paragraph justify)
-                   (let ((paragraph-start
-                          (concat paragraph-start
-                                  "\\|\\s-*\\([(;\"]\\|\\s-:\\|`(\\|#'(\\)"))
-                         (paragraph-separate
-                          (concat paragraph-separate "\\|\\s-*\".*[,\\.]$"))
-                         (fill-column (if (and (integerp emacs-lisp-docstring-fill-column)
-                                               (derived-mode-p 'emacs-lisp-mode))
-                                          emacs-lisp-docstring-fill-column
-                                        fill-column)))
-                     (fill-paragraph justify))
-                   ;; Never return nil.
-                   t))
-             (setq-local fill-paragraph-function #'emacs27-lisp-fill-paragraph)))))
-
+   (eval . (modify-syntax-entry ?+ "'"))))
  (emacs-lisp-mode . ((indent-tabs-mode . nil)))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))

.editorconfig

@@ -1,16 +0,0 @@
-root = true
-
-[*.{c,h,cpp,hpp,el,scm,ac,am,m4,po}{,.in}]
-end_of_line = lf
-insert_final_newline = true
-charset = utf-8
-trim_trailing_whitespace = true
-
-[*.{c,h,cpp,hpp,ac,am,m4,el,scm}{,.in}]
-max_line_length = 85
-
-[*.{c,h,cpp,hpp,ac,m4,el,scm}{,.in}]
-indent_style = space
-
-[*.{c,h,cpp,hpp}{,.in}]
-indent_size = 4

.gitignore

@@ -68,7 +68,6 @@
 /doc/version.texi
 /doc/version-*.texi
 /etc/committer.scm
-/etc/teams.scm
 /etc/gnu-store.mount
 /etc/guix-daemon.cil
 /etc/guix-daemon.conf
@@ -158,4 +157,3 @@ tmp
 /gnu/packages/bootstrap
 /gnu/packages/aux-files/guile-guile-launcher.o
 /guile
-.DS_Store

.guix-authorizations

@@ -4,15 +4,12 @@
 (authorizations
  (version 0)
 
- (;; primary: "D963 A5A3 8A80 3D52 4461  F914 7483 0A27 6C32 8EC2"
-  ("2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"
-   (name "abcdw"))
+ (("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
+   (name "andreas"))
   ("4FB9 9F49 2B12 A365 7997  E664 8246 0C08 2A0E E98F"
    (name "alezost"))
   ("50F3 3E2E 5B0C 3D90 0424  ABE8 9BDC F497 A4BB CC7F"
    (name "ambrevar"))
-  ("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
-   (name "andreas"))
   ("27D5 86A4 F890 0854 329F  F09F 1260 E464 82E6 3562"
    (name "apteryx"))
   ("7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3"
@@ -35,8 +32,10 @@
   (;; primary: "295A F991 6F46 F8A1 34B0  29DA 8086 3842 F0FE D83B"
    "76CE C6B1 7274 B465 C02D  B3D9 E71A 3554 2C30 BAA5"
    (name "dannym"))
-  ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807"
-   (name "dthompson"))
+  ("B3C0 DB4D AD73 BA5D 285E  19AE 5143 0234 CEFD 87C3"
+   (name "davexunit"))
+  ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807" ;FIXME: to be confirmed!
+   (name "davexunit (2nd)"))
   ("A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351"
    (name "efraim"))
   (;; primary: "2453 02B1 BAB1 F867 FDCA  96BC 8F3F 861F 82EB 7A9A"

Makefile.am

@@ -97,6 +97,7 @@ MODULES =					\
   guix/discovery.scm				\
   guix/android-repo-download.scm		\
   guix/bzr-download.scm            		\
+  guix/extracting-download.scm			\
   guix/git-download.scm				\
   guix/hg-download.scm				\
   guix/hash.scm					\
@@ -129,30 +130,21 @@ MODULES =					\
   guix/cache.scm				\
   guix/cve.scm					\
   guix/workers.scm				\
-  guix/least-authority.scm			\
-  guix/read-print.scm				\
   guix/ipfs.scm					\
-  guix/platform.scm                             \
-  guix/platforms/arm.scm                        \
-  guix/platforms/mips.scm                       \
-  guix/platforms/powerpc.scm                    \
-  guix/platforms/riscv.scm                      \
-  guix/platforms/x86.scm                        \
   guix/build-system.scm				\
   guix/build-system/android-ndk.scm		\
   guix/build-system/ant.scm			\
   guix/build-system/cargo.scm			\
-  guix/build-system/channel.scm			\
   guix/build-system/chicken.scm			\
   guix/build-system/clojure.scm			\
   guix/build-system/cmake.scm			\
   guix/build-system/dub.scm			\
   guix/build-system/dune.scm			\
-  guix/build-system/elm.scm			\
   guix/build-system/emacs.scm			\
   guix/build-system/font.scm			\
   guix/build-system/go.scm			\
   guix/build-system/meson.scm			\
+  guix/build-system/mozilla.scm			\
   guix/build-system/minify.scm			\
   guix/build-system/minetest.scm		\
   guix/build-system/asdf.scm			\
@@ -166,7 +158,6 @@ MODULES =					\
   guix/build-system/maven.scm			\
   guix/build-system/node.scm			\
   guix/build-system/perl.scm			\
-  guix/build-system/pyproject.scm		\
   guix/build-system/python.scm			\
   guix/build-system/renpy.scm			\
   guix/build-system/ocaml.scm			\
@@ -174,7 +165,6 @@ MODULES =					\
   guix/build-system/waf.scm			\
   guix/build-system/r.scm			\
   guix/build-system/rakudo.scm			\
-  guix/build-system/rebar.scm			\
   guix/build-system/ruby.scm			\
   guix/build-system/scons.scm			\
   guix/build-system/texlive.scm			\
@@ -202,7 +192,6 @@ MODULES =					\
   guix/build/cmake-build-system.scm		\
   guix/build/dub-build-system.scm		\
   guix/build/dune-build-system.scm		\
-  guix/build/elm-build-system.scm		\
   guix/build/emacs-build-system.scm		\
   guix/build/meson-build-system.scm		\
   guix/build/minify-build-system.scm		\
@@ -223,14 +212,12 @@ MODULES =					\
   guix/build/minetest-build-system.scm		\
   guix/build/node-build-system.scm		\
   guix/build/perl-build-system.scm		\
-  guix/build/pyproject-build-system.scm		\
   guix/build/python-build-system.scm		\
   guix/build/ocaml-build-system.scm		\
   guix/build/qt-build-system.scm		\
   guix/build/r-build-system.scm			\
   guix/build/renpy-build-system.scm			\
   guix/build/rakudo-build-system.scm		\
-  guix/build/rebar-build-system.scm		\
   guix/build/ruby-build-system.scm		\
   guix/build/scons-build-system.scm		\
   guix/build/texlive-build-system.scm		\
@@ -270,7 +257,6 @@ MODULES =					\
   guix/import/cran.scm				\
   guix/import/crate.scm				\
   guix/import/egg.scm   			\
-  guix/import/elm.scm				\
   guix/import/elpa.scm   			\
   guix/import/gem.scm				\
   guix/import/git.scm                           \
@@ -279,7 +265,6 @@ MODULES =					\
   guix/import/gnu.scm				\
   guix/import/go.scm				\
   guix/import/hackage.scm			\
-  guix/import/hexpm.scm				\
   guix/import/json.scm				\
   guix/import/kde.scm				\
   guix/import/launchpad.scm   			\
@@ -314,24 +299,20 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/style.scm			\
   guix/scripts/system.scm			\
-  guix/scripts/system/edit.scm			\
-  guix/scripts/system/reconfigure.scm		\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/home.scm			\
-  guix/scripts/home/edit.scm			\
   guix/scripts/home/import.scm			\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
   guix/scripts/import/cran.scm			\
   guix/scripts/import/egg.scm   		\
-  guix/scripts/import/elm.scm			\
   guix/scripts/import/elpa.scm  		\
   guix/scripts/import/gem.scm			\
   guix/scripts/import/gnu.scm			\
   guix/scripts/import/go.scm			\
   guix/scripts/import/hackage.scm		\
-  guix/scripts/import/hexpm.scm			\
   guix/scripts/import/json.scm  		\
   guix/scripts/import/minetest.scm  		\
   guix/scripts/import/opam.scm			\
@@ -399,10 +380,10 @@ AUX_FILES =						\
   gnu/packages/aux-files/chromium/master-preferences.json		\
   gnu/packages/aux-files/emacs/guix-emacs.el		\
   gnu/packages/aux-files/guix.vim			\
-  gnu/packages/aux-files/linux-libre/6.0-arm.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-arm64.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-i686.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-x86_64.conf	\
+  gnu/packages/aux-files/linux-libre/5.16-arm.conf	\
+  gnu/packages/aux-files/linux-libre/5.16-arm64.conf	\
+  gnu/packages/aux-files/linux-libre/5.16-i686.conf	\
+  gnu/packages/aux-files/linux-libre/5.16-x86_64.conf	\
   gnu/packages/aux-files/linux-libre/5.15-arm.conf	\
   gnu/packages/aux-files/linux-libre/5.15-arm64.conf	\
   gnu/packages/aux-files/linux-libre/5.15-i686.conf	\
@@ -424,9 +405,10 @@ AUX_FILES =						\
   gnu/packages/aux-files/linux-libre/4.14-x86_64.conf	\
   gnu/packages/aux-files/linux-libre/4.9-i686.conf	\
   gnu/packages/aux-files/linux-libre/4.9-x86_64.conf	\
+  gnu/packages/aux-files/linux-libre/4.4-i686.conf	\
+  gnu/packages/aux-files/linux-libre/4.4-x86_64.conf	\
   gnu/packages/aux-files/pack-audit.c			\
   gnu/packages/aux-files/python/sanity-check.py		\
-  gnu/packages/aux-files/python/sanity-check-next.py	\
   gnu/packages/aux-files/python/sitecustomize.py	\
   gnu/packages/aux-files/renpy/renpy.in	\
   gnu/packages/aux-files/run-in-namespace.c
@@ -477,7 +459,6 @@ SCM_TESTS =					\
   tests/boot-parameters.scm			\
   tests/bournish.scm				\
   tests/builders.scm				\
-  tests/build-emacs-utils.scm			\
   tests/build-utils.scm			\
   tests/cache.scm				\
   tests/challenge.scm				\
@@ -493,7 +474,6 @@ SCM_TESTS =					\
   tests/derivations.scm			\
   tests/discovery.scm				\
   tests/egg.scm				\
-  tests/elm.scm				\
   tests/elpa.scm				\
   tests/file-systems.scm			\
   tests/gem.scm				\
@@ -507,7 +487,6 @@ SCM_TESTS =					\
   tests/gremlin.scm				\
   tests/hackage.scm				\
   tests/home-import.scm				\
-  tests/home-services.scm			\
   tests/http-client.scm				\
   tests/import-git.scm				\
   tests/import-github.scm			\
@@ -529,14 +508,12 @@ SCM_TESTS =					\
   tests/profiles.scm				\
   tests/publish.scm				\
   tests/pypi.scm				\
-  tests/read-print.scm				\
   tests/records.scm				\
   tests/scripts.scm				\
   tests/search-paths.scm			\
   tests/services.scm				\
   tests/services/file-sharing.scm		\
   tests/services/configuration.scm		\
-  tests/services/lightdm.scm			\
   tests/services/linux.scm			\
   tests/services/telephony.scm			\
   tests/sets.scm				\
@@ -585,7 +562,6 @@ SH_TESTS =					\
   tests/guix-package.sh				\
   tests/guix-package-aliases.sh			\
   tests/guix-package-net.sh			\
-  tests/guix-style.sh				\
   tests/guix-system.sh				\
   tests/guix-home.sh				\
   tests/guix-archive.sh				\
@@ -593,7 +569,6 @@ SH_TESTS =					\
   tests/guix-environment.sh			\
   tests/guix-environment-container.sh		\
   tests/guix-shell.sh				\
-  tests/guix-shell-export-manifest.sh		\
   tests/guix-graph.sh				\
   tests/guix-describe.sh			\
   tests/guix-repl.sh     			\
@@ -661,49 +636,48 @@ dist_fishcompletion_DATA = etc/completion/fish/guix.fish
 nodist_selinux_policy_DATA = etc/guix-daemon.cil
 
 EXTRA_DIST +=						\
-  .dir-locals.el					\
-  .guix-authorizations					\
-  .guix-channel						\
-  CODE-OF-CONDUCT					\
   HACKING						\
   ROADMAP						\
   TODO							\
-  bootstrap						\
-  build-aux/build-self.scm				\
-  build-aux/check-channel-news.scm			\
-  build-aux/check-final-inputs-self-contained.scm	\
-  build-aux/compile-all.scm				\
-  build-aux/compile-as-derivation.scm			\
-  build-aux/config.rpath				\
-  build-aux/convert-xref.scm			\
-  build-aux/cuirass/hurd-manifest.scm			\
-  build-aux/generate-authors.scm			\
-  build-aux/test-driver.scm				\
-  build-aux/update-NEWS.scm				\
-  build-aux/update-guix-package.scm			\
-  doc/build.scm						\
+  CODE-OF-CONDUCT					\
+  .dir-locals.el					\
+  .guix-authorizations					\
+  .guix-channel						\
+  scripts/guix.in					\
   etc/disarchive-manifest.scm				\
   etc/guix-install.sh					\
-  etc/historical-authorizations				\
   etc/news.scm						\
   etc/release-manifest.scm				\
   etc/source-manifest.scm				\
   etc/system-tests.scm					\
-  etc/time-travel-manifest.scm				\
-  scripts/guix.in					\
+  etc/historical-authorizations				\
+  build-aux/build-self.scm				\
+  build-aux/compile-all.scm				\
+  build-aux/cuirass/hurd-manifest.scm			\
+  build-aux/check-final-inputs-self-contained.scm	\
+  build-aux/check-channel-news.scm			\
+  build-aux/compile-as-derivation.scm			\
+  build-aux/convert-xref.scm			\
+  build-aux/generate-authors.scm			\
+  build-aux/test-driver.scm				\
+  build-aux/update-guix-package.scm			\
+  build-aux/update-NEWS.scm				\
+  tests/test.drv					\
   tests/cve-sample.json					\
+  tests/keys/signing-key.pub				\
+  tests/keys/signing-key.sec				\
   tests/keys/civodul.pub				\
+  tests/keys/rsa.pub					\
   tests/keys/dsa.pub					\
+  tests/keys/ed25519.pub				\
+  tests/keys/ed25519.sec				\
   tests/keys/ed25519-2.pub				\
   tests/keys/ed25519-2.sec				\
   tests/keys/ed25519-3.pub				\
   tests/keys/ed25519-3.sec				\
-  tests/keys/ed25519.pub				\
-  tests/keys/ed25519.sec				\
-  tests/keys/rsa.pub					\
-  tests/keys/signing-key.pub				\
-  tests/keys/signing-key.sec				\
-  tests/test.drv					\
+  build-aux/config.rpath				\
+  bootstrap						\
+  doc/build.scm						\
   $(TESTS)
 
 if !BUILD_DAEMON_OFFLOAD
@@ -752,35 +726,20 @@ endef
 # in <https://issues.guix.gnu.org/48963>.  Each 'eval' call below creates a
 # 'make-*-go' phony target that builds the corresponding subset.
 
-first_half :=								\
-  gnu/packages/a% gnu/packages/b% gnu/packages/c% gnu/packages/d%	\
-  gnu/packages/e% gnu/packages/f% gnu/packages/g% gnu/packages/h%	\
-  gnu/packages/i% gnu/packages/j% gnu/packages/k% gnu/packages/l%
-
-MODULES_CORE      := guix.scm $(filter-out guix/scripts/%,$(filter guix/%,$(MODULES)))
-MODULES_PACKAGES1 := $(filter $(first_half),$(MODULES))
-MODULES_PACKAGES2 := $(filter-out $(first_half),$(filter gnu/packages/%,$(MODULES)))
-MODULES_PACKAGES  := $(MODULES_PACKAGES1) $(MODULES_PACKAGES2)
-MODULES_SYSTEM    := gnu.scm $(filter-out gnu/packages/%,$(filter gnu/%,$(MODULES)))
-MODULES_CLI       := $(filter guix/scripts/%,$(MODULES))
-MODULES_PO        := guix/build/po.scm
+MODULES_CORE     = guix.scm $(filter-out guix/scripts/%,$(filter guix/%,$(MODULES)))
+MODULES_PACKAGES = $(filter gnu/packages/%,$(MODULES))
+MODULES_SYSTEM   = gnu.scm $(filter-out gnu/packages/%,$(filter gnu/%,$(MODULES)))
+MODULES_CLI      = $(filter guix/scripts/%,$(MODULES))
+MODULES_PO       = guix/build/po.scm
 
 $(eval $(call guile-compilation-rule,make-core-go,	\
   $(MODULES_CORE) guix/config.scm $(dist_noinst_DATA),	\
   0))
 .PHONY: make-core-go
 
-$(eval $(call guile-compilation-rule,make-packages1-go,	\
-  $(MODULES_PACKAGES1) make-core-go,			\
+$(eval $(call guile-compilation-rule,make-packages-go,	\
+  $(MODULES_PACKAGES) make-core-go,			\
   $(words $(MODULES_CORE))))
-.PHONY: make-packages1-go
-
-$(eval $(call guile-compilation-rule,make-packages2-go,	\
-  $(MODULES_PACKAGES2) make-core-go make-packages1-go,	\
-  $(words $(MODULES_CORE) $(MODULES_PACKAGES1))))
-.PHONY: make-packages2-go
-
-make-packages-go: make-packages1-go make-packages2-go
 .PHONY: make-packages-go
 
 $(eval $(call guile-compilation-rule,make-system-go,	\
@@ -996,21 +955,25 @@ release: dist-with-updated-version all
 	  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))'	\
+# Bump the Guix package version and build it (again).
+	GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT=yes \
+	$(top_builddir)/pre-inst-env "$(GUILE)"	\
+		$(top_srcdir)/build-aux/update-guix-package.scm	\
+		"`git rev-parse HEAD`"
+	git add $(top_srcdir)/gnu/packages/package-management.scm
+	git commit -m "gnu: guix: Update to `git rev-parse HEAD | cut -c1-7`."
+	$(top_builddir)/pre-inst-env guix build guix			\
 	      $(call system_flags,$(GUIX_SYSTEM_SUPPORTED_SYSTEMS))	\
 	      -v1 --no-grafts --fallback
 # Generate the ISO installation images.
 	for system in $(GUIX_SYSTEM_SUPPORTED_SYSTEMS) ; do				\
-	  GUIX_DISPLAYED_VERSION="`git describe --match=v* | sed -'es/^v//'`" ;		\
 	  image=`$(top_builddir)/pre-inst-env						\
-	    guix system image -t iso9660						\
+	    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 ;		\
+	    echo "failed to produce Guix installation image for $$system" >&2 ;	\
 	    exit 1 ;									\
 	  fi ;										\
 	  cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" ;	\
@@ -1019,7 +982,6 @@ release: dist-with-updated-version all
 	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								\
@@ -1107,35 +1069,21 @@ WEBLATE_REPO = https://framagit.org/tyreunom/guix-translations
 # form.
 download-po:
 	dir=$$(mktemp -d); \
-	git clone --depth 1 "$(WEBLATE_REPO)" "$$dir/translations" && \
+	git clone --depth 1 "$(WEBLATE_REPO)" "$$dir/translations"; \
 	for domain in po/doc po/guix po/packages; do \
 	    for po in "$$dir/translations/$$domain"/*.po; do \
 	        translated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | cut -f1 -d' '); \
-	        untranslated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | rev | cut -f3 -d' ' | rev); \
-	        untranslated=$${untranslated:-0}; \
-	        total=$$(($$translated+$$untranslated)); \
 	        target=$$(basename "$$po"); \
 	        target="$$domain/$$target"; \
-	        msgfmt -c "$$po"; \
-	        if msgfmt -c "$$po" && [ "$$translated" != "0" ] && ([ "$$domain" != "po/doc" ] || [ "$$translated" -gt $$(($$total/10)) ] || [ -f $$target ]); then \
+	        if msgfmt -c "$$po" && [ "$$translated" != "0" ]; then \
 	            msgfilter --no-wrap -i "$$po" cat > "$$po".tmp; \
 	            mv "$$po".tmp "$$target"; \
 	            echo "copied $$target."; \
 	        else \
-	            echo "WARN: $$target ($$translated translated messages ($$((translated/total*100))%)) was not added/updated."; \
+	            echo "WARN: $$target ($$translated translated messages) was not added/updated."; \
 	        fi; \
 	    done; \
 	done; \
-	for po in po/doc/*.po; do \
-	    translated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | cut -f1 -d' '); \
-	    untranslated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | rev | cut -f3 -d' ' | rev); \
-	    untranslated=$${untranslated:-0}; \
-	    total=$$(($$translated + $$untranslated)); \
-	    if [ "$$translated" -lt "$$(($$total/20))" ]; then \
-	        echo "WARN: $$po was removed because it is below the 5% threshold: $$((translated/total*100))%"; \
-	        rm $$po; \
-	    fi; \
-	done; \
 	rm -rf "$$dir"
 .PHONY: download-po
 

NEWS

@@ -2,10 +2,9 @@
 #+TITLE: Guix NEWS – history of user-visible changes
 #+STARTUP: content hidestars
 
-Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
+Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
-Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
+Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 
   Copying and distribution of this file, with or without modification,
   are permitted in any medium without royalty provided the copyright
@@ -17,120 +16,22 @@ Please send Guix bug reports to bug-guix@gnu.org.
 ** Package management
 *** New ‘guix home’ command, for home environment management
 *** New ‘guix shell’ command, the successor to ‘guix environment’
-*** New ‘guix system edit’ command, to edit services
 *** New ‘deb’ format for the ‘guix pack’ command
 *** New ‘guix import minetest’ command, to import Minetest extensions
-*** New ‘guix import elm’ command, to import Elm packages
-*** New ‘guix import egg’ command, to import CHICKEN egg packages
-*** New ‘guix import hexpm’ command, to import Erlang and Elixir packages
-*** New 'guix style' command, to auto-format package definitions
 *** ‘guix import texlive’ rewritten to use the TLPDB as its source
 *** ‘guix import elpa’ now supports the non-GNU ELPA repository
 *** ‘guix import pypi’ can now import a specific version
 *** ‘guix import cran’ can now import a specific version
 *** New updater (see ‘guix refresh’): ‘generic-git’
 *** ‘guix graph’ has a new ‘--max-depth’ option
-*** ‘guix deploy’ has a new ‘--execute’ option
-*** ‘guix shell’ has a new ‘--emulate-fhs’ option
-*** ‘guix shell’ has a new ‘--symlink’ option
 *** ‘--with-commit’ option now accepts strings returned by ‘git describe’
-*** ‘--with-source’ option now applied recursively
-*** Align tabular data output by commands like ‘guix package --list-available’
-*** Improved ‘guix import go’ importer via a new PEG parser
-*** Improved Software Heritage downloader
-*** New 'web.archive.org’ download fall-back
-*** Various performance enhancements
-*** New ‘--tune’ package transformation option
-*** ‘guix refresh’ ‘-L’ option is repurposed to ‘load-path’ modification
-*** ‘guix system image’ supersedes the ‘docker-image’ sub-command
-
 ** Distribution
 *** The installation script can now enable local substitute servers discovery
-*** The installation script can now customize the Bash prompt for Guix
 *** More control over boot-time file system checks and repairs
 *** XFS file systems can be created by the installer and mounted by label/UUID
 *** New interface for declaring swap space
-*** GNOME is now at version 42
-*** TeX Live is now at version 2021
-*** Multiple TeX Live trees can now be used via GUIX_TEXMF
-*** Python modules are searched in GUIX_PYTHONPATH instead of PYTHONPATH
-*** Python is now faster thanks to being built with optimizations
-*** The Rust bootstrap now starts from 1.54 instead of 1.19
-*** Most Python 2 packages have been removed
-*** Guix now makes use of parallel xz compression
-*** Faster shared libraries discovery via a per-package dynamic linker cache
-*** Package inputs can now be plain package lists
-*** A package origin can now be a single file rather than an archive
-*** New sanity-check phase to detect Python packaging problems at build time
-*** Fetching sources can now fall-back to use Disarchive
-*** Improved CI and infrastructure
-*** Multiple cross-compilation tooling addition and fixes
-*** Many Qt 6 modules are now packaged
-*** Configuring setuid programs is now more flexible
-*** Add support for the XFS file system
-*** Add partial support for LUKS2 headers when using GRUB
-*** GDM now supports Wayland
-*** Guix System static networking support is improved
-*** The installer final configuration is prettified
-*** The installer external command handling is improved
-*** The installer now has a crash dump upload mechanism
-*** Emacs now supports native compilation
-*** GRUB bootloader now supports chain-loading
-*** The GNU Shepherd was upgraded to 0.9.3
-*** The init RAM disk honors more arguments—e.g. ‘root’ and ‘rootflags’
-*** ‘guix system image’ can now generate WSL images
-*** The mcron task scheduler logs now contain the jobs exit statuses
-*** Chromium extensions are now built in a deterministic fashion
-*** The ‘rsync’ service lets you specify individual “modules”
-*** New services
-
-anonip, bitmask, fail2ban, gitile, greetd, jami, lightdm, log-cleanup,
-nar-herder, opendht, rasdaemon, samba, seatd, strongswan, wsdd
-
-*** 5311 new packages
-
-*** 6573 package updates
-
-Noteworthy updates:
-bash 5.1.8, binutils 2.37, clojure 1.11.1, cups 2.3.3op2, emacs 28.2,
-enlightenment 0.25.4, gcc-toolchain 12.2.0, gdb 12.1, ghc 8.10.7,
-gimp 2.10.32, glibc 2.33, gnome 42.4, gnupg 2.2.32, go 1.19.1, guile 3.0.8,
-icecat 102.5.0-guix0-preview1, icedtea 3.19.0, inkscape 1.2.1, julia 1.6.7,
-libreoffice 7.4.3.2, linux-libre 6.0.10, ocaml 4.14.0, octave 7.2.0,
-openjdk 18, perl 5.34.0, python2 2.7.18, python 3.9.9, racket 8.7,
-rust 1.60.0, r 4.2.2, sbcl 2.2.10, shepherd 0.9.3, xorg-server 21.1.4
-
 ** Programming interfaces
-*** Package input fields can now be plain package lists
-*** G-expressions can now be used in build phases
-*** New ‘modify-inputs’ macro to ease customizing a list of package inputs
-*** New ‘this-package-input’ and ‘this-package-native-input’ macros
-*** Build phases are no longer required to return a boolean
 *** (guix records) now supports “field sanitizers”
-*** Various improvements to the helpers in (gnu service configuration)
-*** ‘texlive-union’ is now deprecated in favor of ‘texlive-updmap.cfg’
-*** New (guix cpu) module
-*** New (guix least-authority) module
-*** New (guix platform) module
-*** New (guix read-print) module
-
-It provides a comment-preserving reader and a comment-preserving
-pretty-printer smarter than (ice-9 pretty-print).
-
-*** New ‘channel-build-system’
-
-This build system lets you build Guix instances from channel specifications,
-similar to how 'guix time-machine' would do it, as regular packages.
-
-*** New ‘pyproject-build-system’
-
-This is an extension of ‘python-build-system’ with support for PEP-517 and
-‘pyproject.toml’ files.  It may eventually get merged back into
-‘python-build-system’.
-
-*** New ‘elm-build-system’
-*** New ‘rebar-build-system’
-
 ** Noteworthy bug fixes
 *** Fall back to Software Heritage when cloning a channel
     (<https://issues.guix.gnu.org/44187>)
@@ -142,42 +43,6 @@ This is an extension of ‘python-build-system’ with support for PEP-517 and
     (<https://issues.guix.gnu.org/24937>)
 *** File system flags are validated before system instantiation
     (<https://issues.guix.gnu.org/51425>)
-*** Fonts can now be discovered in any profile via XDG_DATA_DIRS
-    (<https://issues.guix.gnu.org/31403>)
-*** Various Python reproducibility fixes
-*** The installer now supports MSDOS disk labels on UEFI systems
-    (<https://issues.guix.gnu.org/47889>)
-*** The installer can now properly mount FAT16 partitions
-    (<https://issues.guix.gnu.org/48419>)
-*** The installer no longer crashes when deleting a free space partition
-*** Emacs handles major upgrades better without a re-login
-    (<https://issues.guix.gnu.org/47458>)
-*** The bootloader configuration now accepts multiple targets
-    (<https://issues.guix.gnu.org/40997>)
-*** File system mount point is always created when ‘create?’ is true
-    (<https://issues.guix.gnu.org/40158>)
-*** Build the man database only if ‘man-db’ is in the profile
-*** gdk-pixbuf now discovers pixbuf loaders via a search path
-    (<https://issues.guix.gnu.org/50957>)
-*** Gitolite home directory permissions are fixed
-    (https://issues.guix.gnu.org/56444)
-*** The man-db database is indexed via man pages names
-    (https://issues.guix.gnu.org/38838)
-*** ‘chfn’ can now change the user's full name
-    (https://issues.guix.gnu.org/52539)
-*** GNOME Settings Bluetooth panel is now working
-    (https://issues.guix.gnu.org/32166)
-*** Inferiors are now caching store connections
-    (https://issues.guix.gnu.org/48007)
-*** Retry downloads when a substitute has become unavailable
-    (https://issues.guix.gnu.org/57978)
-*** The installer doesn't segfault when removing an extended partition
-*** The installer doesn't ship an older Guix revision
-    (https://issues.guix.gnu.org/53210)
-*** The installer cannot proceed without any non-root user accounts
-    (https://issues.guix.gnu.org/54666)
-*** <operating-system> compiler truly honors the 'system' argument
-    (https://issues.guix.gnu.org/55951)
 
 * Changes in 1.3.0 (since 1.2.0)
 ** Package management

build-aux/cuirass/evaluate.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016-2018, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
@@ -78,35 +78,28 @@
            ;; up the evaluation speed as the evaluations can be performed
            ;; concurrently.  It also decreases the amount of memory needed per
            ;; evaluation process.
-           ;;
-           ;; Fork inferior processes upfront before we have created any
-           ;; threads.
-           (let ((inferiors (map (lambda _
-                                   (open-inferior (derivation->output-path derivation)))
-                                 %cuirass-supported-systems)))
-             (n-par-for-each
-              (min (length %cuirass-supported-systems)
-                   (current-processor-count))
-              (lambda (system inferior)
-                (with-store store
-                  (let ((channels (map channel-instance->sexp instances)))
-                    (inferior-eval '(use-modules (gnu ci)) inferior)
-                    (let ((jobs
-                           (inferior-eval-with-store
-                            inferior store
-                            `(lambda (store)
-                               (cuirass-jobs store
-                                             '((subset . all)
-                                               (systems . ,(list system))
-                                               (channels . ,channels))))))
-                          (file
-                           (string-append directory "/jobs-" system ".scm")))
-                      (close-inferior inferior)
-                      (call-with-output-file file
-                        (lambda (port)
-                          (write jobs port)))))))
-              %cuirass-supported-systems
-              inferiors)))))))
+           (n-par-for-each
+            (/ (current-processor-count) 2)
+            (lambda (system)
+              (with-store store
+                (let ((inferior
+                       (open-inferior (derivation->output-path derivation)))
+                      (channels (map channel-instance->sexp instances)))
+                  (inferior-eval '(use-modules (gnu ci)) inferior)
+                  (let ((jobs
+                         (inferior-eval-with-store
+                          inferior store
+                          `(lambda (store)
+                             (cuirass-jobs store
+                                           '((subset . all)
+                                             (systems . ,(list system))
+                                             (channels . ,channels))))))
+                        (file
+                         (string-append directory "/jobs-" system ".scm")))
+                    (call-with-output-file file
+                      (lambda (port)
+                        (write jobs port)))))))
+            %cuirass-supported-systems))))))
   (x
    (format (current-error-port) "Wrong command: ~a~%." x)
    (exit 1)))

configure.ac

@@ -274,7 +274,6 @@ AC_CONFIG_FILES([Makefile
                  guix/config.scm])
 
 AC_CONFIG_FILES([etc/committer.scm], [chmod +x etc/committer.scm])
-AC_CONFIG_FILES([etc/teams.scm], [chmod +x etc/teams.scm])
 AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env])
 AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
   [chmod +x pre-inst-env])

doc/build.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019-2025 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,10 +30,8 @@
              (guix gexp)
              (guix git)
              (guix git-download)
-             (guix profiles)
              (guix utils)
              (git)
-             (gnu packages)
              (gnu packages base)
              (gnu packages compression)
              (gnu packages gawk)
@@ -53,116 +50,8 @@
 (define file-append*
   (@@ (guix self) file-append*))
 
-(define (translated-texi-manuals source)
-  "Return the translated texinfo manuals built from SOURCE."
-  (define po4a
-    (specification->package "po4a"))
-
-  (define gettext-minimal
-    (specification->package "gettext-minimal"))
-
-  (define documentation
-    (file-append* source "doc"))
-
-  (define documentation-po
-    (file-append* source "po/doc"))
-
-  (define build
-    (with-imported-modules '((guix build utils) (guix build po))
-      #~(begin
-          (use-modules (guix build utils) (guix build po)
-                       (ice-9 match) (ice-9 regex) (ice-9 textual-ports)
-                       (ice-9 vlist) (ice-9 threads)
-                       (srfi srfi-1))
-
-          (define (translate-tmp-texi po source output)
-            "Translate Texinfo file SOURCE using messages from PO, and write
-the result to OUTPUT."
-            (invoke #+(file-append po4a "/bin/po4a-translate")
-              "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo"
-              "-m" source "-p" po "-l" output))
-
-          (define (canonicalize-whitespace str)
-            ;; Change whitespace (newlines, etc.) in STR to #\space.
-            (string-map (lambda (chr)
-                          (if (char-set-contains? char-set:whitespace chr)
-                              #\space
-                              chr))
-                        str))
-
-          (define* (translate-texi prefix po lang
-                                   #:key (extras '()))
-            "Translate the manual for one language LANG using the PO file.
-PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'.  EXTRAS is
-a list of extra files, such as '(\"contributing\")."
-            (for-each (lambda (file)
-                        (translate-tmp-texi po (string-append file ".texi")
-                                            (string-append file "." lang
-                                                           ".texi.tmp")))
-                      (cons prefix extras))
-
-            (for-each (lambda (file)
-                        (let* ((texi (string-append file "." lang ".texi"))
-                               (tmp  (string-append texi ".tmp")))
-                          (copy-file tmp texi)
-                          (translate-cross-references texi po)))
-                      (cons prefix extras)))
-
-          (define (available-translations directory domain)
-            ;; Return the list of available translations under DIRECTORY for
-            ;; DOMAIN, a gettext domain such as "guix-manual".  The result is
-            ;; a list of language/PO file pairs.
-            (filter-map (lambda (po)
-                          (let ((base (basename po)))
-                            (and (string-prefix? (string-append domain ".")
-                                                 base)
-                                 (match (string-split base #\.)
-                                   ((_ ... lang "po")
-                                    (cons lang po))))))
-                        (find-files directory
-                                    "\\.[a-z]{2}(_[A-Z]{2})?\\.po$")))
-
-          (define parallel-jobs
-            ;; Limit thread creation by 'n-par-for-each', mostly to put an
-            ;; upper bound on memory usage.
-            (min (parallel-job-count) 4))
-
-          (mkdir #$output)
-          (copy-recursively #$documentation "."
-                            #:log (%make-void-port "w"))
-
-          (for-each
-            (lambda (file)
-              (copy-file file (basename file)))
-            (find-files #$documentation-po ".*.po$"))
-
-          (setenv "GUIX_LOCPATH"
-                  #+(file-append glibc-utf8-locales "/lib/locale"))
-          (setenv "PATH" #+(file-append gettext-minimal "/bin"))
-          (setenv "LC_ALL" "en_US.UTF-8")
-          (setlocale LC_ALL "en_US.UTF-8")
-
-          (n-par-for-each parallel-jobs
-                          (match-lambda
-                            ((language . po)
-                             (translate-texi "guix" po language
-                                             #:extras '("contributing"))))
-                          (available-translations "." "guix-manual"))
-
-          (n-par-for-each parallel-jobs
-                          (match-lambda
-                            ((language . po)
-                             (translate-texi "guix-cookbook" po language)))
-                          (available-translations "." "guix-cookbook"))
-
-          (for-each (lambda (file)
-                      (install-file file #$output))
-                    (append
-                     (find-files "." "contributing\\..*\\.texi$")
-                     (find-files "." "guix\\..*\\.texi$")
-                     (find-files "." "guix-cookbook\\..*\\.texi$"))))))
-
-  (computed-file "guix-translated-texinfo" build))
+(define translated-texi-manuals
+  (@@ (guix self) translate-texi-manuals))
 
 (define info-manual
   (@@ (guix self) info-manual))
@@ -173,23 +62,11 @@ a list of extra files, such as '(\"contributing\")."
   (or (getenv "GUIX_MANUAL")
       "guix"))
 
-(define %manual-languages
-  ;; Available translations for the 'guix-manual' text domain.
-  '("de" "en" "es" "fr" "pt_BR" "ru" "zh_CN"))
-
-(define %cookbook-languages
-  ;; Available translations for the 'guix-cookbook' text domain.
-  '("de" "en" "fr" "sk"))
-
 (define %languages
-  ;; Available translations for the document being built.
+  ;; The cookbook is not translated in the same languages as the manual
   (if (string=? %manual "guix-cookbook")
-      %cookbook-languages
-      %manual-languages))
-
-(define %latest-guix-version
-  ;; Latest released version.
-  "1.4.0")
+      '("de" "en" "fr" "sk")
+      '("de" "en" "es" "fr" "ru" "zh_CN")))
 
 (define (texinfo-manual-images source)
   "Return a directory containing all the images used by the user manual, taken
@@ -297,16 +174,11 @@ as well as images, OS examples, and translations."
 (define %web-site-url
   ;; URL of the web site home page.
   (or (getenv "GUIX_WEB_SITE_URL")
-      "/"))
-
-(define %manual-css-url
-  ;; URL of the main CSS file.
-  (in-vicinity %web-site-url
-               "themes/initial/css/manual.css"))
+      "/software/guix/"))
 
 (define %makeinfo-html-options
   ;; Options passed to 'makeinfo --html'.
-  `(,(string-append "--css-ref=" %manual-css-url)
+  '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"
     "-c" "EXTRA_HEAD=<meta name=\"viewport\" \
 content=\"width=device-width, initial-scale=1\" />"))
 
@@ -402,9 +274,6 @@ actual file name."
                      (loop rest))
                     ((('strong _ ...) _ ...)
                      #t)
-                    ((('span ('@ ('class "category")) ;raw Texinfo 6.8
-                             (? string-or-entity?) ...) rest ...)
-                     #t)
                     ((('span ('@ ('class "symbol-definition-category"))
                              (? string-or-entity?) ...) rest ...)
                      #t)
@@ -432,9 +301,8 @@ actual file name."
             (define (html-files directory)
               ;; Return the list of HTML files under DIRECTORY.
               (map (cut string-append directory "/" <>)
-                   (or (scandir #$manual (lambda (file)
-                                           (string-suffix? ".html" file)))
-                       '())))
+                   (scandir #$manual (lambda (file)
+                                       (string-suffix? ".html" file)))))
 
             (define anchors
               (sort (concatenate
@@ -628,16 +496,10 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 
                   ;; Replace the ugly <strong> used for @deffn etc., which
                   ;; translate to <dt>, with more stylable markup.
-                  (('dt ('@ ('id id))             ;raw Texinfo 6.8
-                        ('span ('@ ('class "category")) category ...)
-                        ('span ('strong thing)
-                               anchor))
+                  (('dt (@ ('id id)) category ... ('strong thing))
                    (highlight-definition id category thing '()))
-                  (('dt (@ ('id id))
-                        ('span ('@ ('class "category")) category ...)
-                        ('span ('strong thing)
-                               (? space?) ('em args ...)
-                               anchor))
+                  (('dt (@ ('id id)) category ... ('strong thing)
+                        (? space?) ('em args ...))
                    (highlight-definition id category thing args))
 
                   ((tag ('@ attributes ...) body ...)
@@ -740,10 +602,9 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 
 (define* (stylized-html source input
                         #:key
-                        (latest-version %latest-guix-version)
                         (languages %languages)
                         (manual %manual)
-                        (manual-css-url %manual-css-url))
+                        (manual-css-url "/static/base/css/manual.css"))
   "Process all the HTML files in INPUT; add them MANUAL-CSS-URL as a <style>
 link, and add a menu to choose among LANGUAGES.  Use the Guix PO files found
 in SOURCE."
@@ -789,14 +650,6 @@ in SOURCE."
 	                 (href ,url))
                       ,label)))
 
-            (define menu-item-separator
-              ;; Thin horizontal line to separate drop-down menu items.
-              `(img (@ (class "hline")
-                       (src ,(in-vicinity
-                              #$%web-site-url
-                              "themes/initial/img/h-separator.png"))
-                       (alt ""))))
-
             (define* (navigation-bar menus #:key split-node?)
               ;; Return the navigation bar showing all of MENUS.
               `(header (@ (class "navbar"))
@@ -843,43 +696,7 @@ in SOURCE."
                                   "https://translate.fedoraproject.org/projects/guix/documentation-cookbook/"
                                   "https://translate.fedoraproject.org/projects/guix/documentation-manual/")))))
 
-            (define (version-menu-items language split-node?)
-              ;; Return the menu items to select the version of the manual of
-              ;; the type of medium (PDF, split-node, etc.).
-              (define language-extension
-                (if (string=? language "en")
-                    ""
-                    (string-append "." language)))
-
-              (define pdf-link
-                (string-append (if split-node? "../" "")
-                               #$manual language-extension ".pdf"))
-
-              (define version-links
-                (list (menu-item #$latest-version
-                                 (string-append
-                                  "/manual/" #$latest-version
-                                  "/" language
-                                  (if split-node? "/html_node" "")))
-                      (menu-item "development"
-                                 (string-append
-                                  "/manual/devel/" language
-                                  (if split-node? "/html_node" "")))
-                      menu-item-separator))
-
-              (append (if (string=? #$manual "guix")
-                          version-links
-                          '())
-                      (list (if split-node?
-                                (menu-item "single page"
-                                           (string-append "../" #$manual
-                                                          language-extension
-                                                          ".html"))
-                                (menu-item "multiple pages"
-                                           "html_node"))
-                            (menu-item "PDF" pdf-link))))
-
-            (define (stylized-html sxml file language)
+            (define (stylized-html sxml file)
               ;; Return SXML, which was read from FILE, with additional
               ;; styling.
               (define split-node?
@@ -902,16 +719,9 @@ in SOURCE."
                             ;; TODO: Add "Contribute" menu, to report
                             ;; errors, etc.
                             (list (menu-dropdown
-                                   #:label "Version"
-                                   #:items
-                                   (version-menu-items language
-                                                       split-node?))
-                                  (menu-dropdown
                                    #:label
                                    `(img (@ (alt "Language")
-                                            (src #$(in-vicinity
-                                                    %web-site-url
-                                                    "themes/initial/img/language-picker.svg"))))
+                                            (src "/static/base/img/language-picker.svg")))
                                    #:items
                                    (language-menu-items file)))
                             #:split-node? split-node?)
@@ -923,13 +733,13 @@ in SOURCE."
                   ((? string? str)
                    str))))
 
-            (define (process-html file language)
+            (define (process-html file)
               ;; Parse FILE and add links to translations.  Install the result
               ;; to #$output.
               (format (current-error-port) "processing ~a...~%" file)
               (let* ((shtml        (parameterize ((%strict-tokenizer? #t))
                                      (call-with-input-file file html->shtml)))
-                     (processed    (stylized-html shtml file language))
+                     (processed    (stylized-html shtml file))
                      (base         (string-drop file (string-length #$input)))
                      (target       (string-append #$output base)))
                 (mkdir-p (dirname target))
@@ -937,15 +747,6 @@ in SOURCE."
                   (lambda (port)
                     (write-shtml-as-html processed port)))))
 
-            (define (input-file-language file)
-              ;; Return the language code of FILE, an input file, as a string
-              ;; like "sv" or "zh-cn".
-              (match (string-tokenize (string-drop file
-                                                   (string-length #$input))
-                                      (char-set-complement
-                                       (char-set #\/)))
-                ((language _ ...) language)))
-
             ;; Install a UTF-8 locale so we can process UTF-8 files.
             (setenv "GUIX_LOCPATH"
                     #+(file-append glibc-utf8-locales "/lib/locale"))
@@ -956,8 +757,7 @@ in SOURCE."
             (n-par-for-each (parallel-job-count)
                             (lambda (file)
                               (if (string-suffix? ".html" file)
-                                  (let ((language (input-file-language file)))
-                                    (process-html file language))
+                                  (process-html file)
                                   ;; Copy FILE as is to #$output.
                                   (let* ((base   (string-drop file (string-length #$input)))
                                          (target (string-append #$output base)))
@@ -1024,8 +824,7 @@ makeinfo OPTIONS."
                       (let* ((texi (language->texi-file-name language))
                              (opts `("--html"
                                      "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
-                                                          #$%latest-guix-version
-                                                          "/" language)
+                                                         language)
                                      #$@options
                                      ,texi)))
                         (format #t "building HTML manual for language '~a'...~%"
@@ -1082,22 +881,14 @@ makeinfo OPTIONS."
                            #:languages languages
                            #:date date))
 
-  (define texinfo-profile
-    (profile
-     (content (packages->manifest
-               ;; texi2dvi requires various command line tools.
-               (list coreutils
-                     diffutils
-                     gawk
-                     grep
-                     sed
-                     tar
-                     texinfo
-                     texlive-scheme-basic
-                     texlive-bin        ;for GUIX_TEXMF
-                     texlive-epsf
-                     texlive-ec
-                     texlive-texinfo)))))
+  ;; FIXME: This union works, except for the table of contents of non-English
+  ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
+  ;; accented letters.
+  ;;
+  ;; (define texlive
+  ;;   (texlive-updmap.cfg (list texlive-tex-texinfo
+  ;;                        texlive-generic-epsf
+  ;;                        texlive-fonts-ec)))
 
   (define build
     (with-imported-modules '((guix build utils))
@@ -1114,12 +905,21 @@ makeinfo OPTIONS."
                         (string-downcase language)))
 
           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
-          (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales
-                                                "/lib/locale"))
+          (setenv "GUIX_LOCPATH"
+                  #+(file-append glibc-utf8-locales "/lib/locale"))
           (setenv "LC_ALL" "en_US.utf8")
-          (setenv "PATH" #+(file-append texinfo-profile "/bin"))
-          (setenv "GUIX_TEXMF" #+(file-append texinfo-profile
-                                              "/share/texmf-dist"))
+          (setenv "PATH"
+                  (string-append #+(file-append texlive "/bin") ":"
+                                 #+(file-append texinfo "/bin") ":"
+
+                                 ;; Below are command-line tools needed by
+                                 ;; 'texi2dvi' and friends.
+                                 #+(file-append sed "/bin") ":"
+                                 #+(file-append grep "/bin") ":"
+                                 #+(file-append coreutils "/bin") ":"
+                                 #+(file-append gawk "/bin") ":"
+                                 #+(file-append tar "/bin") ":"
+                                 #+(file-append diffutils "/bin")))
 
           (setvbuf (current-output-port) 'line)
           (setvbuf (current-error-port) 'line)
@@ -1169,8 +969,7 @@ PDF for language '~a'!~%~%"
   (computed-file (string-append manual "-pdf-manual") build
                  #:local-build? #f))
 
-(define* (guix-manual-text-domain source
-                                  #:optional (languages %manual-languages))
+(define (guix-manual-text-domain source languages)
   "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
 from SOURCE."
   (define po-directory
@@ -1243,7 +1042,9 @@ must be the Guix top-level source directory, from which PO files are taken."
             (define exp
               `(begin
                  (bindtextdomain "guix-manual"
-                                 #+(guix-manual-text-domain source))
+                                 #+(guix-manual-text-domain
+                                    source
+                                    languages))
                  (bindtextdomain "iso_639-3"      ;language names
                                  #+(file-append iso-codes
                                                 "/share/locale"))
@@ -1483,7 +1284,6 @@ commit date (an integer)."
                          (setenv "PATH"
                                  (string-append #+tar "/bin:"
                                                 #+xz "/bin:"
-                                                #+zstd "/bin:"
                                                 #+texinfo "/bin"))
                          (invoke "tar" "xf" #$(package-source guile))
                          (mkdir-p (string-append #$output "/en/html_node"))
@@ -1547,9 +1347,7 @@ by 'html-identifier-indexes'."
 
 
 (let* ((root (canonicalize-path
-              (string-append (or (current-source-directory)
-                                 (string-append (getcwd) "/doc"))
-                             "/..")))
+              (string-append (current-source-directory) "/..")))
        (commit date (latest-commit+date root))
        (version (or (getenv "GUIX_MANUAL_VERSION")
                     (string-take commit 7)))
@@ -1596,8 +1394,7 @@ by 'html-identifier-indexes'."
     (merge-index-alists guix-split-node-indexes guile-split-node-indexes))
 
   (format (current-error-port)
-          "building manual from work tree (~a) around commit ~a, ~a~%"
-          root
+          "building manual from work tree around commit ~a, ~a~%"
           commit
           (let* ((time (make-time time-utc 0 date))
                  (date (time-utc->date time)))

doc/contributing.texi

@@ -29,7 +29,6 @@ choice.
 * Tracking Bugs and Patches::   Keeping it all organized.
 * Commit Access::               Pushing to the official repository.
 * Updating the Guix Package::   Updating the Guix package definition.
-* Writing Documentation::       Improving documentation in GNU Guix.
 * Translating Guix::            Make Guix speak your native language.
 @end menu
 
@@ -225,7 +224,8 @@ $ ./pre-inst-env guile -c '(use-modules (guix utils)) (pk (%current-system))'
 @noindent
 @cindex REPL
 @cindex read-eval-print loop
-@dots{} and for a REPL (@pxref{Using Guix Interactively}):
+@dots{} and for a REPL (@pxref{Using Guile Interactively,,, guile, Guile
+Reference Manual}):
 
 @example
 $ ./pre-inst-env guile
@@ -278,8 +278,8 @@ prepared Guile object (@file{.go}) files.
 
 You can run @command{make} automatically as you work using
 @command{watchexec} from the @code{watchexec} package.  For example,
-to build again each time you update a package file, run
-@samp{watchexec -w gnu/packages -- make -j4}.
+to build again each time you update a package file, you can run
+@samp{watchexec -w gnu/packages make -j4}.
 
 @node The Perfect Setup
 @section The Perfect Setup
@@ -291,7 +291,7 @@ Manual}).  First, you need more than an editor, you need
 wonderful @url{https://nongnu.org/geiser/, Geiser}.  To set that up, run:
 
 @example
-guix install emacs guile emacs-geiser emacs-geiser-guile
+guix package -i emacs guile emacs-geiser emacs-geiser-guile
 @end example
 
 Geiser allows for interactive and incremental development from within
@@ -320,25 +320,15 @@ s-expression, etc.
 @cindex reducing boilerplate
 We also provide templates for common git commit messages and package
 definitions in the @file{etc/snippets} directory.  These templates can
-be used to expand short trigger strings to interactive text snippets. If
-you use @url{https://joaotavora.github.io/yasnippet/, YASnippet}, you
-may want to add the @file{etc/snippets/yas} snippets directory to the
-@var{yas-snippet-dirs} variable.  If you use
-@url{https://github.com/minad/tempel/, Tempel}, you may want to add the
-@file{etc/snippets/tempel/*} path to the @var{tempel-path} variable in
+be used with @url{https://joaotavora.github.io/yasnippet/, YASnippet} to
+expand short trigger strings to interactive text snippets.  You may want
+to add the snippets directory to the @var{yas-snippet-dirs} variable in
 Emacs.
 
 @lisp
 ;; @r{Assuming the Guix checkout is in ~/src/guix.}
-;; @r{Yasnippet configuration}
 (with-eval-after-load 'yasnippet
-  (add-to-list 'yas-snippet-dirs "~/src/guix/etc/snippets/yas"))
-;; @r{Tempel configuration}
-(with-eval-after-load 'tempel
-   ;; Ensure tempel-path is a list -- it may also be a string.
-   (unless (listp 'tempel-path)
-     (setq tempel-path (list tempel-path)))
-   (add-to-list 'tempel-path "~/src/guix/etc/snippets/tempel/*"))
+  (add-to-list 'yas-snippet-dirs "~/src/guix/etc/snippets"))
 @end lisp
 
 The commit message snippets depend on @url{https://magit.vc/, Magit} to
@@ -457,7 +447,6 @@ needed is to review and apply the patch.
 * Perl Modules::                Little pearls.
 * Java Packages::               Coffee break.
 * Rust Crates::                 Beware of oxidation.
-* Elm Packages::                Trees of browser code
 * Fonts::                       Fond of fonts.
 @end menu
 
@@ -674,7 +663,7 @@ hyperlinks (@pxref{Overview,,, texinfo, GNU Texinfo}).  However you
 should be careful when using some characters for example @samp{@@} and
 curly braces which are the basic special characters in Texinfo
 (@pxref{Special Characters,,, texinfo, GNU Texinfo}).  User interfaces
-such as @command{guix show} take care of rendering it
+such as @command{guix package --show} take care of rendering it
 appropriately.
 
 Synopses and descriptions are translated by volunteers
@@ -786,29 +775,12 @@ for instance, the module python-dateutil is packaged under the names
 starts with @code{py} (e.g.@: @code{pytz}), we keep it and prefix it as
 described above.
 
-@quotation Note
-Currently there are two different build systems for Python packages in Guix:
-@var{python-build-system} and @var{pyproject-build-system}.  For the
-longest time, Python packages were built from an informally specified
-@file{setup.py} file.  That worked amazingly well, considering Python's
-success, but was difficult to build tooling around.  As a result, a host
-of alternative build systems emerged and the community eventually settled on a
-@url{https://peps.python.org/pep-0517/, formal standard} for specifying build
-requirements.  @var{pyproject-build-system} is Guix's implementation of this
-standard.  It is considered ``experimental'' in that it does not yet support
-all the various PEP-517 @emph{build backends}, but you are encouraged to try
-it for new Python packages and report any problems.  It will eventually be
-deprecated and merged into @var{python-build-system}.
-@end quotation
-
 @subsubsection Specifying Dependencies
 @cindex inputs, for Python packages
 
 Dependency information for Python packages is usually available in the
 package source tree, with varying degrees of accuracy: in the
-@file{pyproject.toml} file, the @file{setup.py} file, in
-@file{requirements.txt}, or in @file{tox.ini} (the latter mostly for
-test dependencies).
+@file{setup.py} file, in @file{requirements.txt}, or in @file{tox.ini}.
 
 Your mission, when writing a recipe for a Python package, is to map
 these dependencies to the appropriate type of ``input'' (@pxref{package
@@ -819,12 +791,10 @@ following check list to determine which dependency goes where.
 @itemize
 
 @item
-We currently package Python with @code{setuptools} and @code{pip}
-installed per default.  This is about to change, and users are encouraged
-to use @code{python-toolchain} if they want a build environment for Python.
-
-@command{guix lint} will warn if @code{setuptools} or @code{pip} are
-added as native-inputs because they are generally not necessary.
+We currently package Python 2 with @code{setuptools} and @code{pip}
+installed like Python 3.4 has per default.  Thus you don't need to
+specify either of these as an input.  @command{guix lint} will warn you
+if you do.
 
 @item
 Python dependencies required at run time go into
@@ -833,10 +803,9 @@ Python dependencies required at run time go into
 @file{requirements.txt} file.
 
 @item
-Python packages required only at build time---e.g., those listed under
-@code{build-system.requires} in @file{pyproject.toml} or with the
-@code{setup_requires} keyword in @file{setup.py}---or dependencies only
-for testing---e.g., those in @code{tests_require} or @file{tox.ini}---go into
+Python packages required only at build time---e.g., those listed with
+the @code{setup_requires} keyword in @file{setup.py}---or only for
+testing---e.g., those in @code{tests_require}---go into
 @code{native-inputs}.  The rationale is that (1) they do not need to be
 propagated because they are not needed at run time, and (2) in a
 cross-compilation context, it's the ``native'' input that we'd want.
@@ -929,87 +898,6 @@ developed for a different Operating System, depend on features from the Nightly
 Rust compiler, or the test suite may have atrophied since it was released.
 
 
-@node Elm Packages
-@subsection Elm Packages
-
-@cindex Elm
-Elm applications can be named like other software: their names need not
-mention Elm.
-
-Packages in the Elm sense (see @code{elm-build-system} under @ref{Build
-Systems}) are required use names of the format
-@var{author}@code{/}@var{project}, where both the @var{author} and the
-@var{project} may contain hyphens internally, and the @var{author} sometimes
-contains uppercase letters.
-
-To form the Guix package name from the upstream name, we follow a convention
-similar to Python packages (@pxref{Python Modules}), adding an @code{elm-}
-prefix unless the name would already begin with @code{elm-}.
-
-In many cases we can reconstruct an Elm package's upstream name heuristically,
-but, since conversion to a Guix-style name involves a loss of information,
-this is not always possible.  Care should be taken to add the
-@code{'upstream-name} property when necessary so that @samp{guix import elm}
-will work correctly (@pxref{Invoking guix import}). The most notable scenarios
-when explicitly specifying the upstream name is necessary are:
-
-@enumerate
-@item
-When the @var{author} is @code{elm} and the @var{project} contains one or more
-hyphens, as with @code{elm/virtual-dom}; and
-
-@item
-When the @var{author} contains hyphens or uppercase letters, as with
-@code{Elm-Canvas/raster-shapes}---unless the @var{author} is
-@code{elm-explorations}, which is handled as a special case, so packages like
-@code{elm-explorations/markdown} do @emph{not} need to use the
-@code{'upstream-name} property.
-@end enumerate
-
-The module @code{(guix build-system elm)} provides the following utilities for
-working with names and related conventions:
-
-@deffn {Scheme procedure} elm-package-origin @var{elm-name} @var{version} @
-  @var{hash}
-Returns a Git origin using the repository naming and tagging regime required
-for a published Elm package with the upstream name @var{elm-name} at version
-@var{version} with sha256 checksum @var{hash}.
-
-For example:
-@lisp
-(package
-  (name "elm-html")
-  (version "1.0.0")
-  (source
-   (elm-package-origin
-    "elm/html"
-    version
-    (base32 "15k1679ja57vvlpinpv06znmrxy09lbhzfkzdc89i01qa8c4gb4a")))
-  ...)
-@end lisp
-@end deffn
-
-@deffn {Scheme procedure} elm->package-name @var{elm-name}
-Returns the Guix-style package name for an Elm package with upstream name
-@var{elm-name}.
-
-Note that there is more than one possible @var{elm-name} for which
-@code{elm->package-name} will produce a given result.
-@end deffn
-
-@deffn {Scheme procedure} guix-package->elm-name @var{package}
-Given an Elm @var{package}, returns the possibly-inferred upstream name, or
-@code{#f} the upstream name is not specified via the @code{'upstream-name}
-property and can not be inferred by @code{infer-elm-package-name}.
-@end deffn
-
-@deffn {Scheme procedure} infer-elm-package-name @var{guix-name}
-Given the @var{guix-name} of an Elm package, returns the inferred upstream
-name, or @code{#f} if the upstream name can't be inferred.  If the result is
-not @code{#f}, supplying it to @code{elm->package-name} would produce
-@var{guix-name}.
-@end deffn
-
 @node Fonts
 @subsection Fonts
 
@@ -1089,16 +977,11 @@ and then to browse them ``by hand'' using @code{car}, @code{cdr},
 notably the fact that it is hard to read, error-prone, and a hindrance
 to proper type error reports.
 
-@findex define-record-type*
-@findex match-record
-@cindex pattern matching
 Guix code should define appropriate data types (for instance, using
 @code{define-record-type*}) rather than abuse lists.  In addition, it
 should use pattern matching, via Guile’s @code{(ice-9 match)} module,
 especially when matching lists (@pxref{Pattern Matching,,, guile, GNU
-Guile Reference Manual}); pattern matching for records is better done
-using @code{match-record} from @code{(guix records)}, which, unlike
-@code{match}, verifies field names at macro-expansion time.
+Guile Reference Manual}).
 
 @node Formatting Code
 @subsection Formatting Code
@@ -1153,18 +1036,18 @@ Development is done using the Git distributed version control system.
 Thus, access to the repository is not strictly necessary.  We welcome
 contributions in the form of patches as produced by @code{git
 format-patch} sent to the @email{guix-patches@@gnu.org} mailing list
-(@pxref{Submitting patches to a project,,, git, Git User Manual}).
-Contributors are encouraged to take a moment to set some Git repository
-options (@pxref{Configuring Git}) first, which can improve the
-readability of patches.  Seasoned Guix developers may also want to look
-at the section on commit access (@pxref{Commit Access}).
+(@pxref{submitting patches,, Submitting patches to a project, git, Git
+User Manual}).  Contributors are encouraged to take a moment to set some
+Git repository options (@pxref{Configuring Git}) first, which can
+improve the readability of patches.  Seasoned Guix developers may also
+want to look at the section on commit access (@pxref{Commit Access}).
 
 This mailing list is backed by a Debbugs instance, which allows us to
 keep track of submissions (@pxref{Tracking Bugs and Patches}).  Each
 message sent to that mailing list gets a new tracking number assigned;
 people can then follow up on the submission by sending email to
-@code{@var{ISSUE_NUMBER}@@debbugs.gnu.org}, where @var{ISSUE_NUMBER} is
-the tracking number (@pxref{Sending a Patch Series}).
+@code{@var{NNN}@@debbugs.gnu.org}, where @var{NNN} is the tracking
+number (@pxref{Sending a Patch Series}).
 
 Please write commit logs in the ChangeLog format (@pxref{Change Logs,,,
 standards, GNU Coding Standards}); you can check the commit history for
@@ -1174,6 +1057,15 @@ Before submitting a patch that adds or modifies a package definition,
 please run through this check list:
 
 @enumerate
+@cindex @code{git format-patch}
+@cindex @code{git-format-patch}
+@item
+When generating your patches with @code{git format-patch} or @code{git
+send-email}, we recommend using the option @code{--base=}, perhaps with
+the value @code{auto}.  This option adds a note to the patch stating
+which commit the patch is based on.  This helps reviewers understand how
+to apply and review your patches.
+
 @item
 If the authors of the packaged software provide a cryptographic
 signature for the release tarball, make an effort to verify the
@@ -1357,13 +1249,12 @@ guix pull --url=/path/to/your/checkout --profile=/tmp/guix.master
 When posting a patch to the mailing list, use @samp{[PATCH] @dots{}} as
 a subject, if your patch is to be applied on a branch other than
 @code{master}, say @code{core-updates}, specify it in the subject like
-@samp{[PATCH core-updates] @dots{}}.
-
-You may use your email client or the @command{git send-email} command
-(@pxref{Sending a Patch Series}).  We prefer to get patches in plain
-text messages, either inline or as MIME attachments.  You are advised to
-pay attention if your email client changes anything like line breaks or
-indentation which could potentially break the patches.
+@samp{[PATCH core-updates] @dots{}}.  You may use your email client or
+the @command{git send-email} command (@pxref{Sending a Patch Series}).
+We prefer to get patches in plain text messages, either inline or as
+MIME attachments.  You are advised to pay attention if your email client
+changes anything like line breaks or indentation which could potentially
+break the patches.
 
 Expect some delay when you submit your very first patch to
 @email{guix-patches@@gnu.org}. You have to wait until you get an
@@ -1371,7 +1262,7 @@ acknowledgement with the assigned tracking number. Future acknowledgements
 should not be delayed.
 
 When a bug is resolved, please close the thread by sending an email to
-@email{@var{ISSUE_NUMBER}-done@@debbugs.gnu.org}.
+@email{@var{NNN}-done@@debbugs.gnu.org}.
 
 @node Configuring Git
 @subsection Configuring Git
@@ -1409,180 +1300,19 @@ git config --local format.thread shallow
 git config --local sendemail.thread no
 @end example
 
-@node Sending a Patch Series
-@subsection Sending a Patch Series
+@unnumberedsubsec Sending a Patch Series
+@anchor{Sending a Patch Series}
 @cindex patch series
 @cindex @code{git send-email}
-@cindex @code{git format-patch}
 
-@unnumberedsubsubsec Single Patches
-@anchor{Single Patches}
-The @command{git send-email} command is the best way to send both single
-patches and patch series (@pxref{Multiple Patches}) to the Guix mailing
-list.  Sending patches as email attachments may make them difficult to
-review in some mail clients, and @command{git diff} does not store commit
-metadata.
-
-@quotation Note
-The @command{git send-email} command is provided by the @code{send-email}
-output of the @code{git} package, i.e. @code{git:send-email}.
-@end quotation
-
-The following command will create a patch email from the latest commit,
-open it in your @var{EDITOR} or @var{VISUAL} for editing, and send it to
-the Guix mailing list to be reviewed and merged:
-
-@example
-$ git send-email -1 -a --base=auto --to=guix-patches@@gnu.org
-@end example
-
-@quotation Tip
-To add a prefix to the subject of your patch, you may use the
-@option{--subject-prefix} option.  The Guix project uses this to
-specify that the patch is intended for a branch or repository
-other than the @code{master} branch of
-@url{https://git.savannah.gnu.org/cgit/guix.git}.
-
-@example
-git send-email -1 -a --base=auto \
-    --subject-prefix='PATCH core-updates' \
-    --to=guix-patches@@gnu.org
-@end example
-@end quotation
-
-The patch email contains a three-dash separator line after the commit
-message.  You may ``annotate'' the patch with explanatory text by adding
-it under this line.  If you do not wish to annotate the email, you may
-drop the @option{-a} flag (which is short for @option{--annotate}).
-
-The @option{--base=auto} flag automatically adds a note at the bottom
-of the patch of the commit it was based on, making it easier for
-maintainers to rebase and merge your patch.
-
-If you need to send a revised patch, don't resend it like this or send
-a ``fix'' patch to be applied on top of the last one; instead, use
-@command{git commit -a} or @url{https://git-rebase.io, @command{git rebase}}
-to modify the commit, and use the @email{@var{ISSUE_NUMBER}@@debbugs.gnu.org}
-address and the @option{-v} flag with @command{git send-email}.
-
-@example
-$ git commit -a
-$ git send-email -1 -a --base=auto -v @var{REVISION} \
-      --to=@var{ISSUE_NUMBER}@@debbugs.gnu.org
-@end example
-
-You can find out @var{ISSUE_NUMBER} either by searching on the mumi
-interface at @url{issues.guix.gnu.org} for the name of your patch or
-reading the acknowledgement email sent automatically by Debbugs in
-reply to incoming bugs and patches, which contains the bug number.
-
-@unnumberedsubsubsec Notifying Teams
-@anchor{Notifying Teams}
-@cindex teams
-The @file{etc/teams.scm} script may be used to notify all those who
-may be interested in your patch of its existence (@pxref{Teams}).
-Use @command{etc/teams.scm list-teams} to display all the teams,
-decide which team(s) your patch relates to, and use
-@command{etc/teams.scm cc} to output various @command{git send-email}
-flags which will notify the appropriate team members, or use
-@command{etc/teams.scm cc-members} to detect the appropriate teams
-automatically.
-
-@unnumberedsubsubsec Multiple Patches
-@anchor{Multiple Patches}
-@cindex cover letter
-While @command{git send-email} alone will suffice for a single
-patch, an unfortunate flaw in Debbugs means you need to be more
-careful when sending multiple patches: if you send them all to the
-@email{guix-patches@@gnu.org} address, a new issue will be created
-for each patch!
-
-When sending a series of patches, it's best to send a Git ``cover
-letter'' first, to give reviewers an overview of the patch series.
-We can create a directory called @file{outgoing} containing both
-our patch series and a cover letter called @file{0000-cover-letter.patch}
-with @command{git format-patch}.
-
-@example
-$ git format-patch -@var{NUMBER_COMMITS} -o outgoing \
-      --cover-letter --base=auto
-@end example
-
-We can now send @emph{just} the cover letter to the
-@email{guix-patches@@gnu.org} address, which will create an issue
-that we can send the rest of the patches to.
-
-@example
-$ git send-email outgoing/0000-cover-letter.patch -a \
-      --to=guix-patches@@gnu.org \
-      $(etc/teams.scm cc-members ...)
-$ rm outgoing/0000-cover-letter.patch # we don't want to resend it!
-@end example
-
-Ensure you edit the email to add an appropriate subject line and
-blurb before sending it.  Note the automatically generated shortlog
-and diffstat below the blurb.
-
-Once the Debbugs mailer has replied to your cover letter email, you
-can send the actual patches to the newly-created issue address.
-
-@example
-$ git send-email outgoing/*.patch \
-      --to=@var{ISSUE_NUMBER}@@debbugs.gnu.org \
-      $(etc/teams.scm cc-members ...)
-$ rm -rf outgoing # we don't need these anymore
-@end example
-
-Thankfully, this @command{git format-patch} dance is not necessary
-to send an amended patch series, since an issue already exists for
-the patchset.
-
-@example
-$ git send-email -@var{NUMBER_COMMITS} \
-      -v@var{REVISION} --base=auto \
-      --to @var{ISSUE_NUMBER}@@debbugs.gnu.org
-@end example
-
-If need be, you may use @option{--cover-letter -a} to send another cover
-letter, e.g. for explaining what's changed since the last revision, and
-these changes are necessary.
-
-@node Teams
-@subsection Teams
-@cindex teams
-
-There are several teams mentoring different parts of the Guix source
-code.  To list all those teams, you can run from a Guix checkout:
-
-@example
-$ ./etc/teams.scm list-teams
-id: mentors
-name: Mentors
-description: A group of mentors who chaperone contributions by newcomers.
-members:
-+ Christopher Baines <mail@@cbaines.net>
-+ Ricardo Wurmus <rekado@@elephly.net>
-+ Mathieu Othacehe <othacehe@@gnu.org>
-+ jgart <jgart@@dismail.de>
-+ Ludovic Courtès <ludo@@gnu.org>
-@dots{}
-@end example
-
-You can run the following command to have the @code{Mentors} team put in
-CC of a patch series:
-
-@example
-$ git send-email --to @var{ISSUE_NUMBER}@@debbugs.gnu.org $(./etc/teams.scm cc mentors) *.patch
-@end example
-
-The appropriate team or teams can also be inferred from the modified
-files.  For instance, if you want to send the two latest commits of the
-current Git repository to review, you can run:
-
-@example
-$ guix shell -D guix
-[env]$ git send-email --to @var{ISSUE_NUMBER}@@debbugs.gnu.org $(./etc/teams.scm cc-members HEAD~2 HEAD) *.patch
-@end example
+When sending a patch series (e.g., using @code{git send-email}), please
+first send one message to @email{guix-patches@@gnu.org}, and then send
+subsequent patches to @email{@var{NNN}@@debbugs.gnu.org} to make sure
+they are kept together.  See
+@uref{https://debbugs.gnu.org/Advanced.html, the Debbugs documentation}
+for more information.  You can install @command{git send-email} with
+@command{guix install git:send-email}.
+@c Debbugs bug: https://debbugs.gnu.org/db/15/15361.html
 
 @node Tracking Bugs and Patches
 @section Tracking Bugs and Patches
@@ -1805,23 +1535,14 @@ git config commit.gpgsign true
 git config user.signingkey CABBA6EA1DC0FF33
 @end example
 
-To check that commits are signed with correct key, use:
-
-@example
-make authenticate
-@end example
-
-You can prevent yourself from accidentally pushing unsigned or signed
-with the wrong key commits to Savannah by using the pre-push Git hook
-located at @file{etc/git/pre-push}:
+You can prevent yourself from accidentally pushing unsigned commits to
+Savannah by using the pre-push Git hook located at
+@file{etc/git/pre-push}:
 
 @example
 cp etc/git/pre-push .git/hooks/pre-push
 @end example
 
-It additionally calls @code{make check-channel-news} to be sure
-@file{news.scm} file is correct.
-
 @subsection Commit Policy
 
 If you get commit access, please make sure to follow
@@ -1976,47 +1697,6 @@ This check can be disabled, @emph{at your own peril}, by setting the
 this variable is set, the updated package source is also added to the
 store.  This is used as part of the release process of Guix.
 
-@cindex documentation
-@node Writing Documentation
-@section Writing Documentation
-
-Guix is documented using the Texinfo system.  If you are not yet
-familiar with it, we accept contributions for documentation in most
-formats.  That includes plain text, Markdown, Org, etc.
-
-Documentation contributions can be sent to
-@email{guix-patches@@gnu.org}.  Prepend @samp{[DOCUMENTATION]} to the
-subject.
-
-When you need to make more than a simple addition to the documentation,
-we prefer that you send a proper patch as opposed to sending an email
-as described above.  @xref{Submitting Patches} for more information on
-how to send your patches.
-
-To modify the documentation, you need to edit @file{doc/guix.texi} and
-@file{doc/contributing.texi} (which contains this documentation
-section), or @file{doc/guix-cookbook.texi} for the cookbook.  If
-you compiled the Guix repository before, you will have
-many more @file{.texi} files that are translations of these
-documents.  Do not modify them, the translation is managed through
-@uref{https://translate.fedoraproject.org/projects/guix, Weblate}.
-@xref{Translating Guix} for more information.
-
-To render documentation, you must first make sure that you ran
-@command{./configure} in your source tree (@pxref{Running Guix Before
-It Is Installed}).  After that you can run one of the following
-commands:
-
-@itemize
-@item @samp{make doc/guix.info} to compile the Info manual.
-      You can check it with @command{info doc/guix.info}.
-@item @samp{make doc/guix.html} to compile the HTML version.
-      You can point your browser to the relevant file in the
-      @file{doc/guix.html} directory.
-@item @samp{make doc/guix-cookbook.info} for the cookbook Info manual.
-@item @samp{make doc/guix-cookbook.html} for the cookbook HTML version.
-@end itemize
-
 @cindex translation
 @cindex l10n
 @cindex i18n
@@ -2231,28 +1911,6 @@ Currently, some parts of Guix cannot be translated on Weblate, help wanted!
       translated.
 @end itemize
 
-@subsubheading Conditions for Inclusion
-
-There are no conditions for adding new translations of the @code{guix} and
-@code{guix-packages} components, other than they need at least one translated
-string.  New languages will be added to Guix as soon as possible.  The
-files may be removed if they fall out of sync and have no more translated
-strings.
-
-Given that the web site is dedicated to new users, we want its translation
-to be as complete as possible before we include it in the language menu.
-For a new language to be included, it needs to reach at least 80% completion.
-When a language is included, it may be removed in the future if it stays
-out of sync and falls below 60% completion.
-
-The manual and cookbook are automatically added in the default compilation
-target.  Every time we synchronize translations, developers need to
-recompile all the translated manuals and cookbooks.  This is useless for what
-is essentially the English manual or cookbook.  Therefore, we will only
-include a new language when it reaches 10% completion in the component.
-When a language is included, it may be removed in the future if it stays
-out of sync and falls below 5% completion.
-
 @subsubheading Translation Infrastructure
 
 Weblate is backed by a git repository from which it discovers new strings to

doc/guix-cookbook.texi

@@ -11,7 +11,7 @@
 @set SUBSTITUTE-TOR-URL https://4zwzi66wwdaalbhgnix55ea3ab4pvvw66ll2ow53kjub6se4q2bclcyd.onion
 
 @copying
-Copyright @copyright{} 2019, 2022 Ricardo Wurmus@*
+Copyright @copyright{} 2019 Ricardo Wurmus@*
 Copyright @copyright{} 2019 Efraim Flashner@*
 Copyright @copyright{} 2019 Pierre Neidhardt@*
 Copyright @copyright{} 2020 Oleg Pykhalov@*
@@ -21,7 +21,6 @@ Copyright @copyright{} 2020 Brice Waegeneire@*
 Copyright @copyright{} 2020 André Batista@*
 Copyright @copyright{} 2020 Christine Lemmer-Webber@*
 Copyright @copyright{} 2021 Joshua Branson@*
-Copyright @copyright{} 2022 Maxim Cournoyer*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -72,7 +71,6 @@ Weblate} (@pxref{Translating Guix,,, guix, GNU Guix reference manual}).
 * Scheme tutorials::            Meet your new favorite language!
 * Packaging::                   Packaging tutorials
 * System Configuration::        Customizing the GNU System
-* Containers::                  Isolated environments and nested systems
 * Advanced package management:: Power to the users!
 * Environment management::      Control environment
 
@@ -93,17 +91,8 @@ Packaging
 
 System Configuration
 
-* Auto-Login to a Specific TTY::    Automatically Login a User to a Specific TTY
-* Customizing the Kernel::          Creating and using a custom Linux kernel on Guix System.
-* Guix System Image API::           Customizing images to target specific platforms.
-* Using security keys::             How to use security keys with Guix System.
-* Connecting to Wireguard VPN::     Connecting to a Wireguard VPN.
-* Customizing a Window Manager::    Handle customization of a Window manager on Guix System.
-* Running Guix on a Linode Server:: Running Guix on a Linode Server.  Running Guix on a Linode Server
-* Setting up a bind mount::         Setting up a bind mount in the file-systems definition.
-* Getting substitutes from Tor::    Configuring Guix daemon to get substitutes through Tor.
-* Setting up NGINX with Lua::       Configuring NGINX web-server to load Lua modules.
-* Music Server with Bluetooth Audio:: Headless music player with Bluetooth output.
+* Auto-Login to a Specific TTY:: Automatically Login a User to a Specific TTY
+* Customizing the Kernel::       Creating and using a custom Linux kernel on Guix System.
 
 @end detailmenu
 @end menu
@@ -133,7 +122,7 @@ language, install it with @code{guix install guile} and start a
 @dfn{REPL}---short for @uref{https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop,
 @dfn{read-eval-print loop}}---by running @code{guile} from the command line.
 
-Alternatively you can also run @code{guix shell guile -- guile}
+Alternatively you can also run @code{guix environment --ad-hoc guile -- guile}
 if you'd rather not have Guile installed in your user profile.
 
 In the following examples, lines show what you would type at the REPL;
@@ -295,41 +284,24 @@ depends on the @code{(guix store)} module and it exports two variables,
 @code{ruby-build} and @code{ruby-build-system}.
 @end itemize
 
-@quotation Going further
-Scheme is a language that has been widely used to teach programming and
-you'll find plenty of material using it as a vehicle.  Here's a
-selection of documents to learn more about Scheme:
+For a more detailed introduction, check out
+@uref{http://www.troubleshooters.com/codecorn/scheme_guile/hello.htm, Scheme
+at a Glance}, by Steve Litt.
 
-@itemize
-@item
-@uref{https://spritely.institute/static/papers/scheme-primer.html, @i{A
-Scheme Primer}}, by Christine Lemmer-Webber and the Spritely Institute.
-
-@item
-@uref{http://www.troubleshooters.com/codecorn/scheme_guile/hello.htm,
-@i{Scheme at a Glance}}, by Steve Litt.
-
-@item
-@uref{https://mitpress.mit.edu/sites/default/files/sicp/index.html,
-@i{Structure and Interpretation of Computer Programs}}, by Harold
-Abelson and Gerald Jay Sussman, with Julie Sussman.  Colloquially known
-as ``SICP'', this book is a reference.
-
-You can also install it and read it from your computer:
-
-@example
-guix install sicp info-reader
-info sicp
-@end example
-
-An @uref{https://sarabander.github.io/sicp/, unofficial ebook} is also
-available.
-
-@end itemize
+One of the reference Scheme books is the seminal ``Structure and
+Interpretation of Computer Programs'', by Harold Abelson and Gerald Jay
+Sussman, with Julie Sussman.  You'll find a
+@uref{https://mitpress.mit.edu/sites/default/files/sicp/index.html, free copy
+online}, together with
+@uref{https://ocw.mit.edu/courses/electrical-engineering-and-computer-science/6-001-structure-and-interpretation-of-computer-programs-spring-2005/video-lectures/,
+videos of the lectures by the authors}.  The book is available in Texinfo
+format as the @code{sicp} Guix package.  Go ahead, run @code{guix install
+sicp} and start reading with @code{info sicp} (@pxref{,,, sicp, Structure and Interpretation of Computer Programs}).
+An @uref{https://sarabander.github.io/sicp/, unofficial ebook is also
+available}.
 
 You'll find more books, tutorials and other resources at
 @url{https://schemers.org/}.
-@end quotation
 
 
 @c *********************************************************************
@@ -931,7 +903,7 @@ Installed in the store and in the profile, as well as
 being present at build time.
 @end table
 
-@xref{package Reference,,, guix, GNU Guix Reference Manual} for more details.
+@xref{Package Reference,,, guix, GNU Guix Reference Manual} for more details.
 
 The distinction between the various inputs is important: if a dependency can be
 handled as an @emph{input} instead of a @emph{propagated input}, it should be done so, or
@@ -1382,14 +1354,12 @@ reference.
 * Auto-Login to a Specific TTY:: Automatically Login a User to a Specific TTY
 * Customizing the Kernel::       Creating and using a custom Linux kernel on Guix System.
 * Guix System Image API::        Customizing images to target specific platforms.
-* Using security keys::          How to use security keys with Guix System.
 * Connecting to Wireguard VPN::  Connecting to a Wireguard VPN.
 * Customizing a Window Manager:: Handle customization of a Window manager on Guix System.
 * Running Guix on a Linode Server:: Running Guix on a Linode Server
 * Setting up a bind mount:: Setting up a bind mount in the file-systems definition.
 * Getting substitutes from Tor:: Configuring Guix daemon to get substitutes through Tor.
 * Setting up NGINX with Lua:: Configuring NGINX web-server to load Lua modules.
-* Music Server with Bluetooth Audio:: Headless music player with Bluetooth output.
 @end menu
 
 @node Auto-Login to a Specific TTY
@@ -1630,7 +1600,7 @@ letting you know what you're missing.  If the file is blank then you're
 missing everything.  The next step is to run:
 
 @example shell
-guix shell -D linux-libre -- make localmodconfig
+guix environment linux-libre -- make localmodconfig
 @end example
 
 and note the output.  Do note that the @file{.config} file is still empty.
@@ -1886,65 +1856,6 @@ guix system image --image-type=hurd-qcow2 my-hurd-os.scm
 
 will instead produce a Hurd QEMU image.
 
-@node Using security keys
-@section Using security keys
-@cindex 2FA, two-factor authentication
-@cindex U2F, Universal 2nd Factor
-@cindex security key, configuration
-
-The use of security keys can improve your security by providing a second
-authentication source that cannot be easily stolen or copied, at least
-for a remote adversary (something that you have), to the main secret (a
-passphrase -- something that you know), reducing the risk of
-impersonation.
-
-The example configuration detailed below showcases what minimal
-configuration needs to be made on your Guix System to allow the use of a
-Yubico security key.  It is hoped the configuration can be useful for
-other security keys as well, with minor adjustments.
-
-@subsection Configuration for use as a two-factor authenticator (2FA)
-
-To be usable, the udev rules of the system should be extended with
-key-specific rules.  The following shows how to extend your udev rules
-with the @file{lib/udev/rules.d/70-u2f.rules} udev rule file provided by
-the @code{libfido2} package from the @code{(gnu packages
-security-token)} module and add your user to the @samp{"plugdev"} group
-it uses:
-
-@lisp
-(use-package-modules ... security-token ...)
-...
-(operating-system
- ...
- (users (cons* (user-account
-               (name "your-user")
-               (group "users")
-               (supplementary-groups
-		'("wheel" "netdev" "audio" "video"
-                  "plugdev"))           ;<- added system group
-               (home-directory "/home/your-user"))
-              %base-user-accounts))
- ...
- (services
-  (cons*
-   ...
-   (udev-rules-service 'fido2 libfido2 #:groups '("plugdev")))))
-@end lisp
-
-After re-configuring your system and re-logging in your graphical
-session so that the new group is in effect for your user, you can verify
-that your key is usable by launching:
-
-@example
-guix shell ungoogled-chromium -- chromium chrome://settings/securityKeys
-@end example
-
-and validating that the security key can be reset via the ``Reset your
-security key'' menu.  If it works, congratulations, your security key is
-ready to be used with applications supporting two-factor authentication
-(2FA).
-
 @node Connecting to Wireguard VPN
 @section Connecting to Wireguard VPN
 
@@ -2526,594 +2437,6 @@ ngx.say(stdout)
                                                         #$(local-file "index.lua"))))))))))))))
 @end lisp
 
-@node Music Server with Bluetooth Audio
-@section Music Server with Bluetooth Audio
-@cindex mpd
-@cindex music server, headless
-@cindex bluetooth, ALSA configuration
-
-MPD, the Music Player Daemon, is a flexible server-side application for
-playing music.  Client programs on different machines on the network ---
-a mobile phone, a laptop, a desktop workstation --- can connect to it to
-control the playback of audio files from your local music collection.
-MPD decodes the audio files and plays them back on one or many outputs.
-
-By default MPD will play to the default audio device.  In the example
-below we make things a little more interesting by setting up a headless
-music server.  There will be no graphical user interface, no Pulseaudio
-daemon, and no local audio output.  Instead we will configure MPD with
-two outputs: a bluetooth speaker and a web server to serve audio streams
-to any streaming media player.
-
-Bluetooth is often rather frustrating to set up.  You will have to pair
-your Bluetooth device and make sure that the device is automatically
-connected as soon as it powers on.  The Bluetooth system service
-returned by the @code{bluetooth-service} procedure provides the
-infrastructure needed to set this up.
-
-Reconfigure your system with at least the following services and
-packages:
-
-@lisp
-(operating-system
-  ;; …
-  (packages (cons* bluez bluez-alsa
-                   %base-packages))
-  (services
-   ;; …
-   (dbus-service #:services (list bluez-alsa))
-   (bluetooth-service #:auto-enable? #t)))
-@end lisp
-
-Start the @code{bluetooth} service and then use @command{bluetoothctl}
-to scan for Bluetooth devices.  Try to identify your Bluetooth speaker
-and pick out its device ID from the resulting list of devices that is
-indubitably dominated by a baffling smorgasbord of your neighbors' home
-automation gizmos.  This only needs to be done once:
-
-@example
-$ bluetoothctl 
-[NEW] Controller 00:11:22:33:95:7F BlueZ 5.40 [default]
-
-[bluetooth]# power on
-[bluetooth]# Changing power on succeeded
-
-[bluetooth]# agent on
-[bluetooth]# Agent registered
-
-[bluetooth]# default-agent
-[bluetooth]# Default agent request successful
-
-[bluetooth]# scan on
-[bluetooth]# Discovery started
-[CHG] Controller 00:11:22:33:95:7F Discovering: yes
-[NEW] Device AA:BB:CC:A4:AA:CD My Bluetooth Speaker
-[NEW] Device 44:44:FF:2A:20:DC My Neighbor's TV
-@dots{}
-
-[bluetooth]# pair AA:BB:CC:A4:AA:CD
-Attempting to pair with AA:BB:CC:A4:AA:CD
-[CHG] Device AA:BB:CC:A4:AA:CD Connected: yes
-
-[My Bluetooth Speaker]# [CHG] Device AA:BB:CC:A4:AA:CD UUIDs: 0000110b-0000-1000-8000-00xxxxxxxxxx
-[CHG] Device AA:BB:CC:A4:AA:CD UUIDs: 0000110c-0000-1000-8000-00xxxxxxxxxx
-[CHG] Device AA:BB:CC:A4:AA:CD UUIDs: 0000110e-0000-1000-8000-00xxxxxxxxxx
-[CHG] Device AA:BB:CC:A4:AA:CD Paired: yes
-Pairing successful
-
-[CHG] Device AA:BB:CC:A4:AA:CD Connected: no
-
-[bluetooth]# 
-[bluetooth]# trust AA:BB:CC:A4:AA:CD
-[bluetooth]# [CHG] Device AA:BB:CC:A4:AA:CD Trusted: yes
-Changing AA:BB:CC:A4:AA:CD trust succeeded
-
-[bluetooth]# 
-[bluetooth]# connect AA:BB:CC:A4:AA:CD
-Attempting to connect to AA:BB:CC:A4:AA:CD
-[bluetooth]# [CHG] Device AA:BB:CC:A4:AA:CD RSSI: -63
-[CHG] Device AA:BB:CC:A4:AA:CD Connected: yes
-Connection successful
-
-[My Bluetooth Speaker]# scan off
-[CHG] Device AA:BB:CC:A4:AA:CD RSSI is nil
-Discovery stopped
-[CHG] Controller 00:11:22:33:95:7F Discovering: no
-@end example
-
-Congratulations, you can now automatically connect to your Bluetooth
-speaker!
-
-It is now time to configure ALSA to use the @emph{bluealsa} Bluetooth
-module, so that you can define an ALSA pcm device corresponding to your
-Bluetooth speaker.  For a headless server using @emph{bluealsa} with a
-fixed Bluetooth device is likely simpler than configuring Pulseaudio and
-its stream switching behavior.  We configure ALSA by crafting a custom
-@code{alsa-configuration} for the @code{alsa-service-type}.  The
-configuration will declare a @code{pcm} type @code{bluealsa} from the
-@code{bluealsa} module provided by the @code{bluez-alsa} package, and
-then define a @code{pcm} device of that type for your Bluetooth speaker.
-
-All that is left then is to make MPD send audio data to this ALSA
-device.  We also add a secondary MPD output that makes the currently
-played audio files available as a stream through a web server on port
-8080.  When enabled a device on the network could listen to the audio
-stream by connecting any capable media player to the HTTP server on port
-8080, independent of the status of the Bluetooth speaker.
-
-What follows is the outline of an @code{operating-system} declaration
-that should accomplish the above-mentioned tasks:
-
-@lisp
-(use-modules (gnu))
-(use-service-modules audio dbus sound #;… etc)
-(use-package-modules audio linux #;… etc)
-(operating-system
-  ;; …
-  (packages (cons* bluez bluez-alsa
-                   %base-packages))
-  (services
-   ;; …
-   (service mpd-service-type
-            (mpd-configuration
-             (user "your-username")
-             (music-dir "/path/to/your/music")
-             (address "192.168.178.20")
-             (outputs (list (mpd-output
-                             (type "alsa")
-                             (name "MPD")
-                             (extra-options
-                              ;; Use the same name as in the ALSA
-                              ;; configuration below.
-                              '((device . "pcm.btspeaker"))))
-                            (mpd-output
-                             (type "httpd")
-                             (name "streaming")
-                             (enabled? #false)
-                             (always-on? #true)
-                             (tags? #true)
-                             (mixer-type 'null)
-                             (extra-options
-                              '((encoder . "vorbis")
-                                (port    . "8080")
-                                (bind-to-address . "192.168.178.20")
-                                (max-clients . "0") ;no limit
-                                (quality . "5.0")
-                                (format  . "44100:16:1"))))))))
-   (dbus-service #:services (list bluez-alsa))
-   (bluetooth-service #:auto-enable? #t)
-   (service alsa-service-type
-            (alsa-configuration
-             (pulseaudio? #false) ;we don't need it
-             (extra-options
-              #~(string-append "\
-# Declare Bluetooth audio device type \"bluealsa\" from bluealsa module
-pcm_type.bluealsa @{
-    lib \"" #$(file-append bluez-alsa "/lib/alsa-lib/libasound_module_pcm_bluealsa.so") "\"
-@}
-
-# Declare control device type \"bluealsa\" from the same module
-ctl_type.bluealsa @{
-    lib \"" #$(file-append bluez-alsa "/lib/alsa-lib/libasound_module_ctl_bluealsa.so") "\"
-@}
-
-# Define the actual Bluetooth audio device.
-pcm.btspeaker @{
-    type bluealsa
-    device \"AA:BB:CC:A4:AA:CD\" # unique device identifier
-    profile \"a2dp\"
-@}
-
-# Define an associated controller.
-ctl.btspeaker @{
-    type bluealsa
-@}
-"))))))
-@end lisp
-
-Enjoy the music with the MPD client of your choice or a media player
-capable of streaming via HTTP!
-
-
-@c *********************************************************************
-@node Containers
-@chapter Containers
-
-The kernel Linux provides a number of shared facilities that are
-available to processes in the system.  These facilities include a shared
-view on the file system, other processes, network devices, user and
-group identities, and a few others.  Since Linux 3.19 a user can choose
-to @emph{unshare} some of these shared facilities for selected
-processes, providing them (and their child processes) with a different
-view on the system.
-
-A process with an unshared @code{mount} namespace, for example, has its
-own view on the file system --- it will only be able to see directories
-that have been explicitly bound in its mount namespace.  A process with
-its own @code{proc} namespace will consider itself to be the only
-process running on the system, running as PID 1.
-
-Guix uses these kernel features to provide fully isolated environments
-and even complete Guix System containers, lightweight virtual machines
-that share the host system's kernel.  This feature comes in especially
-handy when using Guix on a foreign distribution to prevent interference
-from foreign libraries or configuration files that are available
-system-wide.
-
-@menu
-* Guix Containers::            Perfectly isolated environments
-* Guix System Containers::     A system inside your system
-@end menu
-
-@node Guix Containers
-@section Guix Containers
-
-The easiest way to get started is to use @command{guix shell} with the
-@option{--container} option.  @xref{Invoking guix shell,,, guix, GNU
-Guix Reference Manual} for a reference of valid options.
-
-The following snippet spawns a minimal shell process with most
-namespaces unshared from the system.  The current working directory is
-visible to the process, but anything else on the file system is
-unavailable.  This extreme isolation can be very useful when you want to
-rule out any sort of interference from environment variables, globally
-installed libraries, or configuration files.
-
-@example
-guix shell --container
-@end example
-
-It is a bleak environment, barren, desolate.  You will find that not
-even the GNU coreutils are available here, so to explore this deserted
-wasteland you need to use built-in shell commands.  Even the usually
-gigantic @file{/gnu/store} directory is reduced to a faint shadow of
-itself.
-
-@example sh
-$ echo /gnu/store/*
-/gnu/store/@dots{}-gcc-10.3.0-lib
-/gnu/store/@dots{}-glibc-2.33
-/gnu/store/@dots{}-bash-static-5.1.8
-/gnu/store/@dots{}-ncurses-6.2.20210619
-/gnu/store/@dots{}-bash-5.1.8
-/gnu/store/@dots{}-profile
-/gnu/store/@dots{}-readline-8.1.1
-@end example
-
-@cindex exiting a container
-There isn't much you can do in an environment like this other than
-exiting it.  You can use @key{^D} or @command{exit} to terminate this
-limited shell environment.
-
-@cindex exposing directories, container
-@cindex sharing directories, container
-@cindex mapping locations, container
-You can make other directories available inside of the container
-environment; use @option{--expose=DIRECTORY} to bind-mount the given
-directory as a read-only location inside the container, or use
-@option{--share=DIRECTORY} to make the location writable.  With an
-additional mapping argument after the directory name you can control the
-name of the directory inside the container.  In the following example we
-map @file{/etc} on the host system to @file{/the/host/etc} inside a
-container in which the GNU coreutils are installed.
-
-@example sh
-$ guix shell --container --share=/etc=/the/host/etc coreutils
-$ ls /the/host/etc
-@end example
-
-Similarly, you can prevent the current working directory from being
-mapped into the container with the @option{--no-cwd} option.  Another
-good idea is to create a dedicated directory that will serve as the
-container's home directory, and spawn the container shell from that
-directory.
-
-@cindex hide system libraries, container
-@cindex avoid ABI mismatch, container
-On a foreign system a container environment can be used to compile
-software that cannot possibly be linked with system libraries or with
-the system's compiler toolchain.  A common use-case in a research
-context is to install packages from within an R session.  Outside of a
-container environment there is a good chance that the foreign compiler
-toolchain and incompatible system libraries are found first, resulting
-in incompatible binaries that cannot be used by R.  In a container shell
-this problem disappears, as system libraries and executables simply
-aren't available due to the unshared @code{mount} namespace.
-
-Let's take a comprehensive manifest providing a comfortable development
-environment for use with R:
-
-@lisp
-(specifications->manifest
-  (list "r-minimal"
-
-        ;; base packages
-        "bash-minimal"
-        "glibc-locales"
-        "nss-certs"
-
-        ;; Common command line tools lest the container is too empty.
-        "coreutils"
-        "grep"
-        "which"
-        "wget"
-        "sed"
-
-        ;; R markdown tools
-        "pandoc"
-
-        ;; Toolchain and common libraries for "install.packages"
-        "gcc-toolchain@@10"
-        "gfortran-toolchain"
-        "gawk"
-        "tar"
-        "gzip"
-        "unzip"
-        "make"
-        "cmake"
-        "pkg-config"
-        "cairo"
-        "libxt"
-        "openssl"
-        "curl"
-        "zlib"))
-@end lisp
-
-Let's use this to run R inside a container environment.  For convenience
-we share the @code{net} namespace to use the host system's network
-interfaces.  Now we can build R packages from source the traditional way
-without having to worry about ABI mismatch or incompatibilities.
-
-@example sh
-$ guix shell --container --network --manifest=manifest.scm -- R
-
-R version 4.2.1 (2022-06-23) -- "Funny-Looking Kid"
-Copyright (C) 2022 The R Foundation for Statistical Computing
-@dots{}
-> e <- Sys.getenv("GUIX_ENVIRONMENT")
-> Sys.setenv(GIT_SSL_CAINFO=paste0(e, "/etc/ssl/certs/ca-certificates.crt"))
-> Sys.setenv(SSL_CERT_FILE=paste0(e, "/etc/ssl/certs/ca-certificates.crt"))
-> Sys.setenv(SSL_CERT_DIR=paste0(e, "/etc/ssl/certs"))
-> install.packages("Cairo", lib=paste0(getwd()))
-@dots{}
-* installing *source* package 'Cairo' ...
-@dots{}
-* DONE (Cairo)
-
-The downloaded source packages are in
-	'/tmp/RtmpCuwdwM/downloaded_packages'
-> library("Cairo", lib=getwd())
-> # success!
-@end example
-
-Using container shells is fun, but they can become a little cumbersome
-when you want to go beyond just a single interactive process.  Some
-tasks become a lot easier when they sit on the rock solid foundation of
-a proper Guix System and its rich set of system services.  The next
-section shows you how to launch a complete Guix System inside of a
-container.
-
-
-@node Guix System Containers
-@section Guix System Containers
-
-The Guix System provides a wide array of interconnected system services
-that are configured declaratively to form a dependable stateless GNU
-System foundation for whatever tasks you throw at it.  Even when using
-Guix on a foreign distribution you can benefit from the design of Guix
-System by running a system instance as a container.  Using the same
-kernel features of unshared namespaces mentioned in the previous
-section, the resulting Guix System instance is isolated from the host
-system and only shares file system locations that you explicitly
-declare.
-
-A Guix System container differs from the shell process created by
-@command{guix shell --container} in a number of important ways.  While
-in a container shell the containerized process is a Bash shell process,
-a Guix System container runs the Shepherd as PID 1.  In a system
-container all system services (@pxref{Services,,, guix, GNU Guix
-Reference Manual}) are set up just as they would be on a Guix System in
-a virtual machine or on bare metal---this includes daemons managed by
-the GNU@tie{}Shepherd (@pxref{Shepherd Services,,, guix, GNU Guix
-Reference Manual}) as well as other kinds of extensions to the operating
-system (@pxref{Service Composition,,, guix, GNU Guix Reference Manual}).
-
-The perceived increase in complexity of running a Guix System container
-is easily justified when dealing with more complex applications that
-have higher or just more rigid requirements on their execution
-contexts---configuration files, dedicated user accounts, directories for
-caches or log files, etc.  In Guix System the demands of this kind of
-software are satisfied through the deployment of system services.
-
-
-@node A Database Container
-@subsection A Database Container
-
-A good example might be a PostgreSQL database server.  Much of the
-complexity of setting up such a database server is encapsulated in this
-deceptively short service declaration:
-
-@lisp
-(service postgresql-service-type
-         (postgresql-configuration
-          (postgresql postgresql-14)))
-@end lisp
-
-A complete operating system declaration for use with a Guix System
-container would look something like this:
-
-@lisp
-(use-modules (gnu))
-(use-package-modules databases)
-(use-service-modules databases)
-
-(operating-system
-  (host-name "container")
-  (timezone "Europe/Berlin")
-  (file-systems (cons (file-system
-                        (device (file-system-label "does-not-matter"))
-                        (mount-point "/")
-                        (type "ext4"))
-                      %base-file-systems))
-  (bootloader (bootloader-configuration
-               (bootloader grub-bootloader)
-               (targets '("/dev/sdX"))))
-  (services
-   (cons* (service postgresql-service-type
-                   (postgresql-configuration
-                    (postgresql postgresql-14)
-                    (config-file
-                     (postgresql-config-file
-                      (log-destination "stderr")
-                      (hba-file
-                       (plain-file "pg_hba.conf"
-                                   "\
-local	all	all			trust
-host	all	all	10.0.0.1/32 	trust"))
-                      (extra-config
-                       '(("listen_addresses" "*")
-                         ("log_directory"    "/var/log/postgresql")))))))
-          (service postgresql-role-service-type
-                   (postgresql-role-configuration
-                    (roles
-                     (list (postgresql-role
-                            (name "test")
-                            (create-database? #t))))))
-          %base-services)))
-@end lisp
-
-With @code{postgresql-role-service-type} we define a role ``test'' and
-create a matching database, so that we can test right away without any
-further manual setup.  The @code{postgresql-config-file} settings allow
-a client from IP address 10.0.0.1 to connect without requiring
-authentication---a bad idea in production systems, but convenient for
-this example.
-
-Let's build a script that will launch an instance of this Guix System as
-a container.  Write the @code{operating-system} declaration above to a
-file @file{os.scm} and then use @command{guix system container} to build
-the launcher.  (@pxref{Invoking guix system,,, guix, GNU Guix Reference
-Manual}).
-
-@example
-$ guix system container os.scm
-The following derivations will be built:
-  /gnu/store/@dots{}-run-container.drv
-  @dots{}
-building /gnu/store/@dots{}-run-container.drv...
-/gnu/store/@dots{}-run-container
-@end example
-
-Now that we have a launcher script we can run it to spawn the new system
-with a running PostgreSQL service.  Note that due to some as yet
-unresolved limitations we need to run the launcher as the root user, for
-example with @command{sudo}.
-
-@example
-$ sudo /gnu/store/@dots{}-run-container
-system container is running as PID 5983
-@dots{}
-@end example
-
-Background the process with @key{Ctrl-z} followed by @command{bg}.  Note
-the process ID in the output; we will need it to connect to the
-container later.  You know what?  Let's try attaching to the container
-right now.  We will use @command{nsenter}, a tool provided by the
-@code{util-linux} package:
-
-@example
-$ guix shell util-linux
-$ sudo nsenter -a -t 5983
-root@@container /# pgrep -a postgres
-49 /gnu/store/@dots{}-postgresql-14.4/bin/postgres -D /var/lib/postgresql/data --config-file=/gnu/store/@dots{}-postgresql.conf -p 5432
-51 postgres: checkpointer
-52 postgres: background writer
-53 postgres: walwriter
-54 postgres: autovacuum launcher
-55 postgres: stats collector
-56 postgres: logical replication launcher
-root@@container /# exit
-@end example
-
-The PostgreSQL service is running in the container!
-
-
-@node Container Networking
-@subsection Container Networking
-@cindex container networking
-
-What good is a Guix System running a PostgreSQL database service as a
-container when we can only talk to it with processes originating in the
-container?  It would be much better if we could talk to the database
-over the network.
-
-The easiest way to do this is to create a pair of connected virtual
-Ethernet devices (known as @code{veth}).  We move one of the devices
-(@code{ceth-test}) into the @code{net} namespace of the container and
-leave the other end (@code{veth-test}) of the connection on the host
-system.
-
-@example
-pid=5983
-ns="guix-test"
-host="veth-test"
-client="ceth-test"
-
-# Attach the new net namespace "guix-test" to the container PID.
-sudo ip netns attach $ns $pid
-
-# Create the pair of devices
-sudo ip link add $host type veth peer name $client
-
-# Move the client device into the container's net namespace
-sudo ip link set $client netns $ns
-@end example
-
-Then we configure the host side:
-
-@example
-sudo ip link set $host up
-sudo ip addr add 10.0.0.1/24 dev $host
-@end example
-
-@dots{}and then we configure the client side:
-
-@example
-sudo ip netns exec $ns  ip link set lo up
-sudo ip netns exec $ns  ip link set $client up
-sudo ip netns exec $ns  ip addr add 10.0.0.2/24 dev $client
-@end example
-
-At this point the host can reach the container at IP address 10.0.0.2,
-and the container can reach the host at IP 10.0.0.1.  This is all we
-need to talk to the database server inside the container from the host
-system on the outside.
-
-@example
-$ psql -h 10.0.0.2 -U test
-psql (14.4)
-Type "help" for help.
-
-test=> CREATE TABLE hello (who TEXT NOT NULL);
-CREATE TABLE
-test=> INSERT INTO hello (who) VALUES ('world');
-INSERT 0 1
-test=> SELECT * FROM hello;
-  who
--------
- world
-(1 row)
-@end example
-
-Now that we're done with this little demonstration let's clean up:
-
-@example
-sudo kill $pid
-sudo ip netns del $ns
-sudo ip link del $host
-@end example
-
-
 @c *********************************************************************
 @node Advanced package management
 @chapter Advanced package management
@@ -3210,9 +2533,8 @@ Let's dive in the set up!
 @node Basic setup with manifests
 @subsection Basic setup with manifests
 
-A Guix profile can be set up @i{via} a @dfn{manifest}.  A manifest is a
-snippet of Scheme code that specifies the set of packages you want to
-have in your profile; it looks like this:
+A Guix profile can be set up @emph{via} a so-called @emph{manifest specification} that looks like
+this:
 
 @lisp
 (specifications->manifest
@@ -3225,8 +2547,8 @@ have in your profile; it looks like this:
     "package-N"))
 @end lisp
 
-@xref{Writing Manifests,,, guix, GNU Guix Reference Manual}, for
-more information about the syntax.
+@pxref{Invoking guix package,,, guix, GNU Guix Reference Manual}, for
+the syntax details.
 
 We can create a manifest specification per profile and install them this way:
 
@@ -3464,7 +2786,7 @@ Maybe a dependency from our manifest has been updated; or we may have run
 garbage-collected.
 
 @item
-Eventually, we set to work on that project again, so we run @code{guix shell
+Eventually, we set to work on that project again, so we run @code{guix environment
    -m manifest.scm}.  But now we have to wait for Guix to build and install
 stuff!
 @end enumerate
@@ -3503,8 +2825,8 @@ to reproduce the exact same profile:
 GUIX_EXTRA_PROFILES=$HOME/.guix-extra-profiles
 GUIX_EXTRA=$HOME/.guix-extra
 
-mkdir -p "$GUIX_EXTRA"/my-project
-guix pull --channels=channel-specs.scm --profile="$GUIX_EXTRA/my-project/guix"
+mkdir "$GUIX_EXTRA"/my-project
+guix pull --channels=channel-specs.scm --profile "$GUIX_EXTRA/my-project/guix"
 
 mkdir -p "$GUIX_EXTRA_PROFILES/my-project"
 "$GUIX_EXTRA"/my-project/guix/bin/guix package --manifest=/path/to/guix-my-project-manifest.scm --profile="$GUIX_EXTRA_PROFILES"/my-project/my-project

doc/he-config-bare-bones.scm

@@ -13,13 +13,12 @@
    (service home-bash-service-type
             (home-bash-configuration
              (guix-defaults? #t)
-             (bash-profile (list (plain-file "bash-profile" "\
-export HISTFILE=$XDG_CACHE_HOME/.bash_history")))))
+             (bash-profile '("\
+export HISTFILE=$XDG_CACHE_HOME/.bash_history"))))
 
    (simple-service 'test-config
-                   home-xdg-configuration-files-service-type
-                   (list `("test.conf"
+                   home-files-service-type
+                   (list `("config/test.conf"
                            ,(plain-file "tmp-file.txt"
-                                        "the content of
-                                          ~/.config/test.conf")))))))
+                                        "the content of ~/.config/test.conf")))))))
 

doc/htmlxref.cnf

@@ -1,9 +1,9 @@
 # htmlxref.cnf - reference file for free Texinfo manuals on the web.
 # Modified by Ludovic Courtès <ludo@gnu.org> for the GNU Guix manual.
 
-htmlxrefversion=2026-01-19.09; # UTC
+htmlxrefversion=2021-09-24.23; # UTC
 
-# Copyright 2010-2020, 2022 Free Software Foundation, Inc.
+# Copyright 2010-2020 Free Software Foundation, Inc.
 # 
 # Copying and distribution of this file, with or without modification,
 # are permitted in any medium without royalty provided the copyright
@@ -291,6 +291,8 @@ gdbm		chapter	${GDBM}/html_chapter/
 gdbm		section ${GDBM}/html_section/
 gdbm		node	${GDBM}/html_node/
 
+# XXX: These are actually pages created by texi2html, so no quite following
+# the expected naming scheme.
 geiser		chapter	http://geiser.nongnu.org/
 
 gettext		mono	${GS}/gettext/manual/gettext.html
@@ -409,21 +411,16 @@ GUILE_GNOME = ${GS}/guile-gnome/docs
 
 guile-gtk	node	${GS}/guile-gtk/docs/guile-gtk/
 
-guile-netlink	mono	https://git.lepiller.eu/guile-netlink/manual/manual.html
-
 guile-rpc	mono	${GS}/guile-rpc/manual/guile-rpc.html
 guile-rpc	node	${GS}/guile-rpc/manual/html_node/
 
-GUIX_ROOT = https://guix.gnu.org
-GUIX = ${GUIX_ROOT}/manual/1.4.0
+GUIX = ${GS}/guix/manual
  guix.de	mono	${GUIX}/de/guix.de.html
  guix.de	node	${GUIX}/de/html_node/
  guix.es	mono	${GUIX}/es/guix.es.html
  guix.es	node	${GUIX}/es/html_node/
  guix.fr	mono	${GUIX}/fr/guix.fr.html
  guix.fr	node	${GUIX}/fr/html_node/
- guix.pt_BR	mono	${GUIX}/pt-br/guix.pt_BR.html
- guix.pt_BR	node	${GUIX}/pt-br/html_node/
  guix.ru	mono	${GUIX}/ru/guix.ru.html
  guix.ru	node	${GUIX}/ru/html_node/
  guix.zh_CN	mono	${GUIX}/zh-cn/guix.zh_CN.html
@@ -431,13 +428,11 @@ GUIX = ${GUIX_ROOT}/manual/1.4.0
  guix		mono	${GUIX}/en/guix.html
  guix		node	${GUIX}/en/html_node/
 
-GUIX_COOKBOOK = ${GUIX_ROOT}/cookbook
- guix-cookbook.de	mono	${GUIX_COOKBOOK}/de/guix-cookbook.de.html
+GUIX_COOKBOOK = ${GS}/guix/cookbook
+ guix-cookbook.de	mono	${GUIX_COOKBOOK}/de/guix-cookbook.html
  guix-cookbook.de	node    ${GUIX_COOKBOOK}/de/html_node/
- guix-cookbook.fr	mono    ${GUIX_COOKBOOK}/fr/guix-cookbook.fr.html
+ guix-cookbook.fr	mono    ${GUIX_COOKBOOK}/fr/guix-cookbook.html
  guix-cookbook.fr	node    ${GUIX_COOKBOOK}/fr/html_node/
- guix-cookbook.sk	mono    ${GUIX_COOKBOOK}/sk/guix-cookbook.sk.html
- guix-cookbook.sk	node    ${GUIX_COOKBOOK}/sk/html_node/
  guix-cookbook		mono    ${GUIX_COOKBOOK}/en/guix-cookbook.html
  guix-cookbook		node	${GUIX_COOKBOOK}/en/html_node/
 

doc/images/gcc-core-mesboot0-graph.dot

@@ -1,114 +1,79 @@
 digraph "Guix package" {
-  "139781154519456" [label = "gcc-core-mesboot0@2.95.3", shape = box, fontname = Helvetica];
-  "139781154519456" -> "139781154519632" [color = darkgoldenrod];
-  "139781154519456" -> "139781154520688" [color = darkgoldenrod];
-  "139781154519456" -> "139781034971312" [color = darkgoldenrod];
-  "139781154519456" -> "139781154520160" [color = darkgoldenrod];
-  "139781154519456" -> "139781034971664" [color = darkgoldenrod];
-  "139781154519456" -> "139781154519984" [color = darkgoldenrod];
-  "139781154519456" -> "139781154519808" [color = darkgoldenrod];
-  "139781154519456" -> "139781154520512" [color = darkgoldenrod];
-  "139781154519456" -> "139781034971488" [color = darkgoldenrod];
-  "139781154519456" -> "139781034972896" [color = darkgoldenrod];
-  "139781154519456" -> "139781034972368" [color = darkgoldenrod];
-  "139781154519456" -> "139781034973072" [color = darkgoldenrod];
-  "139781154519456" -> "139781131267872" [color = darkgoldenrod];
-  "139781154519632" [label = "binutils-mesboot0@2.14", shape = box, fontname = Helvetica];
-  "139781154519632" -> "139781154520688" [color = peachpuff4];
-  "139781154519632" -> "139781034971312" [color = peachpuff4];
-  "139781154519632" -> "139781154520160" [color = peachpuff4];
-  "139781154519632" -> "139781034971664" [color = peachpuff4];
-  "139781154519632" -> "139781154519984" [color = peachpuff4];
-  "139781154519632" -> "139781154519808" [color = peachpuff4];
-  "139781154519632" -> "139781154520512" [color = peachpuff4];
-  "139781154519632" -> "139781034971488" [color = peachpuff4];
-  "139781154519632" -> "139781034972896" [color = peachpuff4];
-  "139781154519632" -> "139781034972368" [color = peachpuff4];
-  "139781154519632" -> "139781034973072" [color = peachpuff4];
-  "139781154519632" -> "139781131267872" [color = peachpuff4];
-  "139781154520688" [label = "bash-mesboot0@2.05b", shape = box, fontname = Helvetica];
-  "139781154520688" -> "139781034971488" [color = magenta];
-  "139781154520688" -> "139781034971840" [color = magenta];
-  "139781154520688" -> "139781034972896" [color = magenta];
-  "139781154520688" -> "139781034972368" [color = magenta];
-  "139781154520688" -> "139781034973072" [color = magenta];
-  "139781154520688" -> "139781131267872" [color = magenta];
-  "139781034971488" [label = "make-mesboot0@3.80", shape = box, fontname = Helvetica];
-  "139781034971488" -> "139781034971840" [color = dimgrey];
-  "139781034971488" -> "139781034972896" [color = dimgrey];
-  "139781034971488" -> "139781034972368" [color = dimgrey];
-  "139781034971488" -> "139781034973072" [color = dimgrey];
-  "139781034971488" -> "139781131267872" [color = dimgrey];
-  "139781034971840" [label = "tcc-boot0@0.9.26-1103-g6e62e0e", shape = box, fontname = Helvetica];
-  "139781034971840" -> "139781034972016" [color = magenta];
-  "139781034971840" -> "139781131266816" [color = magenta];
-  "139781034971840" -> "139781034972896" [color = magenta];
-  "139781034971840" -> "139781034972368" [color = magenta];
-  "139781034971840" -> "139781034973072" [color = magenta];
-  "139781034971840" -> "139781131267872" [color = magenta];
-  "139781034972016" [label = "mes-boot@0.22", shape = box, fontname = Helvetica];
-  "139781034972016" -> "139781034972192" [color = cyan3];
-  "139781034972016" -> "139781131266816" [color = cyan3];
-  "139781034972016" -> "139781034972896" [color = cyan3];
-  "139781034972016" -> "139781034972368" [color = cyan3];
-  "139781034972016" -> "139781034973072" [color = cyan3];
-  "139781034972016" -> "139781131267872" [color = cyan3];
-  "139781034972192" [label = "bootstrap-mes-rewired@0.19", shape = ellipse, fontname = Helvetica];
-  "139781034972192" -> "139781131266640" [color = darkseagreen];
-  "139781034972192" -> "139781034972896" [color = darkseagreen];
-  "139781131266640" [label = "bootstrap-mes@0", shape = ellipse, fontname = Helvetica];
-  "139781034972896" [label = "gash-boot@0.2.0", shape = box, fontname = Helvetica];
-  "139781034972896" -> "139781034973072" [color = darkviolet];
-  "139781034972896" -> "139781131267872" [color = darkviolet];
-  "139781034973072" [label = "bootar@1", shape = box, fontname = Helvetica];
-  "139781034973072" -> "139781131267872" [color = darkviolet];
-  "139781131267872" [label = "guile-bootstrap@2.0", shape = ellipse, fontname = Helvetica];
-  "139781131266816" [label = "bootstrap-mescc-tools@0.5.2", shape = ellipse, fontname = Helvetica];
-  "139781034972368" [label = "gash-utils-boot@0.1.0", shape = box, fontname = Helvetica];
-  "139781034972368" -> "139781034973072" [color = darkseagreen];
-  "139781034972368" -> "139781034972896" [color = darkseagreen];
-  "139781034972368" -> "139781131267872" [color = darkseagreen];
-  "139781034971312" [label = "bzip2-mesboot@1.0.8", shape = box, fontname = Helvetica];
-  "139781034971312" -> "139781034971488" [color = cyan3];
-  "139781034971312" -> "139781034971840" [color = cyan3];
-  "139781034971312" -> "139781034972896" [color = cyan3];
-  "139781034971312" -> "139781034972368" [color = cyan3];
-  "139781034971312" -> "139781034973072" [color = cyan3];
-  "139781034971312" -> "139781131267872" [color = cyan3];
-  "139781154520160" [label = "diffutils-mesboot@2.7", shape = box, fontname = Helvetica];
-  "139781154520160" -> "139781034971488" [color = red];
-  "139781154520160" -> "139781034971840" [color = red];
-  "139781154520160" -> "139781034972896" [color = red];
-  "139781154520160" -> "139781034972368" [color = red];
-  "139781154520160" -> "139781034973072" [color = red];
-  "139781154520160" -> "139781131267872" [color = red];
-  "139781034971664" [label = "gzip-mesboot@1.2.4", shape = box, fontname = Helvetica];
-  "139781034971664" -> "139781034971840" [color = red];
-  "139781034971664" -> "139781034972896" [color = red];
-  "139781034971664" -> "139781034972368" [color = red];
-  "139781034971664" -> "139781034973072" [color = red];
-  "139781034971664" -> "139781131267872" [color = red];
-  "139781154519984" [label = "patch-mesboot@2.5.9", shape = box, fontname = Helvetica];
-  "139781154519984" -> "139781034971488" [color = blue];
-  "139781154519984" -> "139781034971840" [color = blue];
-  "139781154519984" -> "139781034972896" [color = blue];
-  "139781154519984" -> "139781034972368" [color = blue];
-  "139781154519984" -> "139781034973072" [color = blue];
-  "139781154519984" -> "139781131267872" [color = blue];
-  "139781154519808" [label = "sed-mesboot0@1.18", shape = box, fontname = Helvetica];
-  "139781154519808" -> "139781034971488" [color = red];
-  "139781154519808" -> "139781034971840" [color = red];
-  "139781154519808" -> "139781034972896" [color = red];
-  "139781154519808" -> "139781034972368" [color = red];
-  "139781154519808" -> "139781034973072" [color = red];
-  "139781154519808" -> "139781131267872" [color = red];
-  "139781154520512" [label = "tcc-boot@0.9.27", shape = box, fontname = Helvetica];
-  "139781154520512" -> "139781034971312" [color = darkviolet];
-  "139781154520512" -> "139781034971488" [color = darkviolet];
-  "139781154520512" -> "139781034971840" [color = darkviolet];
-  "139781154520512" -> "139781034972896" [color = darkviolet];
-  "139781154520512" -> "139781034972368" [color = darkviolet];
-  "139781154520512" -> "139781034973072" [color = darkviolet];
-  "139781154520512" -> "139781131267872" [color = darkviolet];
+  "139803511371136" [label = "gcc-core-mesboot0@2.95.3", shape = box, fontname = sans];
+  "139803511371136" -> "139803511371312" [color = red];
+  "139803511371136" -> "139803511372016" [color = red];
+  "139803511371136" -> "139803511371488" [color = red];
+  "139803511371136" -> "139803511371664" [color = red];
+  "139803511371136" -> "139803511371840" [color = red];
+  "139803511371136" -> "139803507105792" [color = red];
+  "139803511371136" -> "139803511373600" [color = red];
+  "139803511371136" -> "139803507105968" [color = red];
+  "139803511371136" -> "139803749199472" [color = red];
+  "139803511371312" [label = "binutils-mesboot0@2.20.1a", shape = box, fontname = sans];
+  "139803511371312" -> "139803511372016" [color = dimgrey];
+  "139803511371312" -> "139803511371488" [color = dimgrey];
+  "139803511371312" -> "139803511371664" [color = dimgrey];
+  "139803511371312" -> "139803511371840" [color = dimgrey];
+  "139803511371312" -> "139803507105792" [color = dimgrey];
+  "139803511371312" -> "139803511373600" [color = dimgrey];
+  "139803511371312" -> "139803507105968" [color = dimgrey];
+  "139803511371312" -> "139803749199472" [color = dimgrey];
+  "139803511372016" [label = "gzip-mesboot@1.2.4", shape = box, fontname = sans];
+  "139803511372016" -> "139803511372192" [color = magenta];
+  "139803511372016" -> "139803507105792" [color = magenta];
+  "139803511372016" -> "139803511373600" [color = magenta];
+  "139803511372016" -> "139803507105968" [color = magenta];
+  "139803511372016" -> "139803749199472" [color = magenta];
+  "139803511372192" [label = "tcc-boot0@0.9.26-1136-g5bba73cc", shape = box, fontname = sans];
+  "139803511372192" -> "139803511372368" [color = magenta];
+  "139803511372192" -> "139803511372544" [color = magenta];
+  "139803511372192" -> "139803507105792" [color = magenta];
+  "139803511372192" -> "139803511373600" [color = magenta];
+  "139803511372192" -> "139803507105968" [color = magenta];
+  "139803511372192" -> "139803749199472" [color = magenta];
+  "139803511372368" [label = "mes-boot@0.24", shape = box, fontname = sans];
+  "139803511372368" -> "139803511372544" [color = darkviolet];
+  "139803511372368" -> "139803507105792" [color = darkviolet];
+  "139803511372368" -> "139803511373600" [color = darkviolet];
+  "139803511372368" -> "139803507105968" [color = darkviolet];
+  "139803511372368" -> "139803749199472" [color = darkviolet];
+  "139803511372544" [label = "stage0-posix@1.4", shape = box, fontname = sans];
+  "139803511372544" -> "139803511373072" [color = peachpuff4];
+  "139803511372544" -> "139803507105792" [color = peachpuff4];
+  "139803511372544" -> "139803511373600" [color = peachpuff4];
+  "139803511372544" -> "139803507105968" [color = peachpuff4];
+  "139803511372544" -> "139803749199472" [color = peachpuff4];
+  "139803511373072" [label = "bootstrap-seeds@1.0.0", shape = ellipse, fontname = sans];
+  "139803511373072" -> "139803507105968" [color = cyan3];
+  "139803507105968" [label = "bootar@1b", shape = box, fontname = sans];
+  "139803507105968" -> "139803749199472" [color = dimgrey];
+  "139803749199472" [label = "guile-bootstrap@2.0", shape = ellipse, fontname = sans];
+  "139803507105792" [label = "gash-boot@0.3.0", shape = box, fontname = sans];
+  "139803507105792" -> "139803507105968" [color = darkviolet];
+  "139803507105792" -> "139803749199472" [color = darkviolet];
+  "139803511373600" [label = "gash-utils-boot@0.2.0", shape = box, fontname = sans];
+  "139803511373600" -> "139803507105968" [color = red];
+  "139803511373600" -> "139803507105792" [color = red];
+  "139803511373600" -> "139803749199472" [color = red];
+  "139803511371488" [label = "patch-mesboot@2.5.9", shape = box, fontname = sans];
+  "139803511371488" -> "139803511371840" [color = darkseagreen];
+  "139803511371488" -> "139803511372192" [color = darkseagreen];
+  "139803511371488" -> "139803507105792" [color = darkseagreen];
+  "139803511371488" -> "139803511373600" [color = darkseagreen];
+  "139803511371488" -> "139803507105968" [color = darkseagreen];
+  "139803511371488" -> "139803749199472" [color = darkseagreen];
+  "139803511371840" [label = "make-mesboot0@3.80", shape = box, fontname = sans];
+  "139803511371840" -> "139803511372192" [color = blue];
+  "139803511371840" -> "139803507105792" [color = blue];
+  "139803511371840" -> "139803511373600" [color = blue];
+  "139803511371840" -> "139803507105968" [color = blue];
+  "139803511371840" -> "139803749199472" [color = blue];
+  "139803511371664" [label = "tcc-boot@0.9.27", shape = box, fontname = sans];
+  "139803511371664" -> "139803511371840" [color = peachpuff4];
+  "139803511371664" -> "139803511372192" [color = peachpuff4];
+  "139803511371664" -> "139803507105792" [color = peachpuff4];
+  "139803511371664" -> "139803511373600" [color = peachpuff4];
+  "139803511371664" -> "139803507105968" [color = peachpuff4];
+  "139803511371664" -> "139803749199472" [color = peachpuff4];
 
 }

doc/local.mk

@@ -22,8 +22,8 @@
 # along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 # If adding a language, update the following variables, and info_TEXINFOS.
-MANUAL_LANGUAGES = de es fr pt_BR ru zh_CN
-COOKBOOK_LANGUAGES = de fr ko sk
+MANUAL_LANGUAGES = de es fa fi fr it ko pt_BR ru sk zh_CN
+COOKBOOK_LANGUAGES = de es fa fi fr ko pt_BR ru sk uk zh_Hans
 
 # Arg1: A list of languages codes.
 # Arg2: The file name stem.
@@ -34,15 +34,27 @@ lang_to_texinfo = $(foreach lang,$(1),%D%/$(2).$(lang).texi)
 info_TEXINFOS = %D%/guix.texi			\
   %D%/guix.de.texi				\
   %D%/guix.es.texi				\
+  %D%/guix.fa.texi				\
+  %D%/guix.fi.texi				\
   %D%/guix.fr.texi				\
+  %D%/guix.it.texi				\
+  %D%/guix.ko.texi				\
   %D%/guix.pt_BR.texi				\
   %D%/guix.ru.texi				\
+  %D%/guix.sk.texi				\
   %D%/guix.zh_CN.texi				\
   %D%/guix-cookbook.texi			\
   %D%/guix-cookbook.de.texi			\
+  %D%/guix-cookbook.es.texi			\
+  %D%/guix-cookbook.fa.texi			\
+  %D%/guix-cookbook.fi.texi			\
   %D%/guix-cookbook.fr.texi			\
   %D%/guix-cookbook.ko.texi			\
-  %D%/guix-cookbook.sk.texi
+  %D%/guix-cookbook.pt_BR.texi			\
+  %D%/guix-cookbook.ru.texi			\
+  %D%/guix-cookbook.sk.texi			\
+  %D%/guix-cookbook.uk.texi			\
+  %D%/guix-cookbook.zh_Hans.texi
 
 %C%_guix_TEXINFOS = \
   %D%/contributing.texi \
@@ -179,31 +191,19 @@ sub_commands_mans =				\
   $(srcdir)/%D%/guix-archive.1			\
   $(srcdir)/%D%/guix-build.1			\
   $(srcdir)/%D%/guix-challenge.1		\
-  $(srcdir)/%D%/guix-container.1		\
-  $(srcdir)/%D%/guix-copy.1			\
   $(srcdir)/%D%/guix-deploy.1			\
-  $(srcdir)/%D%/guix-describe.1			\
   $(srcdir)/%D%/guix-download.1			\
   $(srcdir)/%D%/guix-edit.1			\
   $(srcdir)/%D%/guix-environment.1		\
   $(srcdir)/%D%/guix-gc.1			\
-  $(srcdir)/%D%/guix-git.1			\
-  $(srcdir)/%D%/guix-graph.1			\
   $(srcdir)/%D%/guix-hash.1			\
-  $(srcdir)/%D%/guix-home.1			\
   $(srcdir)/%D%/guix-import.1			\
   $(srcdir)/%D%/guix-lint.1			\
-  $(srcdir)/%D%/guix-offload.1			\
-  $(srcdir)/%D%/guix-pack.1			\
   $(srcdir)/%D%/guix-package.1			\
-  $(srcdir)/%D%/guix-processes.1		\
   $(srcdir)/%D%/guix-publish.1			\
   $(srcdir)/%D%/guix-pull.1			\
   $(srcdir)/%D%/guix-refresh.1			\
-  $(srcdir)/%D%/guix-repl.1			\
-  $(srcdir)/%D%/guix-shell.1			\
   $(srcdir)/%D%/guix-size.1			\
-  $(srcdir)/%D%/guix-style.1			\
   $(srcdir)/%D%/guix-system.1			\
   $(srcdir)/%D%/guix-time-machine.1		\
   $(srcdir)/%D%/guix-weather.1

etc/committer.scm.in

@@ -6,7 +6,6 @@
 ;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,19 +28,19 @@
 
 ;;; Code:
 
-(use-modules ((sxml xpath) #:prefix xpath:)
-             (srfi srfi-1)
-             (srfi srfi-2)
-             (srfi srfi-9)
-             (srfi srfi-11)
-             (srfi srfi-26)
-             (ice-9 format)
-             (ice-9 popen)
-             (ice-9 match)
-             (ice-9 rdelim)
-             (ice-9 regex)
-             (ice-9 textual-ports)
-             (guix gexp))
+(import (sxml xpath)
+        (srfi srfi-1)
+        (srfi srfi-2)
+        (srfi srfi-9)
+        (srfi srfi-11)
+        (srfi srfi-26)
+        (ice-9 format)
+        (ice-9 popen)
+        (ice-9 match)
+        (ice-9 rdelim)
+        (ice-9 regex)
+        (ice-9 textual-ports)
+        (guix gexp))
 
 (define* (break-string str #:optional (max-line-length 70))
   "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
@@ -101,16 +100,12 @@ LINE-NO in PORT."
            (read-line port)
            (loop (1- i) last-top-level-sexp))))))
 
-;;; Whether the hunk contains a newly added package (definition), a removed
-;;; package (removal) or something else (#false).
-(define hunk-types '(addition removal #false))
-
 (define-record-type <hunk>
   (make-hunk file-name
              old-line-number
              new-line-number
              diff-lines
-             type)
+             definition?)
   hunk?
   (file-name       hunk-file-name)
   ;; Line number before the change
@@ -119,8 +114,8 @@ LINE-NO in PORT."
   (new-line-number hunk-new-line-number)
   ;; The full diff to be used with "git apply --cached"
   (diff-lines hunk-diff-lines)
-  ;; Does this hunk add or remove a package?
-  (type hunk-type))                     ;one of 'hunk-types'
+  ;; Does this hunk add a definition?
+  (definition? hunk-definition?))
 
 (define* (hunk->patch hunk #:optional (port (current-output-port)))
   (let ((file-name (hunk-file-name hunk)))
@@ -138,30 +133,25 @@ LINE-NO in PORT."
                           ;; new definitions with changes to existing
                           ;; definitions.
                           "--unified=1"
-                          "--" "gnu")))
+                          "gnu")))
     (define (extract-line-number line-tag)
       (abs (string->number
             (car (string-split line-tag #\,)))))
     (define (read-hunk)
       (let loop ((lines '())
-                 (type #false))
+                 (definition? #false))
         (let ((line (read-line port 'concat)))
           (cond
            ((eof-object? line)
-            (values (reverse lines) type))
+            (values (reverse lines) definition?))
            ((or (string-prefix? "@@ " line)
                 (string-prefix? "diff --git" line))
             (unget-string port line)
-            (values (reverse lines) type))
+            (values (reverse lines) definition?))
            (else
             (loop (cons line lines)
-                  (or type
-                      (cond
-                       ((string-prefix? "+(define" line)
-                        'addition)
-                       ((string-prefix? "-(define" line)
-                        'removal)
-                       (else #false)))))))))
+                  (or definition?
+                      (string-prefix? "+(define" line))))))))
     (define info
       (let loop ((acc '())
                  (file-name #f))
@@ -176,13 +166,13 @@ LINE-NO in PORT."
             (match (string-split line #\space)
               ((_ old-start new-start . _)
                (let-values
-                   (((diff-lines type) (read-hunk)))
+                   (((diff-lines definition?) (read-hunk)))
                  (loop (cons (make-hunk file-name
                                         (extract-line-number old-start)
                                         (extract-line-number new-start)
                                         (cons (string-append line "\n")
                                               diff-lines)
-                                        type) acc)
+                                        definition?) acc)
                        file-name)))))
            (else (loop acc file-name))))))
     (close-pipe port)
@@ -224,10 +214,10 @@ corresponding to the top-level definition containing the staged changes."
 (define* (change-commit-message file-name old new #:optional (port (current-output-port)))
   "Print ChangeLog commit message for changes between OLD and NEW."
   (define (get-values expr field)
-    (match ((xpath:sxpath `(// ,field quasiquote *)) expr)
+    (match ((sxpath `(// ,field quasiquote *)) expr)
       (()
        ;; New-style plain lists
-       (match ((xpath:sxpath `(// ,field list *)) expr)
+       (match ((sxpath `(// ,field list *)) expr)
          ((inner) inner)
          (_ '())))
       ;; Old-style labelled inputs
@@ -244,7 +234,7 @@ corresponding to the top-level definition containing the staged changes."
   (define variable-name
     (second old))
   (define version
-    (and=> ((xpath:sxpath '(// version *any*)) new)
+    (and=> ((sxpath '(// version *any*)) new)
            first))
   (format port
           "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
@@ -272,18 +262,10 @@ corresponding to the top-level definition containing the staged changes."
                                           (listify added))))))))))
             '(inputs propagated-inputs native-inputs)))
 
-(define* (add-commit-message file-name variable-name
-                             #:optional (port (current-output-port)))
-  "Print ChangeLog commit message for a change to FILE-NAME adding a
-definition."
-  (format port "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
-          variable-name file-name variable-name))
-
-(define* (remove-commit-message file-name variable-name
-                                #:optional (port (current-output-port)))
-  "Print ChangeLog commit message for a change to FILE-NAME removing a
-definition."
-  (format port "gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%"
+(define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
+  "Print ChangeLog commit message for a change to FILE-NAME adding a definition."
+  (format port
+          "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
           variable-name file-name variable-name))
 
 (define* (custom-commit-message file-name variable-name message changelog
@@ -362,67 +344,66 @@ modifying."
     (()
      (display "Nothing to be done.\n" (current-error-port)))
     (hunks
-     (let-values (((definitions changes) (partition hunk-type hunks)))
-       ;; Additions/removals.
-       (for-each
-        (lambda (hunk)
-          (and-let* ((define-line (find (cut string-match "(\\+|-)\\(define" <>)
-                                        (hunk-diff-lines hunk)))
-                     (variable-name (and=> (string-tokenize define-line)
-                                           second))
-                     (commit-message-proc (match (hunk-type hunk)
-                                            ('addition add-commit-message)
-                                            ('removal remove-commit-message))))
-            (commit-message-proc (hunk-file-name hunk) variable-name)
-            (let ((port (open-pipe* OPEN_WRITE
-                                    "git" "apply"
-                                    "--cached"
-                                    "--unidiff-zero")))
-              (hunk->patch hunk port)
-              (unless (eqv? 0 (status:exit-val (close-pipe port)))
-                (error "Cannot apply")))
+     (let-values
+         (((definitions changes)
+           (partition hunk-definition? hunks)))
 
-            (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
-              (commit-message-proc (hunk-file-name hunk) variable-name port)
-              (usleep %delay)
-              (unless (eqv? 0 (status:exit-val (close-pipe port)))
-                (error "Cannot commit"))))
-          (usleep %delay))
-        definitions))
-
-     ;; Changes.
-     (for-each
-      (match-lambda
-        ((new old . hunks)
-         (for-each (lambda (hunk)
-                     (let ((port (open-pipe* OPEN_WRITE
-                                             "git" "apply"
-                                             "--cached"
-                                             "--unidiff-zero")))
-                       (hunk->patch hunk port)
-                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
+       ;; Additions.
+       (for-each (lambda (hunk)
+                   (and-let*
+                       ((define-line (find (cut string-prefix? "+(define" <>)
+                                           (hunk-diff-lines hunk)))
+                        (variable-name (and=> (string-tokenize define-line) second)))
+                     (add-commit-message (hunk-file-name hunk) variable-name)
+                     (let ((port (open-pipe* OPEN_WRITE                   
+                                             "git" "apply"                
+                                             "--cached"                   
+                                             "--unidiff-zero")))          
+                       (hunk->patch hunk port)                            
+                       (unless (eqv? 0 (status:exit-val (close-pipe port))) 
                          (error "Cannot apply")))
-                     (usleep %delay))
-                   hunks)
-         (define copyright-line
-           (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
-                                      (const line)))
-                (hunk-diff-lines (first hunks))))
-         (cond
-          (copyright-line
-           (add-copyright-line copyright-line))
-          (else
-           (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new)
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new
-                                     port)
-             (usleep %delay)
-             (unless (eqv? 0 (status:exit-val (close-pipe port)))
-               (error "Cannot commit")))))))
-      ;; XXX: we recompute the hunks here because previous
-      ;; insertions lead to offsets.
-      (new+old+hunks (diff-info))))))
+
+                     (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
+                       (add-commit-message (hunk-file-name hunk)
+                                           variable-name port)
+                       (usleep %delay)
+                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                         (error "Cannot commit"))))
+                   (usleep %delay))
+                 definitions)
+
+       ;; Changes.
+       (for-each (match-lambda
+                   ((new old . hunks)
+                    (for-each (lambda (hunk)
+                                (let ((port (open-pipe* OPEN_WRITE
+                                                        "git" "apply"
+                                                        "--cached"
+                                                        "--unidiff-zero")))
+                                  (hunk->patch hunk port)
+                                  (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                                    (error "Cannot apply")))
+                                (usleep %delay))
+                              hunks)
+                    (define copyright-line
+                      (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
+                                              (const line)))
+                                (hunk-diff-lines (first hunks))))
+                    (cond
+                     (copyright-line
+                      (add-copyright-line copyright-line))
+                     (else
+                      (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
+                        (change-commit-message* (hunk-file-name (first hunks))
+                                                old new)
+                      (change-commit-message* (hunk-file-name (first hunks))
+                                              old new
+                                              port)
+                      (usleep %delay)
+                      (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                        (error "Cannot commit")))))))
+                 ;; XXX: we recompute the hunks here because previous
+                 ;; insertions lead to offsets.
+                 (new+old+hunks (diff-info)))))))
 
 (apply main (cdr (command-line)))

etc/completion/bash/guix

@@ -117,59 +117,58 @@ _guix_is_removing ()
     $result
 }
 
-_guix_is_short_option ()
-{
-    case "${COMP_WORDS[$COMP_CWORD - 1]}" in
-	--*)	false;;
-	-*$1)	true ;;
-	*)	false ;;
-    esac
-}
-
-_guix_is_long_option ()
-{
-    # Don't handle (non-GNU?) ‘--long-option VALUE’, as Guix doesn't either.
-    case "${COMP_WORDS[$COMP_CWORD]}" in
-	--$1=*)	true ;;
-	*)	false ;;
-    esac
-}
-
 _guix_is_dash_f ()
 {
-    _guix_is_short_option f ||
-    _guix_is_long_option file ||
-    _guix_is_long_option install-from-file
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-f" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --file=*|--install-from-file=*) true;;
+		 *)                              false;;
+	     esac }
 }
 
 _guix_is_dash_l ()
 {
-    _guix_is_short_option l ||
-    _guix_is_long_option load
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-l" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --load=*) true;;
+		 *)        false;;
+	     esac }
 }
 
 _guix_is_dash_L ()
 {
-    _guix_is_short_option L ||
-    _guix_is_long_option load-path
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-L" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --load-path=*) true;;
+		 *)             false;;
+	     esac }
 }
 
 _guix_is_dash_m ()
 {
-    _guix_is_short_option m ||
-    _guix_is_long_option manifest
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-m" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --manifest=*) true;;
+		 *)            false;;
+	     esac }
 }
 
 _guix_is_dash_C ()
 {
-    _guix_is_short_option C ||
-    _guix_is_long_option channels
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-C" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --channels=*)  true;;
+		 *)             false;;
+	     esac }
 }
 
 _guix_is_dash_p ()
 {
-    _guix_is_short_option p ||
-    _guix_is_long_option profile
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-p" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --profile=*)   true;;
+		 *)             false;;
+	     esac }
 }
 
 _guix_complete_file ()

etc/disarchive-manifest.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,12 +30,11 @@
   (match (origin-actual-file-name origin)
     (#f #f)
     ((? string? file)
-     ;; As of version 0.4.0, Disarchive can only deal with raw tarballs,
-     ;; gzip-compressed tarballs, and xz-compressed tarballs.
+     ;; As of version 0.2.1, Disarchive can only deal with raw tarballs and
+     ;; gzip-compressed tarballs.
      (and (origin-hash origin)
           (or (string-suffix? ".tar.gz" file)
               (string-suffix? ".tgz" file)
-              (string-suffix? ".tar.xz" file)
               (string-suffix? ".tar" file))))))
 
 (define (origin->disarchive origin)
@@ -99,20 +98,6 @@ an empty directory if ORIGIN could not be disassembled."
   (directory-union "disarchive-collection"
                    (filter-map (lambda (origin)
                                  (and (tarball-origin? origin)
-
-                                      ;; Dismiss origins with (sha256 #f) such
-                                      ;; as that of IceCat.
-                                      (and=> (origin-hash origin)
-                                             content-hash-value)
-
-                                      ;; FIXME: Exclude the Chromium tarball
-                                      ;; because it's huge and "disarchive
-                                      ;; disassemble" exceeds the max-silent
-                                      ;; timeout.
-                                      (not (string-prefix?
-                                            "chromium-"
-                                            (origin-actual-file-name origin)))
-
                                       (origin->disarchive origin)))
                                origins)
                    #:copy? #t))

etc/guix-daemon.service.in

@@ -9,16 +9,10 @@ Description=Build daemon for GNU Guix
 ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon \
     --build-users-group=guixbuild --discover=no
 Environment='GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale' LC_ALL=en_US.utf8
+RemainAfterExit=yes
 StandardOutput=syslog
 StandardError=syslog
 
-# Work around a nasty systemd ‘feature’ that kills the entire process tree
-# (including the daemon!) if any child, such as cc1plus, runs out of memory.
-OOMPolicy=continue
-
-# Despite the name, this is rate-limited: a broken daemon will eventually fail.
-Restart=always
-
 # See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
 # Some package builds (for example, go@1.8.1) may require even more than
 # 1024 tasks.

etc/guix-install.sh

@@ -3,14 +3,13 @@
 # Copyright © 2017 sharlatan <sharlatanus@gmail.com>
 # Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 # Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
-# Copyright © 2019–2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+# Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 # Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
 # Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 # Copyright © 2020 Daniel Brooks <db48x@db48x.net>
 # Copyright © 2021 Jakub Kądziołka <kuba@kadziolka.net>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
-# Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-# Copyright © 2022 Prafulla Giri <prafulla.giri@protonmail.com>
+# Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 #
 # This file is part of GNU Guix.
 #
@@ -34,7 +33,7 @@ then
     exec bash "$0" "$@"
 fi
 
-set -eo pipefail
+set -e
 
 [ "$UID" -eq 0 ] || { echo "This script must be run as root."; exit 1; }
 
@@ -93,20 +92,17 @@ _debug()
     fi
 }
 
-die()
-{
-    _err "${ERR}$*"
-    exit 1
-}
-
-# Return true if user answered yes, false otherwise.  The prompt is
-# yes-biased, that is, when the user simply enter newline, it is equivalent to
-# answering "yes".
+# Return true if user answered yes, false otherwise.
 # $1: The prompt question.
 prompt_yes_no() {
-    local -l yn
-    read -rp "$1 [Y/n]" yn
-    [[ ! $yn || $yn = y || $yn = yes ]] || return 1
+    while true; do
+        read -rp "$1 " yn
+        case $yn in
+            [Yy]*) return 0;;
+            [Nn]*) return 1;;
+            *) _msg "Please answer yes or no."
+        esac
+    done
 }
 
 chk_require()
@@ -138,27 +134,21 @@ chk_gpg_keyring()
         gpg_key_id=${GPG_SIGNING_KEYS[$user_id]}
         # Without --dry-run this command will create a ~/.gnupg owned by root on
         # systems where gpg has never been used, causing errors and confusion.
-        if gpg --dry-run --list-keys "$gpg_key_id" >/dev/null 2>&1; then
-            continue
-        fi
-        if prompt_yes_no "${INF}The following OpenPGP public key is \
+        if ! gpg --dry-run --list-keys "$gpg_key_id" >/dev/null 2>&1; then
+            if prompt_yes_no "${INF}The following OpenPGP public key is \
 required to verify the Guix binary signature: $gpg_key_id.
-Would you like me to fetch it for you?"; then
-            # Use a reasonable time-out here so users don't report silent
-            # ‘freezes’ when Savannah goes out to lunch, as has happened.
-            if wget "https://sv.gnu.org/people/viewgpg.php?user_id=$user_id" \
-                    --timeout=30 --no-verbose -O- | gpg --import -; then
-                continue
-            fi
-        fi
-	# If we reach this point, the key is (still) missing.  Report further
-	# missing keys, if any, but then abort the installation.
-        _err "${ERR}Missing OpenPGP public key ($gpg_key_id).
+Would you like me to fetch it for you? (yes/no)"; then
+                wget "https://sv.gnu.org/people/viewgpg.php?user_id=$user_id" \
+                     --no-verbose -O- | gpg --import -
+            else
+                _err "${ERR}Missing OpenPGP public key ($gpg_key_id).
 Fetch it with this command:
 
   wget \"https://sv.gnu.org/people/viewgpg.php?user_id=$user_id\" -O - | \
 sudo -i gpg --import -"
-        exit_flag=yes
+                exit_flag=yes
+            fi
+        fi
     done
     if [ "$exit_flag" = yes ]; then
         exit 1
@@ -230,7 +220,8 @@ chk_sys_arch()
             local arch=powerpc64le
             ;;
         *)
-            die "Unsupported CPU type: ${arch}"
+            _err "${ERR}Unsupported CPU type: ${arch}"
+            exit 1
     esac
 
     case "$os" in
@@ -238,7 +229,8 @@ chk_sys_arch()
             local os=linux
             ;;
         *)
-            die "Your operation system (${os}) is not supported."
+            _err "${ERR}Your operation system (${os}) is not supported."
+            exit 1
     esac
 
     ARCH_OS="${arch}-${os}"
@@ -262,7 +254,7 @@ chk_sys_nscd()
 configure_substitute_discovery() {
     if grep -q -- '--discover=no' "$1" && \
             prompt_yes_no "Would you like the Guix daemon to automatically \
-discover substitute servers on the local network?"; then
+discover substitute servers on the local network? (yes/no)"; then
         sed -i 's/--discover=no/--discover=yes/' "$1"
     fi
 }
@@ -293,7 +285,8 @@ guix_get_bin_list()
     if [[ "${#bin_ver_ls}" -ne "0" ]]; then
         _msg "${PAS}Release for your system: ${default_ver}"
     else
-        die "Could not obtain list of Guix releases."
+        _err "${ERR}Could not obtain list of Guix releases."
+        exit 1
     fi
 
     # Use default to download according to the list and local ARCH_OS.
@@ -318,7 +311,8 @@ guix_get_bin()
             "${url}/${bin_ver}.tar.xz" "${url}/${bin_ver}.tar.xz.sig"; then
         _msg "${PAS}download completed."
     else
-        die "could not download ${url}/${bin_ver}.tar.xz."
+        _err "${ERR}could not download ${url}/${bin_ver}.tar.xz."
+        exit 1
     fi
 
     pushd "${dl_path}" >/dev/null
@@ -326,7 +320,8 @@ guix_get_bin()
         _msg "${PAS}Signature is valid."
         popd >/dev/null
     else
-        die "could not verify the signature."
+        _err "${ERR}could not verify the signature."
+        exit 1
     fi
 }
 
@@ -338,7 +333,8 @@ sys_create_store()
     _debug "--- [ ${FUNCNAME[0]} ] ---"
 
     if [[ -e "/var/guix" || -e "/gnu" ]]; then
-        die "A previous Guix installation was found.  Refusing to overwrite."
+        _err "${ERR}A previous Guix installation was found.  Refusing to overwrite."
+        exit 1
     fi
 
     cd "$tmp_path"
@@ -492,22 +488,14 @@ sys_enable_guix_daemon()
 }
 
 sys_authorize_build_farms()
-{ # authorize the public key(s) of the build farm(s)
-    local hosts=(
-	ci.guix.gnu.org
-	bordeaux.guix.gnu.org
-    )
-
+{ # authorize the public key of the build farm
     if prompt_yes_no "Permit downloading pre-built package binaries from the \
-project's build farms?"; then
-	for host in "${hosts[@]}"; do
-	    local key=~root/.config/guix/current/share/guix/$host.pub
-	    [ -f "$key" ] \
-		&& guix archive --authorize < "$key" \
-		&& _msg "${PAS}Authorized public key for $host"
-	done
-    else
-        _msg "${INF}Skipped authorizing build farm public keys"
+project's build farm? (yes/no)"; then
+        guix archive --authorize \
+             < ~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub \
+            && _msg "${PAS}Authorized public key for ci.guix.gnu.org"
+        else
+            _msg "${INF}Skipped authorizing build farm public keys"
     fi
 }
 
@@ -515,17 +503,7 @@ sys_create_init_profile()
 { # Define for better desktop integration
   # This will not take effect until the next shell or desktop session!
     [ -d "/etc/profile.d" ] || mkdir /etc/profile.d # Just in case
-    cat <<"EOF" > /etc/profile.d/zzz-guix.sh
-# Explicitly initialize XDG base directory variables to ease compatibility
-# with Guix System: see <https://issues.guix.gnu.org/56050#3>.
-export XDG_DATA_HOME="${XDG_DATA_HOME:-$HOME/.local/share}"
-export XDG_CONFIG_HOME="${XDG_CONFIG_HOME:-$HOME/.config}"
-export XDG_STATE_HOME="${XDG_STATE_HOME:-$HOME/.local/state}"
-export XDG_DATA_DIRS="${XDG_DATA_DIRS:-/usr/local/share/:/usr/share/}"
-export XDG_CONFIG_DIRS="${XDG_CONFIG_DIRS:-/etc/xdg}"
-export XDG_CACHE_HOME="${XDG_CACHE_HOME:-$HOME/.cache}"
-# no default for XDG_RUNTIME_DIR (depends on foreign distro for semantics)
-
+    cat <<"EOF" > /etc/profile.d/guix.sh
 # _GUIX_PROFILE: `guix pull` profile
 _GUIX_PROFILE="$HOME/.config/guix/current"
 export PATH="$_GUIX_PROFILE/bin${PATH:+:}$PATH"
@@ -536,14 +514,15 @@ export PATH="$_GUIX_PROFILE/bin${PATH:+:}$PATH"
 export INFOPATH="$_GUIX_PROFILE/share/info:$INFOPATH"
 
 # GUIX_PROFILE: User's default profile
-# Prefer the one from 'guix home' if it exists.
-GUIX_PROFILE="$HOME/.guix-home/profile"
-[ -L $GUIX_PROFILE ] || GUIX_PROFILE="$HOME/.guix-profile"
+GUIX_PROFILE="$HOME/.guix-profile"
 [ -L $GUIX_PROFILE ] || return
 GUIX_LOCPATH="$GUIX_PROFILE/lib/locale"
 export GUIX_LOCPATH
 
 [ -f "$GUIX_PROFILE/etc/profile" ] && . "$GUIX_PROFILE/etc/profile"
+
+# set XDG_DATA_DIRS to include Guix installations
+export XDG_DATA_DIRS="$GUIX_PROFILE/share:${XDG_DATA_DIRS:-/usr/local/share/:/usr/share/}"
 EOF
 }
 
@@ -566,28 +545,9 @@ sys_create_shell_completion()
         _msg "${PAS}installed shell completion"
 }
 
-sys_customize_bashrc()
-{
-    prompt_yes_no "Customize users Bash shell prompt for Guix?" || return
-    for bashrc in /home/*/.bashrc /root/.bashrc; do
-        test -f "$bashrc" || continue
-        grep -Fq '$GUIX_ENVIRONMENT' "$bashrc" && continue
-        cp "${bashrc}" "${bashrc}.bak"
-        echo '
-# Automatically added by the Guix install script.
-if [ -n "$GUIX_ENVIRONMENT" ]; then
-    if [[ $PS1 =~ (.*)"\\$" ]]; then
-        PS1="${BASH_REMATCH[1]} [env]\\\$ "
-    fi
-fi
-' >> "$bashrc"
-    done
-    _msg "${PAS}Bash shell prompt successfully customized for Guix"
-}
 
 welcome()
 {
-    local char
     cat<<"EOF"
     ░░░                                     ░░░
     ░░▒▒░░░░░░░░░               ░░░░░░░░░▒▒░░
@@ -613,15 +573,8 @@ This script installs GNU Guix on your system
 
 https://www.gnu.org/software/guix/
 EOF
-    # Don't use ‘read -p’ here!  It won't display when run non-interactively.
-    echo -n "Press return to continue..."$'\r'
-    read -r char
-    if [ "$char" ]; then
-	echo
-	echo "...that ($char) was not a return!"
-	_msg "${WAR}Use newlines to automate installation, e.g.: yes '' | ${0##*/}"
-	_msg "${WAR}Any other method is unsupported and likely to break in future."
-    fi
+    echo -n "Press return to continue..."
+    read -r
 }
 
 main()
@@ -641,7 +594,7 @@ main()
     _msg "${INF}system is ${ARCH_OS}"
 
     umask 0022
-    tmp_path="$(mktemp -t -d guix.XXXXXX)"
+    tmp_path="$(mktemp -t -d guix.XXX)"
 
     if [ -z "${GUIX_BINARY_FILE_NAME}" ]; then
         guix_get_bin_list "${GNU_URL}"
@@ -661,7 +614,6 @@ main()
     sys_authorize_build_farms
     sys_create_init_profile
     sys_create_shell_completion
-    sys_customize_bashrc
 
     _msg "${INF}cleaning up ${tmp_path}"
     rm -r "${tmp_path}"

etc/guix-publish.service.in

@@ -11,12 +11,10 @@ After=guix-daemon.service
 [Service]
 ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix publish --user=nobody --port=8181
 Environment='GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale' LC_ALL=en_US.utf8
+RemainAfterExit=yes
 StandardOutput=syslog
 StandardError=syslog
 
-# Despite the name, this is rate-limited: a broken daemon will eventually fail.
-Restart=always
-
 # See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
 TasksMax=1024
 

etc/news.scm

@@ -6,18 +6,17 @@
 ;; Copyright © 2019, 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;; Copyright © 2019, 2020, 2021 Julien Lepiller <julien@lepiller.eu>
 ;; Copyright © 2019–2022 Florian Pelz <pelzflorian@pelzflorian.de>
-;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org>
+;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
 ;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
 ;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;; Copyright © 2021 Leo Famulari <leo@famulari.name>
 ;; Copyright © 2021 Zhu Zihao <all_but_last@163.com>
 ;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
-;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
+;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
 ;; Copyright © 2021 Jonathan Brielmaier <jonathan.brielmaier@web.de>
-;; Copyright © 2022 Thiago Jung Bauermann <bauermann@kolabnow.com>
 ;;
 ;; Copying and distribution of this file, with or without modification, are
 ;; permitted in any medium without royalty provided the copyright notice and
@@ -26,594 +25,6 @@
 (channel-news
  (version 0)
 
- (entry (commit "788602b37ff42f730d4b7b569b0fb51465f147da")
-        (title
-         (en "New @option{--symlink} option for @command{guix shell}")
-         (de "Neue Option @option{--symlink} für @command{guix shell}")
-         (fr "Nouvelle option @option{--symlink} pour @command{guix shell}"))
-        (body
-         (en "The @command{guix shell} command has a new
-@option{--symlink} (or @option{-S}) option, to be used in conjunction with the
-@option{--container} (or @option{-C}) option to create a symbolic link inside
-the container.  Run @command{info \"(guix) Invoking guix shell\"} for more
-information.")
-         (de "Der Befehl @command{guix shell} verfügt jetzt über eine neue
-Befehlszeilenoption @option{--symlink} (oder @option{-S}), die zusammen mit der
-Option @option{--container} (oder @option{-C}) benutzt werden kann, um eine
-symbolische Verknüpfung im Container anzulegen.  Führen Sie
-@command{info \"(guix.de) Aufruf von guix shell\"} aus, um mehr zu erfahren.")
-         (fr "La commande @command{guix shell} dispose d'une nouvelle option,
-@option{--symlink} (ou @option{-S}), qui doit être utilisée en conjonction
-avec l'option @option{--container} (ou @option{-C}) pour créer un lien
-symbolique dans le conteneur.  Lancer @command{info \"(guix.fr) Invoquer guix
-shell\"} pour plus d'informations.")))
-
- (entry (commit "82a0a395d7051eab7b9f15ec4740d58c86413604")
-        (title
-         (en "Linux-libre kernel updated to 6.0")
-         (de "Linux-libre-Kernel wird auf 6.0 aktualisiert")
-         (fr "Le noyau linux-libre est mis à jour vers la 6.0")
-         (pt "Kernel linux-libre atualizado para 6.0"))
-        (body
-         (en "The default version of the linux-libre kernel has been
-              updated to the 6.0 release series.")
-         (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
-              jetzt auf der 6.0-Versionsreihe.")
-         (fr "La version par défaut du noyau linux-libre est mise à jour
-              vers la série des 6.0.")
-         (pt "A versão padrão do kernel linux-libre foi atualizada para a
-              série do kernel 6.0.")))
-
- (entry (commit "400a7a4c80efbde1905ae98a298bbb5882d46a0d")
-        (title
-         (en "New build system for Python packages")
-         (de "Neues Erstellungssystem für Python-Pakete")
-         (fr "Nouveau système de construction pour les paquets Python")
-         (pt "Novo sistema de compilação para pacotes Python"))
-        (body
-         (en "A new @var{pyproject-build-system} has been added.  This
-is a redesign of @var{python-build-system} with support for @dfn{PEP 517}
-and @file{pyproject.toml} files.  It also has built-in support for various
-test frameworks such as @command{pytest} and @code{nosetests}.
-
-There is a complementary @code{python-toolchain} package that comes with
-updated versions of @command{pip}, @command{setuptools} and others.
-
-The build system will eventually be merged into @var{python-build-system}
-but you are encouraged to use it for packages in the @code{guix} channel.
-Third party channels may want to wait until the API is stable (see the
-Guix manual for caveats).
-
-Despite the name, @var{pyproject-build-system} also works with the
-``legacy'' @file{setup.py} format.")
-         (de "Ein neues Erstellungssystem @var{pyproject-build-system} ist
-verfügbar.  Es ist eine Neuauflage des @var{python-build-system}, die
-@dfn{PEP 517} und @file{pyproject.toml}-Dateien unterstützt.  Auch wurde
-Unterstützung für Testrahmen wie @command{pytest} und @code{nosetests}
-eingebaut.
-
-Ergänzend gibt es ein Paket @code{python-toolchain} mit aktualisierten Versionen
-von @command{pip}, @command{setuptools} und mehr.
-
-Das Erstellungssystem wird in Zukunft Teil von @var{python-build-system} werden,
-aber wir würden es begrüßen, wenn Sie es für Pakete auf dem @code{guix}-Kanal
-verwenden würden.  Drittanbieterkanäle warten vielleicht lieber auf eine
-stabile Programmierschnittstelle (siehe die im Guix-Handbuch genannten
-Einschränkungen).
-
-Trotz dem Namen funktioniert @var{pyproject-build-system} auch mit dem „alten“
-@file{setup.py}-Format.")
-         (fr "Un nouveau système de construction, @var{pyproject-build-system},
-a été ajouté.  Il s'agit d'une refonte du @var{python-build-system} qui rajoute
-la prise en charge de @dfn{PEP 517} et des fichiers @file{pyproject.toml}.
-Il intègre aussi la prise en charge de divers cadriciels de test comme
-@command{pytest} ou @code{nosetests}.
-
-Un paquet supplémentaire @code{python-toolchain} fournit des versions à jour
-de @command{pip}, @command{setuptools} et autres.
-
-Le système de construction finira par être intégré au @var{python-build-system}
-mais nous vous encourageons à l'utiliser pour les paquets du canal @code{guix}.
-Les canaux tiers devraient attendre que l'API se stabilise (voir le manuel de
-Guix pour les mises en garde).
-
-Contrairement à ce qu'indique son nom, @var{pyproject-build-system} fonctionne
-aussi avec « l'ancien » format @file{setup.py}.")
-         (pt "Um novo sistema de compilação chamado @var{pyproject-build-system}
-foi adicionado.  É um redesign do @var{python-build-system} com suporte à
-@dfn{PEP 517} e a arquivos @file{pyproject.toml}.  Ele também inclui suporte a
-vários frameworks de teste tais como @command{pytest} e @code{nosetests}.
-
-Há um pacote complementar @code{python-toolchain} que contém versões
-atualizadas do @command{pip}, @command{setuptools} e outros.
-
-O sistema de compilação será eventualmente incorporado ao
-@var{python-build-system}, mas encorajamos você a usá-lo para pacotes no canal
-@code{guix}.  Canais de terceiros podem querer esperar até a API se
-estabilizar (veja o manual do Guix para ressalvas).
-
-Apesar do nome, o @var{pyproject-build-system} também funciona com o formato
-“legado” do @file{setup.py}.")))
-
- (entry (commit "c7ba5f38b80433b040d3946b8fc0b1e8621ba30a")
-        (title
-         (en "New @option{--emulate-fhs} option for @command{guix shell}")
-         (de "Neue Option @option{--emulate-fhs} für @command{guix shell}")
-         (fr "Nouvelle option @option{--emulate-fhs} pour @command{guix shell}")
-         (pt "Nova opção @option{--emulate-fhs} para o @command{guix shell}"))
-        (body
-         (en "The @command{guix shell} command has a new
-@option{--emulate-fhs} (or @option{-F}) option.  Combined with
-@option{--container} (or @option{-C}), it emulates the file and directory
-layout specified by the Filesystem Hierarchy Standard (FHS), providing
-@file{/bin}, @file{/lib}, etc. within the container.
-
-For example, the following command runs @file{/bin/ls} within such a
-container:
-
-@example
-guix shell -CF coreutils -- /bin/ls
-@end example
-
-Run @command{info \"(guix) Invoking guix shell\"} for more information.")
-         (de "Der Befehl @command{guix shell} verfügt jetzt über eine neue
-Befehlszeilenoption @option{--emulate-fhs} (oder @option{-F}).  Zusammen mit
-@option{--container} (oder @option{-C}) kann so die Datei- und
-Verzeichnisstruktur, die im @i{Filesystem Hierarchy Standard} (FHS) vorgegeben
-wird, nachgebildet werden. Das heißt, in der Container-Umgebung gibt es
-@file{/bin}, @file{/lib} und so weiter.
-
-Zum Beispiel wird folgender Befehl @file{/bin/ls} in einem solchen Container
-ausführen:
-
-@example
-guix shell -CF coreutils -- /bin/ls
-@end example
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix shell\"} aus, um mehr
-zu erfahren.")
-         (fr "La commande @command{guix shell} dispose d'une nouvelle option,
-@option{--emulate-fhs} (ou @option{-F}).  Avec @option{--container} (ou
-@option{-C}), elle permet d'imiter la disposition des fichiers et répertoires
-spécifiée par le @i{Filesystem Hierarchy Standard} (FHS) en fournissant
-@file{/bin}, @file{/lib}, etc. dans le conteneur.
-
-Par exemple, la commande ci-dessous lance @file{/bin/ls} dans un tel
-conteneur :
-
-@example
-guix shell -CF coreutils -- /bin/ls
-@end example
-
-Lancer @command{info \"(guix.fr) Invoquer guix shell\"} pour plus
-d'informations.")
-         (pt "O comando @command{guix shell} tem uma nova opção
-@option{--emulate-fhs} (ou @option{-F}).  Combinada com
-@option{--container} (ou @option{-C}), ela emula o layout de arquivos e
-diretórios especificado pelo Padrão de Hierarquia do Sistema de
-Arquivos (Filesystem Hierarchy Standard — FHS), provendo @file{/bin},
-@file{/lib}, etc. dentro do contêiner.
-
-Por exemplo, o comando seguinte executa @file{/bin/ls} dentro de um contêiner
-desse tipo:
-
-@example
-guix shell -CF coreutils -- /bin/ls
-@end example
-
-Execute @command{info \"(guix) Invoking guix shell\"} para mais informações.")))
-
- (entry (commit "28ade1bab207974cce6a014e7187968511fc5526")
-        (title
-         (en "@option{--with-source} is now recursive")
-         (de "@option{--with-source} ist jetzt rekursiv")
-         (fr "@option{--with-source} est dorénavant récursive")
-         (pt "@option{--with-source} agora é recursiva"))
-        (body
-         (en "The @option{--with-source} package transformation option now
-uses the specified source for all matching packages, including dependencies.
-This option is useful for all package maintainers, developers, and, in
-general, all users who want Guix to facilitate their rights to modify their
-software and share their changes.
-
-Run @command{info \"(guix) Package Transformation Options\"} for more
-info.")
-         (de "Die Paketumwandlungsoption @option{--with-source} wird jetzt den
-angegebenen Quellcode für sämtliche passende Pakete benutzen, Abhängigkeiten
-eingeschlossen. Die Option hilft Paketbetreuern, Entwicklern und allgemein allen
-Nutzern, die Guix benutzen, das Recht, ihre Software anzupassen und
-Änderungen zu teilen, leichter auszuüben.
-
-Führen Sie für mehr Informationen @command{info \"(guix.de)
-Paketumwandlungsoptionen\"} aus.")
-         (fr "L'option de transformation de paquet @option{--with-source}
-s'applique désormais à tous les paquets correspondant, y compris les
-dépendances.  Cette option est utile pour les personnes qui maintiennent un
-logiciel, en développent un ou, plus généralement, pour toute personne qui
-souhaite que Guix facilite l'exercice de ses droits à modifier le logiciel et
-à partager ses changements.
-
-Lancer @command{info \"(guix.fr) Options de transformation de paquets\"} pour
-plus d'informations.")
-         (pt "A opção de transformação de pacote @option{--with-source} agora
-usa a fonte especificada para todos os pacotes correspondentes, incluindo
-dependências.  Essa opção é útil para todos os mantenedores de pacotes,
-desenvolvedores e usuários em geral que querem que o Guix facilite seu direito
-de modificar seu software e compartilhar suas mudanças.
-
-Execute @command{info \"(guix) Package Transformation Options\"} para mais
-informações.")))
-
- (entry (commit "a13f5ead0265cf0fe11e60150547c09dfc8c45b0")
-        (title
-         (en "Guix System image creation is now documented")
-         (de "Es gibt eine Dokumentation, wie Sie Guix-System-Abbilder („Images“) erzeugen")
-         (fr "La création d'images pour Guix System est à présent documentée")
-         (pt "A criação de imagens do Guix System agora está documentada"))
-        (body
-         (en "The Guix System image API that allows you to create customized
-system images and turn them into actual bootable images is now documented in
-the @code{Creating System Images} chapter of the Guix documentation.  This
-should be particularly useful for people trying to port Guix System to new
-hardware.")
-         (de "Sie können nun im Kapitel @code{Creating System Images} der
-Dokumentation nachlesen, wie Sie mit der Schnittstelle für Guix-System-Abbilder
-anpassbare, bootfähige Systemabbilder erzeugen können.  Das sollte vor allem
-Personen unterstützen, die versuchen, Guix System auf neuer Hardware zum Laufen
-zu bringen.")
-         (fr "L'interface de programmation d'images pour Guix System,
-permettant de créer des images personnalisées et de les transformer en images
-amorçables est désormais documentée dans le chapitre @code{Création d'images
-système}.  Cette interface devrait être particulièrement utile aux personnes
-qui essaient de faire fonctionner Guix sur de nouvelles machines.")
-         (pt "A API de imagens do Guix System que permite criar imagens de
-sistema customizadas e torná-las inicializáveis agora está documentada no
-capítulo @code{Creating System Images} da documentação do Guix.  Isso é
-particularmente útil para pessoas tentando portar o Guix System para um novo
-hardware.")))
- (entry (commit "c8112f3bd95269ce4aca12dedbfe61bb6b37acae")
-        (title
-         (en "WSL system images support")
-         (de "WSL-Systemabbilder werden unterstützt")
-         (fr "Support pour les images système WSL")
-         (pt "Suporte a imagens de sistema WSL"))
-        (body
-         (en "The @command{guix system image} command can now generate system
-images for the Windows Subsystem for Linux.  To get started, you can for
-instance run from a Guix checkout:
-
-@command{guix system image gnu/system/images/wsl2.scm},
-
-and import the resulting image this way:
-
-@command{wsl --import Guix ./guix ./wsl2-image.tar.gz}
-@command{wsl -d Guix}.")
-         (de "Mit dem Befehl @command{guix system image} können Sie
-Systemabbilder erzeugen, die auf dem Windows-Subsystem für Linux laufen.  Wenn
-Sie das ausprobieren möchten, führen Sie zum Beispiel Folgendes aus einem
-Guix-Checkout heraus aus:
-
-@command{guix system image gnu/system/images/wsl2.scm},
-
-Das resultierende Abbild können Sie so importieren:
-
-@command{wsl --import Guix ./guix ./wsl2-image.tar.gz}
-@command{wsl -d Guix}.")
-         (fr "La commande @command{guix system image} peut désormais générer
-des images système pour le Windows Subystem for Linux.  Vous pouvez par
-exemple lancer la commande suivante depuis un répertoire de sources Guix :
-
-@command{guix system image gnu/system/images/wsl2.scm},
-
-et importer l'image obtenue de cette manière :
-
-@command{wsl --import Guix ./guix ./wsl2-image.tar.gz}
-@command{wsl -d Guix}.")
-         (pt "Agora o comando @command{guix system image} pode gerar imagens
-de sistema para o Subsistema do Windows para Linux.  Para começar, você pode
-por exemplo rodar a partir de um checkout do repositório do Guix:
-
-@command{guix system image gnu/system/images/wsl2.scm},
-
-e importar a imagem resultante da seguinte maneira:
-
-@command{wsl --import Guix ./guix ./wsl2-image.tar.gz}
-@command{wsl -d Guix}.")))
- (entry (commit "11a06d1e49f4d50d6789e05bbf35e2e145ff7838")
-        (title
-         (en "Emacs now supports native compilation")
-         (de "Emacs kann Pakete nun nativ kompilieren")
-         (pt "O Emacs agora suporta compilação nativa"))
-        (body
-         (en "Emacs can now compile packages natively.  Under the default
-configuration, this means that Emacs packages will now be just-in-time (JIT)
-compiled as you use them, and the results stored in a subdirectory of your
-@code{user-emacs-directory}.
-
-Furthermore, the build system for Emacs packages transparently supports native
-compilation, but note, that @code{emacs-minimal}---the default Emacs for
-building packages---has been configured without native compilation.
-To natively compile your emacs packages ahead of time, use a transformation
-like @option{--with-input=emacs-minimal=emacs}.")
-         (de "Emacs kann nun native Maschinenbefehle erzeugen.  Standardgemäß
-kompiliert es nun Pakete „just in time“, während Sie diese laden, und platziert
-die so erzeugten nativen Bibliotheken in einem Unterverzeichnis Ihres
-@code{user-emacs-directory}.
-
-Darüber hinaus unterstützt das Erstellungssystem für Emacs-Pakete die Erzeugung
-nativer Maschinenbefehle.  Beachten Sie jedoch, dass @code{emacs-minimal} –
-die Emacs-Variante, mit der normalerweise Emacs-Pakete erstellt werden –
-weiterhin keine nativen Befehle generiert.  Um native Befehle für Ihre
-Emacs-Pakete schon im Voraus zu erzeugen, nutzen Sie eine Transformation, z.B.
-@option{--with-input=emacs-minimal=emacs}.")
-         (pt "Agora o Emacs pode compilar pacotes nativamente.  Na
-configuração padrão os pacotes do Emacs serão compilados “just-in-time” (JIT)
-conforme forem usados, e os resultados armazenados em um subdiretório de
-@code{user-emacs-directory}.
-
-Além disso, o sistema de compilação para pacotes do Emacs suporta compilação
-nativa de forma transparente.  Note porém que o @code{emacs-minimal} --- a
-variante padrão do Emacs para compilar pacotes --- foi configurado sem
-compilação nativa.  Para pré-compilar nativamente seus pacotes do Emacs use
-uma transformação, como por exemplo
-@code{--with-input=emacs-minimal=emacs}.")))
-
- (entry (commit "c188cf57f161c0c26e2d7c8516bd1ddd1492d686")
-        (title
-         (en "Linux-libre kernel updated to 5.19")
-         (de "Linux-libre-Kernel wird auf 5.19 aktualisiert")
-         (fr "Le noyau linux-libre est mis à jour vers la 5.19")
-         (pt "Kernel linux-libre atualizado para 5.19"))
-        (body
-         (en "The default version of the linux-libre kernel has been
-              updated to the 5.19 release series.")
-         (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
-              jetzt auf der 5.19-Versionsreihe.")
-         (fr "La version par défaut du noyau linux-libre est mise à jour
-              vers la série des 5.19.")
-         (pt "A versão padrão do kernel linux-libre foi atualizada para a
-              série do kernel 5.19.")))
-
- (entry (commit "a15542d26df42dabdb5e2f76d150ae200230c3b0")
-        (title
-         (en "New @option{--whole-file} option for @command{guix style}")
-         (de "Neue Option @option{--whole-file} für @command{guix style}")
-         (fr "Nouvelle option @option{--whole-file} pour @command{guix style}")
-         (pt "Nova opção @option{--whole-file} para @command{guix style}"))
-        (body
-         (en "The @command{guix style} command has a new @option{--whole-file}
-option: instead of formatting individual package definitions, this option lets
-you reformat entire Scheme files.  You might want to use it to format your
-operating system configuration file, for instance.
-
-Run @command{info \"(guix) Invoking guix style\"} for more info.")
-         (de "Der Befehl @command{guix style} verfügt über eine neue
-Befehlszeilenoption @option{--whole-file}: Mit ihr werden keine einzelnen
-Paketdefinitionen umformatiert, sondern ganze Scheme-Dateien werden in die
-richtige Darstellungsform gebracht.  Sie können damit zum Beispiel die
-Konfigurationsdatei für Ihr Betriebssystem formatieren lassen.
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix style\"} aus, um mehr
-Informationen zu erhalten.")
-         (fr "La commande @command{guix style} a désormais une nouvelle option
-@option{--whole-file} : au lieu de mettre en forme des définitions de paquets,
-cette option permet de mettre en forme des fichiers Scheme entiers.  Ça peut
-s'avérer utile par exemple pour mettre en forme son fichier de configuration
-du système d'exploitation.
-
-Lancer @command{info \"(guix.fr) Invoquer guix style\"} pour plus
-d'informations.")
-         (pt "O comando @command{guix style} tem uma nova opção
-@option{--whole-file}: ao invés de formatar definições de pacote
-individualmente, esta opção permite a reformatação de arquivos Scheme por
-inteiro.  Você pode querer usá-la para formatar seu arquivo de configuração do
-sistema operacional, por exemplo.
-
-Execute @command{info \"(guix) Invoking guix style\"} para mais informações.")))
-
- (entry (commit "2ec7ab2610eb67e26dab52b671eb29e46f64ea0f")
-        (title
-         (en "Linux-libre kernel updated to 5.18")
-         (de "Linux-libre-Kernel wird auf 5.18 aktualisiert")
-         (fr "Le noyau linux-libre est mis à jour vers la 5.18"))
-        (body
-         (en "The default version of the linux-libre kernel has been
-              updated to the 5.18 release series.")
-         (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
-jetzt auf der 5.18-Versionsreihe.")
-         (fr "La version par défaut du noyau linux-libre est mise à jour
-              vers la série des 5.18.")))
-
- (entry (commit "bdf422176739b473add66eb8cac9fdd8c654f794")
-        (title
-         (en "@option{-L} option of @command{guix refresh} repurposed")
-         (de "Option @option{-L} von @command{guix refresh} wechselt Bedeutung")
-         (fr "Option @option{-L} de @command{guix refresh} réutilisée"))
-        (body
-         (en "The @option{-L} option of @command{guix refresh} has been
-repurposed: it used to be synonymous with @option{--list-updaters}; it is now
-synonymous with @option{--load-path} as is the case with most other commands.
-
-Run @command{info \"(guix) Invoking guix refresh\"} for more info.")
-         (de "Die Befehlszeilenoption @option{-L} von @command{guix refresh} hat
-einen anderen Zweck bekommen: Früher war sie gleichbedeutend mit
-@option{--list-updaters}; jetzt ist sie gleichbedeutend mit
-@option{--load-path}, wie bereits beim Großteil der anderen Befehle.
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix refresh\"} aus, wenn Sie
-mehr wissen möchten.")
-         (fr "L'option @option{-L} de @command{guix refresh} a changé de
-signification : elle était auparavant synonyme de @option{--list-updaters} ;
-elle est maintenant synonyme de @option{--load-path} comme c'est le cas pour
-la plupart des autres commandes.
-
-Lancer @command{info \"(guix.fr) Invoquer guix refresh\"} pour plus
-d'informations.")))
-
- (entry (commit "35c1edb20ad07250728d3bdcd0296bd0cedaf6bb")
-        (title
-         (en "New @command{edit} sub-commands for services")
-         (de "Neue @command{edit}-Unterbefehle für Dienste")
-         (fr "Nouvelles commandes @command{edit} pour les services")
-         (nl "Nieuwe deelopdracht @command{edit} voor diensten"))
-        (body
-         (en "The new @command{guix system edit} and @command{guix home edit} commands
-allow you to view or edit service types defined for Guix System or Guix Home.
-For example, here is how you would open the definition of the OpenSSH system
-service:
-
-@example
-guix system edit openssh
-@end example
-
-Run @command{info \"(guix) Invoking guix system\"} or @command{info \"(guix)
-Invoking guix home\"} for more info.")
-         (de "Mit den neuen Befehlen @command{guix system edit} und
-@command{guix home edit} können Sie Diensttypen für Guix System oder Guix Home
-betrachten und bearbeiten.  Zum Beispiel würden Sie die Definition des
-OpenSSH-Systemdienstes wie folgt öffnen:
-
-@example
-guix system edit openssh
-@end example
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix system\"} oder
-@command{info \"(guix.de) Aufruf von guix home\"} aus, um mehr zu erfahren.")
-         (fr "Les nouvelles commandes @command{guix system edit} et
-@command{guix home edit} permettent de visualiser ou d'éditer les types de
-services définis pour Guix System ou Guix Home.  Par exemple, voici comment
-ouvrir la définition du service système OpenSSH :
-
-@example
-guix system edit openssh
-@end example
-
-Lancer @command{info \"(guix.fr) Invoquer guix system\"} ou @command{info
-\"(guix.fr) Invoquer guix home\"} pour plus d'informations.")
-         ;; TODO: pas verwijzingen naar de handleiding aan wanneer ze vertaald is
-         (nl "Met de nieuwe bewerkingen @command{guix system edit} en
-@command{guix home edit} kan je dienstsoorten van Guix System en Guix
-Home bekijken en bewerken.  Je kan bijvoorbeeld de definitie van de
-systeemdienst OpenSSH als volgt openen:
-
-@example
-guix system edit openssh
-@end example
-
-Voer @command{info \"(guix) Invoking guix system\"} of @command{info
-\"(guix)Invoking guix home\"} uit voor meer informatie.")))
-
- (entry (commit "903c82583e1cec4c9ff09d5895c5cc646c37b661")
-        (title
-         (en "New @command{guix import elm} command")
-         (de "Neuer Befehl @command{guix import elm}")
-         (fr "Nouvelle commande @command{guix import elm}"))
-        (body
-         (en "The new @command{guix import elm} command allows packagers to
-generate a package definition or given the name of a package for Elm, a
-functional programming language for the Web:
-
-@example
-guix import elm elm/bytes
-@end example
-
-Run @command{info \"(guix) Invoking guix import\"} for more info.
-
-This comes with a new build system for Elm packages---run @command{info
-\"(guix) Build Systems\"} for details.")
-         (de "Mit dem neuen Befehl @command{guix import elm} können Paketautoren
-eine Paketdefinition anhand des Namens eines Pakets für Elm, einer funktionalen
-Programmiersprache für das Web, erzeugen:
-
-@example
-guix import elm elm/bytes
-@end example
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix import\"} aus, um mehr
-Informationen zu bekommen.
-
-Dazu kommt ein neues Erstellungssystem für Elm-Pakete.  Führen Sie
-@command{info \"(guix.de) Erstellungssysteme\"} aus, um mehr zu erfahren.")
-         (fr "La nouvelle commande @command{guix import elm} permet de générer
-une définition de paquet reposant sur Elm, un langage de programmation
-fonctionnelle pour le Web:
-
-@example
-guix import elm elm/bytes
-@end example
-
-Lancer @command{info \"(guix.fr) Invoquer guix import\"} pour plus
-d'informations.
-
-Cela vient avec un nouveau système de construction pour paquets Elm---lancer
-@command{info \"(guix.fr) Systèmes de construction\"} pour plus de détails.")))
-
- (entry (commit "b6b2de2a0d52530bc1ee128c61580bed662ee15c")
-        (title (en "Linux-libre kernel updated to 5.17")
-               (de "Linux-libre-Kernel wird auf 5.17 aktualisiert")
-               (fr "Le noyau linux-libre est mis à jour vers la 5.17"))
-        (body
-         (en "The default version of the linux-libre kernel has been
-              updated to the 5.17 release series.")
-         (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
-jetzt auf der 5.17-Versionsreihe.")
-         (fr "La version par défaut du noyau linux-libre est mise à jour
-              vers la série des 5.17.")))
-
- (entry (commit "c42b7baf13c7633b4512e94da7445299c57b247d")
-        (title
-         (en "New @option{--export-manifest} option for @command{guix shell}")
-         (de "Neue Option @option{--export-manifest} für @command{guix shell}")
-         (fr "Nouvelle option @option{--export-manifest} de @command{guix shell}"))
-        (body
-         (en "If you use @command{guix shell}, you might wonder how to
-``translate'' a command line into a manifest file that you can keep under
-version control, share with others, and pass to @command{guix shell -m} and in
-fact to most @command{guix} commands.  This is what the new
-@option{--export-manifest} option does.
-
-For example, the command below prints a manifest for the given packages:
-
-@lisp
-guix shell --export-manifest \\
-   -D guile git emacs emacs-geiser emacs-geiser-guile
-@end lisp
-
-Run @code{info \"(guix) Invoking guix shell\"} for more information.")
-         (de "Wenn Sie @command{guix shell} benutzen, haben Sie sich vielleicht
-einmal gefragt, wie Sie eine Befehlszeile in eine Manifest-Datei „übersetzen“
-können, die Sie unter Versionskontrolle stellen können, mit anderen teilen
-können und an @command{guix shell -m} oder tatsächlich die meisten anderen
-@command{guix}-Befehle übergeben können.  Die Antwort ist die neue
-Befehlszeilenoption @option{--export-manifest}.
-
-Zum Beispiel gibt der folgende Befehl ein Manifest mit den genannten Paketen
-aus:
-
-@lisp
-guix shell --export-manifest \\
-   -D guile git emacs emacs-geiser emacs-geiser-guile
-@end lisp
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix shell\"} aus, um mehr
-zu erfahren.")
-         (fr "Si tu utilises @command{guix shell}, tu t'es peut-être déjà
-demandé comment « traduire » une ligne de commande en un fichier manifeste que
-tu puisse garder en gestion de version, partager et passer à @command{guix
-shell -m} et autres commandes @command{guix}.  C'est ce que la nouvelle option
-@option{--export-manifest} fait.
-
-Par exemple, la commande ci-dessous affiche un manifeste pour les paquets
-donnés :
-
-@lisp
-guix shell --export-manifest \\
-   -D guile git emacs emacs-geiser emacs-geiser-guile
-@end lisp
-
-Lancer @code{info \"(guix.fr) Invoquer guix shell\"} pour plus
-d'informations.")))
-
  (entry (commit "094a2cfbe45c104d0da30ff9d975d052ca0c118c")
         (title
          (en "New @command{guix home container} command")
@@ -777,7 +188,7 @@ Bezeichnungen aus Paketeingaben entfernt werden. Wenn Sie {--styling}
 weglassen, passiert das Gleiche wie wenn Sie @samp{--styling=format} angeben;
 früher war es das Gleiche wie @samp{--styling=inputs}.
 
-Führen Sie @command{info \"(guix.de) Aufruf von guix style\"} aus, um mehr
+Führen Sie @command{info \"(guix) Invoking guix style\"} aus, um mehr
 Informationen zu erhalten.")
          (fr "La commande @command{guix style}, récemment introduite, peut
 désormais être utilisée pour mettre en forme des définitions de paquets
@@ -1264,7 +675,7 @@ das Löschen, Ersetzen, Hinzufügen von Eingaben.
 
 Um den Übergang zum „neuen Stil“ zu erleichtern, steht ein neuer
 Befehl @command{guix style} zur Verfügung.  Führen Sie @command{info
-\"(guix.de) Aufruf von guix style\"} aus, um mehr Informationen zu
+\"(guix) Invoking guix style\"} aus, um mehr Informationen zu
 erhalten.")))
 
  (entry (commit "82daab42811a2e3c7684ebdf12af75ff0fa67b99")

etc/release-manifest.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -23,10 +23,9 @@
 (use-modules (gnu packages)
              (guix packages)
              (guix profiles)
-             ((guix platform) #:select (targets))
+             ((gnu ci) #:select (%cross-targets))
              ((gnu services xorg) #:select (%default-xorg-modules))
              (guix utils)
-             (guix gexp)
              (srfi srfi-1)
              (srfi srfi-26))
 
@@ -51,17 +50,18 @@ TARGET."
          "openssh" "emacs" "vim" "python" "guile" "guix")))
 
 (define %base-packages/armhf
-  ;; The guix package doesn't build natively on armhf due to Guile memory
-  ;; issues compiling the package modules
-  (remove (lambda (package)
-            (string=? (package-name package) "guix"))
-          %base-packages))
+  ;; XXX: Relax requirements for armhf-linux for lack of enough build power.
+  (map (lambda (package)
+         (if (string=? (package-name package) "emacs")
+             (specification->package "emacs-no-x")
+             package))
+       %base-packages))
 
 (define %base-packages/hurd
   ;; XXX: For now we are less demanding of "i586-gnu".
   (map specification->package
        '("coreutils" "grep" "findutils" "gawk" "make"
-         #;"gcc-toolchain" "tar" "xz")))
+         "gcc-toolchain" "tar" "xz")))
 
 (define %system-packages
   ;; Key packages proposed by the Guix System installer.
@@ -111,6 +111,8 @@ TARGET."
                       (cond ((string=? system "i586-gnu")
                              %base-packages/hurd)
                             ((string=? system "armhf-linux")
+                             ;; FIXME: Drop special case when ci.guix.gnu.org
+                             ;; has more ARMv7 build power.
                              %base-packages/armhf)
                             ((string=? system "powerpc64le-linux")
                              ;; FIXME: Drop 'bootstrap-tarballs' until
@@ -140,16 +142,9 @@ TARGET."
                       (if (target-mingw? target)
                           %packages-to-cross-build-for-mingw
                           %packages-to-cross-build)))
-               (fold delete (targets)
-                     '(;; Like in (gnu ci), dismiss cross-compilation to x86:
-                       ;; it's pointless.
-                       "x86_64-linux-gnu"
-                       "i686-linux-gnu"
-
-                       ;; XXX: Important bits like libsigsegv and libffi don't
-                       ;; support RISCV at the moment, so don't require RISCV
-                       ;; support.
-                       "riscv64-linux-gnu")))))
+               ;; XXX: Important bits like libsigsegv and libffi don't support
+               ;; RISCV at the moment, so don't require RISCV support.
+               (delete "riscv64-linux-gnu" %cross-targets))))
 
 (define %cross-bootstrap-manifest
   (manifest

etc/snippets/scheme-mode/guix-package

@@ -11,7 +11,6 @@
                                           "ant-build-system"
                                           "asdf-build-system"
                                           "cargo-build-system"
-                                          "chicken-build-system"
                                           "clojure-build-system"
                                           "cmake-build-system"
                                           "copy-build-system"
@@ -28,7 +27,6 @@
                                           "linux-module-build-system"
                                           "maven-build-system"
                                           "meson-build-system"
-                                          "minetest-build-system"
                                           "minify-build-system"
                                           "node-build-system"
                                           "ocaml-build-system"
@@ -37,8 +35,6 @@
                                           "qt-build-system"
                                           "r-build-system"
                                           "rakudo-build-system"
-                                          "rebar-build-system"
-                                          "renpy-build-system"
                                           "ruby-build-system"
                                           "scons-build-system"
                                           "texlive-build-system"

etc/snippets/tempel/scheme-mode

@@ -1,89 +0,0 @@
--*- mode: lisp-data -*-
-
-scheme-mode
-
-(package...
- "(define-public " (s name)
- n> "(package"
- n  > "(name \"" (s name) "\")"
- n  > "(version \"" p "\")"
- n  > "(source origin...)"
- n  > "(build-system " (p "gnu") "-build-system)"
- n  > "(home-page \"" p "\")"
- n  > "(synopsis \"" p "\")"
- n  > "(description \"" p "\")"
- n  > "(license license:" (p "unknown") ")))" n)
-
-(origin...
- "(origin"
- n> "(method " (p "url-fetch" method) ")"
- n> "(uri " (cl-case (and method (intern method))
-              ('git-fetch "git-reference...")
-              ('svn-fetch "svn-reference...")
-              ('hg-fetch  "hg-reference...")
-              ('cvs-fetch "cvs-reference...")
-              ('bzr-fetch "bzr-reference...")
-              (t          "\"https://...\""))
- ")"
- n>
- (cl-case (and method (intern method))
-   ('git-fetch
-    (insert "(file-name (git-file-name name version))")
-    (newline)
-    (indent-according-to-mode))
-   ('hg-fetch
-    (insert "(file-name (hg-file-name name version))")
-    (newline)
-    (indent-according-to-mode))
-   ('svn-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   ('cvs-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   ('bzr-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   (t          ""))
- > "(sha256"
- n > "(base32 \""
- ;; hash of an empty directory
- (p "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") "\")))")
-
-(git-reference...
- "(git-reference"
- n> "(url \"" p "\")"
- n> "(commit \"" p "\"))")
-
-(svn-reference...
- "(svn-reference"
- n> "(url \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(cvs-reference...
- "(cvs-reference"
- n> "(root-directory \"" p "\")"
- n> "(module \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(hg-reference...
- "(hg-reference"
- n> "(url \"" p "\")"
- n> "(changeset \"" p "\"))")
-
-(bzr-reference...
- "(bzr-reference"
- n> "(url \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(:phases\ "#:phases (modify-phases %standard-phases"
-          n> p ")")
-
-(add-before\ "(add-before '" p " '" p
-             n > p ")")
-(add-after\ "(add-after '" p " '" p
-            n > p ")")
-(replace\ "(replace '" p " " p")")

etc/snippets/tempel/text-mode

@@ -1,158 +0,0 @@
--*- mode: lisp-data -*-
-
-text-mode :when (and (fboundp 'git-commit-mode) (git-commit-mode))
-
-(add\ "gnu: Add "
-      (p (with-temp-buffer
-           (magit-git-wash #'magit-diff-wash-diffs
-             "diff" "--staged")
-           (goto-char (point-min))
-           (when (re-search-forward "\\+(define-public \\(\\S-+\\)"
-                                    nil 'noerror)
-             (match-string-no-properties 1)))
-         var)
-      "." n n
-      "* " (p (or (car (magit-staged-files)) ""))
-      " (" (s var ) "): New variable.")
-
-(remove\ "gnu: Remove "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (when (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                       nil 'noerror)
-                (match-string-no-properties 1)))
-            var)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) ""))
-         " (" (s var) "): Delete variable.")
-
-(rename\ "gnu: "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (beginning-of-buffer)
-              (when (search-forward "-(define-public " nil 'noerror)
-                (thing-at-point 'sexp 'no-properties)))
-            prev-var)
-         ": Rename package to "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (beginning-of-buffer)
-              (when (search-forward "+(define-public " nil 'noerror)
-                (thing-at-point 'sexp 'no-properties)))
-            new-var)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) "")) " (" (s prev-var) "): "
-         "Define in terms of" n
-         "'deprecated-package'." n
-         "(" (s new-var) "): New variable, formerly known as \""
-         (s prev-var) "\".")
-
-(update\ "gnu: "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)"
-                                       nil 'noerror)
-                (match-string-no-properties 1)))
-            var)
-         ": Update to "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (search-forward "name" nil 'noerror)
-              (search-forward "+" nil 'noerror)   ; first change
-              (when (and (search-forward "version " nil 'noerror)
-                         (looking-at-p "\""))
-                (let ((end (save-excursion (search-forward "\")"
-                                                           nil 'noerror))))
-                  (when end
-                    (forward-char)
-                    (buffer-substring-no-properties (point) (- end 2))))))
-            version)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) "")) " (" (s var) "): "
-         "Update to " (s version) "." n
-         (mapconcat (lambda (file) (concat "* " file))
-                    (cdr (magit-staged-files))
-                    "\n"))
-
-(addcl\ "gnu: Add cl-"
-        (p (replace-regexp-in-string
-            "^cl-" "" (with-temp-buffer
-                        (magit-git-wash #'magit-diff-wash-diffs
-                          "diff" "--staged")
-                        (beginning-of-buffer)
-                        (when (search-forward "+(define-public " nil 'noerror)
-                          (replace-regexp-in-string
-                           "^sbcl-" ""
-                           (thing-at-point 'sexp 'no-properties)))))
-           var)
-        "." n n
-        "* " (p (or (car (magit-staged-files)) ""))
-        " (cl-" (s var)
-        ", ecl-" (s var)
-        ", sbcl-" (s var) "): New variables.")
-
-(https\ "gnu: "
-        (p (with-temp-buffer
-             (magit-git-wash #'magit-diff-wash-diffs
-               "diff" "--staged")
-             (goto-char (point-min))
-             (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)"
-                                      nil 'noerror)
-               (match-string-no-properties 1)))
-           var)
-        ": Use HTTPS home page." n n
-        "* " (p (or (car (magit-staged-files)) ""))
-        " (" (s var) ")[home-page]: Use HTTPS."
-        n
-        (mapconcat (lambda (file) (concat "* " file))
-                   (cdr (magit-staged-files))
-                   "\n"))
-
-(move\ "gnu: "
-       (p (with-temp-buffer
-            (magit-git-wash #'magit-diff-wash-diffs
-              "diff" "--staged")
-            (goto-char (point-min))
-            (when (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                     nil 'noerror)
-              (match-string-no-properties 1)))
-          var)
-       ": Move to ("
-       (p (with-temp-buffer
-            (magit-git-wash #'magit-diff-wash-diffs
-              "diff" "--staged")
-            (goto-char (point-min))
-            (when (and
-                   (re-search-forward "\\+(define-public \\(\\S-+\\)"
-                                      nil 'noerror)
-                   (re-search-backward "modified[ ]*\\(\\S-+\\)"
-                                       nil 'noerror))
-              (string-replace
-               "\.scm" ""
-               (string-replace "/" " "
-                               (match-string-no-properties 1)))))
-          new-module)
-       ")." n
-       n
-       "* " (p (with-temp-buffer
-                  (magit-git-wash #'magit-diff-wash-diffs
-                    "diff" "--staged")
-                  (goto-char (point-min))
-                  (when (and
-                         (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                            nil 'noerror)
-                         (re-search-backward "modified[ ]*\\(\\S-+\\)"
-                                             nil 'noerror))
-                    (match-string-no-properties 1)))
-                source)
-       " (" (s var) "): Move from here…" n
-       "* " (concat (string-replace " " "/" new-module) ".scm")
-       " (" (s var) "): …to here.")

etc/snippets/yas/text-mode/guix-commit-message-remove-package

@@ -1,13 +0,0 @@
-# -*- mode: snippet -*-
-# name: guix-commit-message-remove-package
-# key: remove
-# condition: git-commit-mode
-# --
-gnu: Remove ${1:`(with-temp-buffer
-                   (magit-git-wash #'magit-diff-wash-diffs
-                     "diff" "--staged")
-                   (goto-char (point-min))
-                   (when (re-search-forward "\\-(define-public \\(\\S-+\\)" nil 'noerror)
-                     (match-string-no-properties 1)))`}.
-
-* `(car (magit-staged-files))` ($1): Delete variable.

etc/system-tests.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018-2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,8 +18,7 @@
 
 (use-modules (gnu tests)
              (gnu packages package-management)
-             (guix monads)
-             (guix store)
+             ((gnu ci) #:select (channel-source->package))
              ((guix git-download) #:select (git-predicate))
              ((guix utils) #:select (current-source-directory))
              (git)
@@ -49,19 +48,15 @@ instance."
   ;; of tests to run in the usual way:
   ;;
   ;;   make check-system TESTS=installed-os
-  (let ((guix (channel-source->package source #:commit commit)))
-    (map (lambda (test)
-           (system-test
-            (inherit test)
-            (value (mparameterize %store-monad ((current-guix-package guix))
-                     (system-test-value test)))))
-         (match (getenv "TESTS")
-           (#f
-            (all-system-tests))
-           ((= string-tokenize (tests ...))
-            (filter (lambda (test)
-                      (member (system-test-name test) tests))
-                    (all-system-tests)))))))
+  (parameterize ((current-guix-package
+                  (channel-source->package source #:commit commit)))
+    (match (getenv "TESTS")
+      (#f
+       (all-system-tests))
+      ((= string-tokenize (tests ...))
+       (filter (lambda (test)
+                 (member (system-test-name test) tests))
+               (all-system-tests))))))
 
 (define (system-test->manifest-entry test)
   "Return a manifest entry for TEST, a system test."

etc/teams.scm.in

@@ -1,624 +0,0 @@
-#!@GUILE@ \
---no-auto-compile -s
-!#
-
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
-;;;
-;;; 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 code defines development teams and team members, as well as their
-;; scope.
-
-;;; Code:
-
-(use-modules (srfi srfi-1)
-             (srfi srfi-9)
-             (srfi srfi-26)
-             (ice-9 format)
-             (ice-9 regex)
-             (ice-9 match)
-             (guix ui)
-             (git))
-
-(define-record-type <team>
-  (make-team id name description members scope)
-  team?
-  (id          team-id)
-  (name        team-name)
-  (description team-description)
-  (members     team-members set-team-members!)
-  (scope       team-scope))
-
-(define-record-type <person>
-  (make-person name email)
-  person?
-  (name    person-name)
-  (email   person-email))
-
-(define* (person name #:optional email)
-  (make-person name email))
-
-(define* (team id #:key name description (members '())
-               (scope '()))
-  (make-team id
-             (or name (symbol->string id))
-             description
-             members
-             scope))
-
-(define %teams
-  (make-hash-table))
-
-(define-syntax define-team
-  (lambda (x)
-    (syntax-case x ()
-      ((_ id value)
-       #`(begin
-           (define-public id value)
-           (hash-set! %teams 'id id))))))
-
-(define-syntax-rule (define-member person teams ...)
-  (let ((p person))
-    (for-each (lambda (team-id)
-                (let ((team
-                       (hash-ref %teams team-id
-                                 (lambda ()
-                                   (error (format #false
-                                                  "Unknown team ~a for ~a~%"
-                                                  team-id p))))))
-                  (set-team-members!
-                   team (cons p (team-members team)))))
-              (quote (teams ...)))))
-
-
-(define-team python
-  (team 'python
-        #:name "Python team"
-        #:description
-        "Python, Python packages, the \"pypi\" importer, and the python-build-system."
-        #:scope
-        (list "gnu/packages/django.scm"
-              "gnu/packages/jupyter.scm"
-              ;; Match haskell.scm and haskell-*.scm.
-              (make-regexp "^gnu/packages/python(-.+|)\\.scm$")
-              "gnu/packages/sphinx.scm"
-              "gnu/packages/tryton.scm"
-              "guix/build/pyproject-build-system.scm"
-              "guix/build-system/pyproject.scm"
-              "guix/build/python-build-system.scm"
-              "guix/build-system/python.scm"
-              "guix/import/pypi.scm"
-              "guix/scripts/import/pypi.scm"
-              "tests/pypi.scm")))
-
-(define-team haskell
-  (team 'haskell
-        #:name "Haskell team"
-        #:description
-        "GHC, Hugs, Haskell packages, the \"hackage\" and \"stackage\" importers, and
-the haskell-build-system."
-        #:scope
-        (list "gnu/packages/dhall.scm"
-              ;; Match haskell.scm and haskell-*.scm.
-              (make-regexp "^gnu/packages/haskell(-.+|)\\.scm$")
-              "gnu/packages/purescript.scm"
-              "guix/build/haskell-build-system.scm"
-              "guix/build-system/haskell.scm"
-              "guix/import/cabal.scm"
-              "guix/import/hackage.scm"
-              "guix/import/stackage.scm"
-              "guix/scripts/import/hackage.scm")))
-
-(define-team r
-  (team 'r
-        #:name "R team"
-        #:description
-        "The R language, CRAN and Bioconductor repositories, the \"cran\" importer,
-and the r-build-system."
-        #:scope (list "gnu/packages/bioconductor.scm"
-                      "gnu/packages/cran.scm"
-                      "guix/build/r-build-system.scm"
-                      "guix/build-system/r.scm"
-                      "guix/import/cran.scm"
-                      "guix/scripts/import/cran.scm"
-                      "tests/cran.scm")))
-
-(define-team julia
-  (team 'julia
-        #:name "Julia team"
-        #:description
-        "The Julia language, Julia packages, and the julia-build-system."
-        #:scope (list (make-regexp "^gnu/packages/julia(-.+|)\\.scm$")
-                      "guix/build/julia-build-system.scm"
-                      "guix/build-system/julia.scm")))
-
-(define-team ocaml
-  (team 'ocaml
-        #:name "OCaml and Dune team"
-        #:description
-        "The OCaml language, the Dune build system, OCaml packages, the \"opam\"
-importer, and the ocaml-build-system."
-        #:scope
-        (list "gnu/packages/ocaml.scm"
-              "gnu/packages/coq.scm"
-              "guix/build/ocaml-build-system.scm"
-              "guix/build/dune-build-system.scm"
-              "guix/build-system/ocaml.scm"
-              "guix/build-system/dune.scm"
-              "guix/import/opam.scm"
-              "guix/scripts/import/opam.scm"
-              "tests/opam.scm")))
-
-(define-team java
-  (team 'java
-        #:name "Java and Maven team"
-        #:description
-        "The JDK and JRE, the Maven build system, Java packages, the ant-build-system,
-and the maven-build-system."
-        #:scope
-        (list ;; Match java.scm and java-*.scm.
-              (make-regexp "^gnu/packages/java(-.+|)\\.scm$")
-              ;; Match maven.scm and maven-*.scm
-              (make-regexp "^gnu/packages/maven(-.+|)\\.scm$")
-              "guix/build/ant-build-system.scm"
-              "guix/build/java-utils.scm"
-              "guix/build/maven-build-system.scm"
-              ;; The maven directory
-              (make-regexp "^guix/build/maven/")
-              "guix/build-system/ant.scm"
-              "guix/build-system/maven.scm")))
-
-(define-team science
-  (team 'science
-        #:name "Science team"))
-
-(define-team emacs
-  (team 'emacs
-        #:name "Emacs team"
-        #:description "The extensible, customizable text editor and its
-ecosystem."
-        #:scope (list (make-regexp "^gnu/packages/emacs(-.+|)\\.scm$")
-                      "guix/build/emacs-build-system.scm"
-                      "guix/build/emacs-utils.scm"
-                      "guix/build-system/emacs.scm"
-                      "guix/import/elpa.scm"
-                      "guix/scripts/import/elpa.scm"
-                      "tests/elpa.scm")))
-
-(define-team lisp
-  (team 'lisp
-        #:name "Lisp team"
-        #:description
-        "Common Lisp and similar languages, Common Lisp packages and the
-asdf-build-system."
-        #:scope (list (make-regexp "^gnu/packages/lisp(-.+|)\\.scm$")
-                      "guix/build/asdf-build-system.scm"
-                      "guix/build/lisp-utils.scm"
-                      "guix/build-system/asdf.scm")))
-
-(define-team ruby
-  (team 'ruby
-        #:name "Ruby team"
-        #:scope (list "gnu/packages/ruby.scm"
-                      "guix/build/ruby-build-system.scm"
-                      "guix/build-system/ruby.scm"
-                      "guix/import/gem.scm"
-                      "guix/scripts/import/gem.scm"
-                      "tests/gem.scm")))
-
-(define-team go
-  (team 'go
-        #:name "Go team"
-        #:scope (list "gnu/packages/golang.scm"
-                      "guix/build/go-build-system.scm"
-                      "guix/build-system/go.scm"
-                      "guix/import/go.scm"
-                      "guix/scripts/import/go.scm"
-                      "tests/go.scm")))
-
-(define-team embedded-bootstrap
-  (team 'embedded-bootstrap
-        #:name "Embedded / Bootstrap"))
-
-(define-team rust
-  (team 'rust
-        #:name "Rust"
-        #:scope (list (make-regexp "^gnu/packages/(crates|rust)(-.+|)\\.scm$")
-                      "guix/build/cargo-build-system.scm"
-                      "guix/build/cargo-utils.scm"
-                      "guix/build-system/cargo.scm"
-                      "guix/import/crate.scm"
-                      "guix/scripts/import/crate.scm"
-                      "tests/crate.scm")))
-
-(define-team kernel
-  (team 'kernel
-        #:name "Linux-libre kernel team"
-        #:scope (list "gnu/build/linux-modules.scm"
-                      "gnu/packages/linux.scm"
-                      "gnu/tests/linux-modules.scm"
-                      "guix/build/linux-module-build-system.scm"
-                      "guix/build-system/linux-module.scm")))
-
-(define-team core
-  (team 'core
-        #:name "Core / Tools / Internals"
-        #:scope
-        (list "guix/avahi.scm"
-              "guix/base16.scm"
-              "guix/base32.scm"
-              "guix/base64.scm"
-              "guix/bzr-download.scm"
-              "guix/cache.scm"
-              "guix/channels.scm"
-              "guix/ci.scm"
-              "guix/colors.scm"
-              "guix/combinators.scm"
-              "guix/config.scm"
-              "guix/cpio.scm"
-              "guix/cpu.scm"
-              "guix/cve.scm"
-              "guix/cvs-download.scm"
-              "guix/deprecation.scm"
-              "guix/derivations.scm"
-              "guix/describe.scm"
-              "guix/diagnostics.scm"
-              "guix/discovery.scm"
-              "guix/docker.scm"
-              "guix/download.scm"
-              "guix/elf.scm"
-              "guix/ftp-client.scm"
-              "guix/gexp.scm"
-              "guix/git-authenticate.scm"
-              "guix/git-download.scm"
-              "guix/git.scm"
-              "guix/glob.scm"
-              "guix/gnu-maintenance.scm"
-              "guix/gnupg.scm"
-              "guix/grafts.scm"
-              "guix/graph.scm"
-              "guix/hash.scm"
-              "guix/hg-download.scm"
-              "guix/http-client.scm"
-              "guix/i18n.scm"
-              "guix/inferior.scm"
-              "guix/ipfs.scm"
-              "guix/least-authority.scm"
-              "guix/licenses.scm"
-              "guix/lint.scm"
-              "guix/man-db.scm"
-              "guix/memoization.scm"
-              "guix/modules.scm"
-              "guix/monad-repl.scm"
-              "guix/monads.scm"
-              "guix/narinfo.scm"
-              "guix/nar.scm"
-              "guix/openpgp.scm"
-              "guix/packages.scm"
-              "guix/pki.scm"
-              "guix/platform.scm"
-              "guix/profiles.scm"
-              "guix/profiling.scm"
-              "guix/progress.scm"
-              "guix/quirks.scm"
-              "guix/read-print.scm"
-              "guix/records.scm"
-              "guix/remote.scm"
-              "guix/repl.scm"
-              "guix/search-paths.scm"
-              "guix/self.scm"
-              "guix/serialization.scm"
-              "guix/sets.scm"
-              "guix/ssh.scm"
-              "guix/status.scm"
-              "guix/store.scm"
-              "guix/substitutes.scm"
-              "guix/svn-download.scm"
-              "guix/swh.scm"
-              "guix/tests.scm"
-              "guix/transformations.scm"
-              "guix/ui.scm"
-              "guix/upstream.scm"
-              "guix/utils.scm"
-              "guix/workers.scm"
-              (make-regexp "^guix/platforms/")
-              (make-regexp "^guix/scripts/")
-              (make-regexp "^guix/store/"))))
-
-(define-team games
-  (team 'games
-        #:name "Games and Toys"
-        #:description "Packaging programs for amusement."
-        #:scope (list "gnu/packages/games.scm"
-                      "gnu/packages/game-development.scm"
-                      "gnu/packages/minetest.scm"
-                      "gnu/packages/esolangs.scm" ; granted, rather niche
-                      "gnu/packages/motti.scm"
-                      "guix/build/minetest-build-system.scm")))
-
-(define-team translations
-  (team 'translations
-        #:name "Translations"
-        #:scope (list "etc/news.scm"
-                      (make-regexp "^po/"))))
-
-(define-team installer
-  (team 'installer
-        #:name "Installer script and system installer"
-        #:scope (list (make-regexp "^gnu/installer(\\.scm$|/)"))))
-
-(define-team home
-  (team 'home
-        #:name "Team for \"Guix Home\""
-        #:scope (list (make-regexp "^(gnu|guix/scripts)/home(\\.scm$|/)")
-                      "tests/guix-home.sh"
-                      "tests/home-import.scm"
-                      "tests/home-services.scm")))
-
-(define-team mentors
-  (team 'mentors
-        #:name "Mentors"
-        #:description
-        "A group of mentors who chaperone contributions by newcomers."))
-
-(define-team mozilla
-  (team 'mozilla
-        #:name "Mozilla"
-        #:description
-        "Taking care about Icecat and Icedove, built from Mozilla Firefox
-and Thunderbird."
-        #:scope (list "gnu/packages/gnuzilla.scm")))
-
-(define-team racket
-  (team 'racket
-        #:name "Racket team"
-        #:description
-        "The Racket language and Racket-based languages, Racket packages,
-Racket's variant of Chez Scheme, and development of a Racket build system and
-importer."
-        #:scope (list "gnu/packages/racket.scm")))
-
-
-(define-member (person "Thiago Jung Bauermann"
-                       "bauermann@kolabnow.com")
-  embedded-bootstrap translations)
-
-(define-member (person "Eric Bavier"
-                       "bavier@posteo.net")
-  science)
-
-(define-member (person "Lars-Dominik Braun"
-                       "lars@6xq.net")
-  python haskell)
-
-(define-member (person "Jonathan Brielmaier"
-                       "jonathan.brielmaier@web.de")
-  mozilla)
-
-(define-member (person "Ludovic Courtès"
-                       "ludo@gnu.org")
-  core home embedded-bootstrap mentors)
-
-(define-member (person "Andreas Enge"
-                       "andreas@enge.fr")
-  science)
-
-(define-member (person "Björn Höfling"
-                       "bjoern.hoefling@bjoernhoefling.de")
-  java)
-
-(define-member (person "Leo Famulari"
-                       "leo@famulari.name")
-  kernel)
-
-(define-member (person "Efraim Flashner"
-                       "efraim@flashner.co.il")
-  embedded-bootstrap julia rust science)
-
-(define-member (person "jgart"
-                       "jgart@dismail.de")
-  python lisp mentors)
-
-(define-member (person "Guillaume Le Vaillant"
-                       "glv@posteo.net")
-  lisp)
-
-(define-member (person "Julien Lepiller"
-                       "julien@lepiller.eu")
-  java ocaml translations)
-
-(define-member (person "Philip McGrath"
-                       "philip@philipmcgrath.com")
-  racket)
-
-(define-member (person "Mathieu Othacehe"
-                       "othacehe@gnu.org")
-  core installer mentors)
-
-(define-member (person "Florian Pelz"
-                       "pelzflorian@pelzflorian.de")
-  translations)
-
-(define-member (person "Liliana Marie Prikler"
-                       "liliana.prikler@gmail.com")
-  emacs games)
-
-(define-member (person "Ricardo Wurmus"
-                       "rekado@elephly.net")
-  r core mentors)
-
-(define-member (person "Christopher Baines"
-                       "mail@cbaines.net")
-  core mentors ruby)
-
-(define-member (person "Andrew Tropin"
-                       "andrew@trop.in")
-  home emacs)
-
-(define-member (person "pukkamustard"
-                       "pukkamustard@posteo.net")
-  ocaml)
-
-(define-member (person "Josselin Poiret"
-                       "dev@jpoiret.xyz")
-  core installer)
-
-(define-member (person "("
-                       "paren@disroot.org")
-  home mentors)
-
-(define-member (person "Simon Tournier"
-                       "zimon.toutoune@gmail.com")
-  julia core mentors)
-
-(define-member (person "Raghav Gururajan"
-                       "rg@raghavgururajan.name")
-  mentors)
-
-
-(define (find-team name)
-  (or (hash-ref %teams (string->symbol name))
-      (error (format #false
-                           "no such team: ~a~%" name))))
-
-(define (find-team-by-scope files)
-  "Return the team(s) which scope matches at least one of the FILES, as list
-of file names as string."
-  (hash-fold
-   (lambda (key team acc)
-     (if (any (lambda (file)
-                (any (match-lambda
-                       ((? string? scope)
-                        (string=? scope file))
-                       ((? regexp? scope)
-                        (regexp-exec scope file)))
-                     (team-scope team)))
-              files)
-         (cons team acc)
-         acc))
-   '()
-   %teams))
-
-(define (cc . teams)
-  "Return arguments for `git send-email' to notify the members of the given
-TEAMS when a patch is received by Debbugs."
-  (format #true
-          "~{--add-header=\"X-Debbugs-Cc: ~a\"~^ ~}"
-          (map person-email
-               (delete-duplicates (append-map team-members teams) equal?))))
-
-(define* (list-members team #:optional port (prefix ""))
-  "Print the members of the given TEAM."
-  (define port* (or port (current-output-port)))
-  (for-each
-   (lambda (member)
-     (format port*
-             "~a~a <~a>~%"
-             prefix
-             (person-name member)
-             (person-email member)))
-   (sort
-    (team-members team)
-    (lambda (m1 m2) (string<? (person-name m1) (person-name m2))))))
-
-(define (list-teams)
-  "Print all teams, their scope and their members."
-  (define port* (current-output-port))
-  (define width* (%text-width))
-  (for-each
-   (lambda (team)
-     (format port*
-             "\
-id: ~a
-name: ~a
-description: ~a
-~amembers:
-"
-             (team-id team)
-             (team-name team)
-             (or (and=> (team-description team)
-                        (lambda (text)
-                          (string->recutils
-                           (fill-paragraph text width*
-                                           (string-length "description: ")))))
-                 "<none>")
-             (match (team-scope team)
-               (() "")
-               (scope (format #f "scope: ~{~s ~}~%" scope))))
-     (list-members team port* "+ ")
-     (newline))
-   (sort
-    (hash-map->list (lambda (key value) value) %teams)
-    (lambda (team1 team2)
-      (string<? (symbol->string (team-id team1))
-                (symbol->string (team-id team2)))))))
-
-
-(define (diff-revisions rev-start rev-end)
-  "Return the list of added, modified or removed files between REV-START
-and REV-END, two git revision strings."
-  (let* ((repository (repository-open (getcwd)))
-         (commit1 (commit-lookup repository
-                                 (object-id
-                                  (revparse-single repository rev-start))))
-         (commit2 (commit-lookup repository
-                                 (object-id
-                                  (revparse-single repository rev-end))))
-         (diff (diff-tree-to-tree repository
-                                  (commit-tree commit1)
-                                  (commit-tree commit2)))
-         (files '()))
-    (diff-foreach
-     diff
-     (lambda (delta progress)
-       (set! files
-             (cons (diff-file-path (diff-delta-old-file delta)) files))
-       0)
-     (const 0)
-     (const 0)
-     (const 0))
-    files))
-
-
-(define (main . args)
-  (match args
-    (("cc" . team-names)
-     (apply cc (map find-team team-names)))
-    (("cc-members" rev-start rev-end)
-     (apply cc (find-team-by-scope
-                (diff-revisions rev-start rev-end))))
-    (("list-teams" . args)
-     (list-teams))
-    (("list-members" . team-names)
-     (for-each
-      (lambda (team-name)
-        (list-members (find-team team-name)))
-      team-names))
-    (anything
-     (format (current-error-port)
-             "Usage: etc/teams.scm <command> [<args>]
-
-Commands:
-  cc <team-name>            get git send-email flags for cc-ing <team-name>
-  cc-members <start> <end>  cc teams related to files changed between revisions
-  list-teams                list teams and their members
-  list-members <team-name>  list members belonging to <team-name>~%"))))
-
-(apply main (cdr (command-line)))

etc/time-travel-manifest.scm

@@ -1,84 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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 file returns a manifest containing entries to build past Guix
-;;; releases from the current Guix, as per 'guix time-machine'.
-
-(use-modules (srfi srfi-9) (ice-9 match)
-             (guix channels) (guix gexp)
-             ((guix store) #:select (%store-monad))
-             ((guix monads) #:select (mparameterize return))
-             ((guix git) #:select (%repository-cache-directory))
-             ((guix build utils) #:select (mkdir-p)))
-
-;; Representation of the latest channels.  This type exists just so we can
-;; refer to such records in a gexp.
-(define-record-type <guix-instance>
-  (guix-instance channels)
-  guix-instance?
-  (channels guix-instance-channels))
-
-(define-gexp-compiler (guix-instance-compiler (instance <guix-instance>)
-                                              system target)
-  (match instance
-    (($ <guix-instance> channels)
-     ;; When this manifest is evaluated by Cuirass, make sure it does not
-     ;; fiddle with the cached checkout that Cuirass is also using since
-     ;; concurrent accesses are unsafe.
-     (mparameterize %store-monad ((%repository-cache-directory
-                                   (string-append (%repository-cache-directory)
-                                                  "/time-travel/" system)))
-       (return (mkdir-p (%repository-cache-directory)))
-       (latest-channel-derivation channels)))))
-
-(define (guix-instance->manifest-entry instance)
-  "Return a manifest entry for INSTANCE."
-  (define (shorten commit)
-    (string-take commit 7))
-
-  (manifest-entry
-    (name "guix")
-    (version (string-join (map (compose shorten channel-commit)
-                               (guix-instance-channels instance))
-                          "-"))
-    (item instance)))
-
-(define (commit->guix-instance commit)
-  "Return a Guix instance for COMMIT."
-  (guix-instance (list (channel
-                        (inherit %default-guix-channel)
-                        (commit commit)))))
-
-(define %release-commits
-  ;; Release commits: the list of version/commit pairs.
-  '(("1.3.0" . "a0178d34f582b50e9bdbb0403943129ae5b560ff")
-    ("1.2.0" . "a099685659b4bfa6b3218f84953cbb7ff9e88063")
-    ("1.1.0" . "d62c9b2671be55ae0305bebfda17b595f33797f2")
-    ("1.0.1" . "d68de958b60426798ed62797ff7c96c327a672ac")
-    ("1.0.0" . "6298c3ffd9654d3231a6f25390b056483e8f407c")
-    ("0.16.0" . "4a0b87f0ec5b6c2dcf82b372dd20ca7ea6acdd9c")))
-
-(manifest
- (map (match-lambda
-        ((version . commit)
-         (let ((entry (guix-instance->manifest-entry
-                       (commit->guix-instance commit))))
-           (manifest-entry
-             (inherit entry)
-             (version version)))))
-      %release-commits))

gnu/artwork.scm

@@ -29,7 +29,7 @@
 ;;; Code:
 
 (define %artwork-repository
-  (let ((commit "4c7f2ce6428a63e202cd2a9474a06f68a946934d"))
+  (let ((commit "2f2fe74c1078be605a6a93c2193fd6c715cebbb0"))
     (origin
       (method git-fetch)
       (uri (git-reference
@@ -39,6 +39,6 @@
                                 "-checkout"))
       (sha256
        (base32
-        "1rl569759q9wm1dxn7nkq3873d2k92giic7aa6jwzwr3n16prc7y")))))
+        "0c8r0phvm3wgf914n2kw1461cwdjl2zbzqvzq9x7d9pwkgv7xmq7")))))
 
 ;;; artwork.scm ends here

gnu/bootloader.scm

@@ -1,11 +1,9 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 David Craven <david@craven.ch>
-;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
-;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,8 +21,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu bootloader)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system uuid)
   #:use-module (guix discovery)
   #:use-module (guix gexp)
   #:use-module (guix profiles)
@@ -34,8 +30,6 @@
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (menu-entry
             menu-entry?
@@ -48,7 +42,6 @@
             menu-entry-multiboot-kernel
             menu-entry-multiboot-arguments
             menu-entry-multiboot-modules
-            menu-entry-chain-loader
 
             menu-entry->sexp
             sexp->menu-entry
@@ -76,7 +69,7 @@
             bootloader-configuration-terminal-inputs
             bootloader-configuration-serial-unit
             bootloader-configuration-serial-speed
-            bootloader-configuration-device-tree-support?
+            bootloader-configuration-additional-configuration
 
             %bootloaders
             lookup-bootloader-by-name
@@ -107,77 +100,34 @@
   (multiboot-arguments menu-entry-multiboot-arguments
                        (default '()))      ; list of string-valued gexps
   (multiboot-modules menu-entry-multiboot-modules
-                     (default '()))        ; list of multiboot commands, where
+                     (default '())))       ; list of multiboot commands, where
                                            ; a command is a list of <string>
-  (chain-loader     menu-entry-chain-loader
-                    (default #f)))         ; string, path of efi file
-
-(define (report-menu-entry-error menu-entry)
-  (raise
-   (condition
-    (&message
-     (message
-      (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
-    (&fix-hint
-     (hint
-      (G_ "Please chose only one of:
-@enumerate
-@item direct boot by specifying fields @code{linux},
-@code{linux-arguments} and @code{linux-modules},
-@item multiboot by specifying fields @code{multiboot-kernel},
-@code{multiboot-arguments} and @code{multiboot-modules},
-@item chain-loader by specifying field @code{chain-loader}.
-@end enumerate"))))))
 
 (define (menu-entry->sexp entry)
   "Return ENTRY serialized as an sexp."
-  (define (device->sexp device)
-    (match device
-      ((? uuid? uuid)
-       `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
-      ((? file-system-label? label)
-       `(label ,(file-system-label->string label)))
-      (_ device)))
   (match entry
-    (($ <menu-entry> label device mount-point
-                     (? identity linux) linux-arguments (? identity initrd)
-                     #f () () #f)
+    (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
+                     ())
      `(menu-entry (version 0)
                   (label ,label)
-                  (device ,(device->sexp device))
+                  (device ,device)
                   (device-mount-point ,mount-point)
                   (linux ,linux)
                   (linux-arguments ,linux-arguments)
                   (initrd ,initrd)))
     (($ <menu-entry> label device mount-point #f () #f
-                     (? identity multiboot-kernel) multiboot-arguments
-                     multiboot-modules #f)
+                     multiboot-kernel multiboot-arguments multiboot-modules)
      `(menu-entry (version 0)
                   (label ,label)
-                  (device ,(device->sexp device))
+                  (device ,device)
                   (device-mount-point ,mount-point)
                   (multiboot-kernel ,multiboot-kernel)
                   (multiboot-arguments ,multiboot-arguments)
-                  (multiboot-modules ,multiboot-modules)))
-    (($ <menu-entry> label device mount-point #f () #f #f () ()
-                     (? identity chain-loader))
-     `(menu-entry (version 0)
-                  (label ,label)
-                  (device ,(device->sexp device))
-                  (device-mount-point ,mount-point)
-                  (chain-loader ,chain-loader)))
-    (_ (report-menu-entry-error entry))))
+                  (multiboot-modules ,multiboot-modules)))))
 
 (define (sexp->menu-entry sexp)
   "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
 record."
-  (define (sexp->device device-sexp)
-    (match device-sexp
-      (('uuid type uuid-string)
-       (uuid uuid-string type))
-      (('label label)
-       (file-system-label label))
-      (_ device-sexp)))
   (match sexp
     (('menu-entry ('version 0)
                   ('label label) ('device device)
@@ -186,7 +136,7 @@ record."
                   ('initrd initrd) _ ...)
      (menu-entry
       (label label)
-      (device (sexp->device device))
+      (device device)
       (device-mount-point mount-point)
       (linux linux)
       (linux-arguments linux-arguments)
@@ -199,20 +149,11 @@ record."
                   ('multiboot-modules multiboot-modules) _ ...)
      (menu-entry
       (label label)
-      (device (sexp->device device))
+      (device device)
       (device-mount-point mount-point)
       (multiboot-kernel multiboot-kernel)
       (multiboot-arguments multiboot-arguments)
-      (multiboot-modules multiboot-modules)))
-    (('menu-entry ('version 0)
-                  ('label label) ('device device)
-                  ('device-mount-point mount-point)
-                  ('chain-loader chain-loader) _ ...)
-     (menu-entry
-      (label label)
-      (device (sexp->device device))
-      (device-mount-point mount-point)
-      (chain-loader chain-loader)))))
+      (multiboot-modules multiboot-modules)))))
 
 
 ;;;
@@ -253,33 +194,29 @@ instead~%")))
 (define-record-type* <bootloader-configuration>
   bootloader-configuration make-bootloader-configuration
   bootloader-configuration?
-  (bootloader
-   bootloader-configuration-bootloader) ;<bootloader>
-  (targets               %bootloader-configuration-targets
-                         (default #f))     ;list of strings
-  (target                %bootloader-configuration-target ;deprecated
-                         (default #f)
-                         (sanitize warn-target-field-deprecation))
-  (menu-entries          bootloader-configuration-menu-entries
-                         (default '()))   ;list of <menu-entry>
-  (default-entry         bootloader-configuration-default-entry
-                         (default 0))     ;integer
-  (timeout               bootloader-configuration-timeout
-                         (default 5))     ;seconds as integer
-  (keyboard-layout       bootloader-configuration-keyboard-layout
-                         (default #f))    ;<keyboard-layout> | #f
-  (theme                 bootloader-configuration-theme
-                         (default #f))    ;bootloader-specific theme
-  (terminal-outputs      bootloader-configuration-terminal-outputs
-                         (default '(gfxterm)))   ;list of symbols
-  (terminal-inputs       bootloader-configuration-terminal-inputs
-                         (default '()))   ;list of symbols
-  (serial-unit           bootloader-configuration-serial-unit
-                         (default #f))    ;integer | #f
-  (serial-speed          bootloader-configuration-serial-speed
-                         (default #f))    ;integer | #f
-  (device-tree-support?  bootloader-configuration-device-tree-support?
-                         (default #t)))   ;boolean
+  (bootloader         bootloader-configuration-bootloader) ;<bootloader>
+  (targets            %bootloader-configuration-targets    ;list of strings
+                      (default #f))
+  (target             %bootloader-configuration-target ;deprecated
+                      (default #f) (sanitize warn-target-field-deprecation))
+  (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
+                      (default '()))
+  (default-entry      bootloader-configuration-default-entry ;integer
+                      (default 0))
+  (timeout            bootloader-configuration-timeout ;seconds as integer
+                      (default 5))
+  (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
+                      (default #f))
+  (theme              bootloader-configuration-theme ;bootloader-specific theme
+                      (default #f))
+  (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
+                      (default '(gfxterm)))
+  (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
+                      (default '()))
+  (serial-unit        bootloader-configuration-serial-unit ;integer | #f
+                      (default #f))
+  (serial-speed       bootloader-configuration-serial-speed ;integer | #f
+                      (default #f)))
 
 (define-deprecated (bootloader-configuration-target config)
   bootloader-configuration-targets

gnu/bootloader/extlinux.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,9 +38,6 @@ corresponding to old generations of the system."
   (define all-entries
     (append entries (bootloader-configuration-menu-entries config)))
 
-  (define with-fdtdir?
-    (bootloader-configuration-device-tree-support? config))
-
   (define (menu-entry->gexp entry)
     (let ((label (menu-entry-label entry))
           (kernel (menu-entry-linux entry))
@@ -50,16 +46,12 @@ corresponding to old generations of the system."
       #~(format port "LABEL ~a
   MENU LABEL ~a
   KERNEL ~a
-  ~a
+  FDTDIR ~a/lib/dtbs
   INITRD ~a
   APPEND ~a
 ~%"
                 #$label #$label
-                #$kernel
-                (if #$with-fdtdir?
-                    (string-append "FDTDIR " (dirname #$kernel) "/lib/dtbs")
-                    "")
-                #$initrd
+                #$kernel (dirname #$kernel) #$initrd
                 (string-join (list #$@kernel-arguments)))))
 
   (define builder

gnu/bootloader/grub.scm

@@ -7,8 +7,6 @@
 ;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
-;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,13 +50,10 @@
             grub-theme-color-highlight
             grub-theme-gfxmode
 
-            install-grub-efi-removable
             install-grub-efi-netboot
 
             grub-bootloader
             grub-efi-bootloader
-            grub-efi-removable-bootloader
-            grub-efi32-bootloader
             grub-efi-netboot-bootloader
             grub-mkrescue-bootloader
             grub-minimal-bootloader
@@ -374,57 +369,44 @@ when booting a root file system on a Btrfs subvolume."
     (let ((label (menu-entry-label entry))
           (linux (menu-entry-linux entry))
           (device (menu-entry-device entry))
-          (device-mount-point (menu-entry-device-mount-point entry))
-          (multiboot-kernel (menu-entry-multiboot-kernel entry))
-          (chain-loader (menu-entry-chain-loader entry)))
-      (cond
-       (linux
-        (let ((arguments (menu-entry-linux-arguments entry))
-              (linux (normalize-file linux
-                                     device-mount-point
-                                     store-directory-prefix))
-              (initrd (normalize-file (menu-entry-initrd entry)
-                                      device-mount-point
-                                      store-directory-prefix)))
-          ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-          ;; Use the right file names for LINUX and INITRD in case
-          ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
-          ;; separate partition.
+          (device-mount-point (menu-entry-device-mount-point entry)))
+      (if linux
+          (let ((arguments (menu-entry-linux-arguments entry))
+                (linux (normalize-file linux
+                                       device-mount-point
+                                       store-directory-prefix))
+                (initrd (normalize-file (menu-entry-initrd entry)
+                                        device-mount-point
+                                        store-directory-prefix)))
+         ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+         ;; Use the right file names for LINUX and INITRD in case
+         ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+         ;; separate partition.
 
-          ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
-          ;; initrd paths, to allow booting from a Btrfs subvolume.
-          #~(format port "menuentry ~s {
+         ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
+         ;; initrd paths, to allow booting from a Btrfs subvolume.
+         #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
-                    #$label
-                    #$(grub-root-search device linux)
-                    #$linux (string-join (list #$@arguments))
-                    #$initrd)))
-       (multiboot-kernel
-        (let ((kernel (menu-entry-multiboot-kernel entry))
-              (arguments (menu-entry-multiboot-arguments entry))
-              (modules (menu-entry-multiboot-modules entry))
-              (root-index 1))            ; XXX EFI will need root-index 2
-          #~(format port "
+                   #$label
+                   #$(grub-root-search device linux)
+                   #$linux (string-join (list #$@arguments))
+                   #$initrd))
+          (let ((kernel (menu-entry-multiboot-kernel entry))
+                (arguments (menu-entry-multiboot-arguments entry))
+                (modules (menu-entry-multiboot-modules entry))
+                (root-index 1))            ; XXX EFI will need root-index 2
+        #~(format port "
 menuentry ~s {
   multiboot ~a root=device:hd0s~a~a~a
-}~%"
-                    #$label
-                    #$kernel
-                    #$root-index (string-join (list #$@arguments) " " 'prefix)
-                    (string-join (map string-join '#$modules)
-                                 "\n  module " 'prefix))))
-       (chain-loader
-        #~(format port "
-menuentry ~s {
-  ~a
-  chainloader ~a
 }~%"
                   #$label
-                  #$(grub-root-search device chain-loader)
-                  #$chain-loader)))))
+                  #$kernel
+                  #$root-index (string-join (list #$@arguments) " " 'prefix)
+                  (string-join (map string-join '#$modules)
+                               "\n  module " 'prefix))))))
 
   (define (crypto-devices)
     (define (crypto-device->cryptomount dev)
@@ -626,54 +608,6 @@ fi~%"))))
                         "--bootloader-id=Guix"
                         "--efi-directory" target-esp)))))
 
-(define install-grub-efi-removable
-  #~(lambda (bootloader efi-dir mount-point)
-      ;; NOTE: mount-point is /mnt in guix system init /etc/config.scm /mnt/point
-      ;; NOTE: efi-dir comes from target list of booloader configuration
-      ;; There is nothing useful to do when called in the context of a disk
-      ;; image generation.
-      (when efi-dir
-        ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
-        ;; system whose root is mounted at MOUNT-POINT.
-        (let ((grub-install (string-append bootloader "/sbin/grub-install"))
-              (install-dir (string-append mount-point "/boot"))
-              ;; When installing Guix, it's common to mount EFI-DIR below
-              ;; MOUNT-POINT rather than /boot/efi on the live image.
-              (target-esp (if (file-exists? (string-append mount-point efi-dir))
-                              (string-append mount-point efi-dir)
-                              efi-dir)))
-          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
-          ;; root partition.
-          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-          (invoke/quiet grub-install "--boot-directory" install-dir
-                        "--removable"
-                        ;; "--no-nvram"
-                        "--bootloader-id=Guix"
-                        "--efi-directory" target-esp)))))
-
-(define install-grub-efi32
-  #~(lambda (bootloader efi-dir mount-point)
-      ;; There is nothing useful to do when called in the context of a disk
-      ;; image generation.
-      (when efi-dir
-        ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
-        ;; system whose root is mounted at MOUNT-POINT.
-        (let ((grub-install (string-append bootloader "/sbin/grub-install"))
-              (install-dir (string-append mount-point "/boot"))
-              ;; When installing Guix, it's common to mount EFI-DIR below
-              ;; MOUNT-POINT rather than /boot/efi on the live image.
-              (target-esp (if (file-exists? (string-append mount-point efi-dir))
-                              (string-append mount-point efi-dir)
-                              efi-dir)))
-          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
-          ;; root partition.
-          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-          (invoke/quiet grub-install "--boot-directory" install-dir
-                        "--bootloader-id=Guix"
-			(cond ((target-x86?) "--target=i386-efi")
-                              ((target-arm?) "--target=arm-efi"))
-                        "--efi-directory" target-esp)))))
-
 (define (install-grub-efi-netboot subdir)
   "Define a grub-efi-netboot bootloader installer for installation in SUBDIR,
 which is usually efi/Guix or efi/boot."
@@ -800,19 +734,6 @@ considered for security aspects."
    (name 'grub-efi)
    (package grub-efi)))
 
-(define grub-efi-removable-bootloader
-  (bootloader
-   (inherit grub-efi-bootloader)
-   (name 'grub-efi-removable-bootloader)
-   (installer install-grub-efi-removable)))
-
-(define grub-efi32-bootloader
-  (bootloader
-   (inherit grub-efi-bootloader)
-   (installer install-grub-efi32)
-   (name 'grub-efi32)
-   (package grub-efi32)))
-
 (define grub-efi-netboot-bootloader
   (bootloader
    (inherit grub-efi-bootloader)

gnu/build/bootloader.scm

@@ -1,8 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
-;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,12 +54,8 @@
 ;;; EFI bootloader.
 ;;;
 
-(define* (install-efi grub grub-config esp #:key targets)
-  "Write a self-contained GRUB EFI loader to the mounted ESP using
-GRUB-CONFIG.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
+(define (install-efi grub grub-config esp)
+  "Write a self-contained GRUB EFI loader to the mounted ESP using GRUB-CONFIG."
   (let* ((system %host-type)
          ;; Hard code the output location to a well-known path recognized by
          ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
@@ -69,15 +63,14 @@ the output filename.  Otherwise, use defaults for the host platform."
          (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
          (efi-directory (string-append esp "/EFI/BOOT"))
          ;; Map grub target names to boot file names.
-         (efi-targets (or targets
-                          (cond ((string-prefix? "x86_64" system)
-                                 '("x86_64-efi" . "BOOTX64.EFI"))
-                                ((string-prefix? "i686" system)
-                                 '("i386-efi" . "BOOTIA32.EFI"))
-                                ((string-prefix? "armhf" system)
-                                 '("arm-efi" . "BOOTARM.EFI"))
-                                ((string-prefix? "aarch64" system)
-                                 '("arm64-efi" . "BOOTAA64.EFI"))))))
+         (efi-targets (cond ((string-prefix? "x86_64" system)
+                             '("x86_64-efi" . "BOOTX64.EFI"))
+                            ((string-prefix? "i686" system)
+                             '("i386-efi" . "BOOTIA32.EFI"))
+                            ((string-prefix? "armhf" system)
+                             '("arm-efi" . "BOOTARM.EFI"))
+                            ((string-prefix? "aarch64" system)
+                             '("arm64-efi" . "BOOTAA64.EFI")))))
     ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
     (setenv "TMPDIR" esp)
 
@@ -88,12 +81,9 @@ the output filename.  Otherwise, use defaults for the host platform."
             ;; Graft the configuration file onto the image.
             (string-append "boot/grub/grub.cfg=" grub-config))))
 
-(define* (install-efi-loader grub-efi esp #:key targets)
+(define (install-efi-loader grub-efi esp)
   "Install in ESP directory the given GRUB-EFI bootloader.  Configure it to
-load the Grub bootloader located in the 'Guix_image' root partition.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
+load the Grub bootloader located in the 'Guix_image' root partition."
   (let ((grub-config "grub.cfg"))
     (call-with-output-file grub-config
       (lambda (port)
@@ -107,6 +97,5 @@ the output filename.  Otherwise, use defaults for the host platform."
                insmod part_gpt~@
                search --set=root --label Guix_image~@
                configfile /boot/grub/grub.cfg~%")))
-    (install-efi grub-efi grub-config esp #:targets targets)
+    (install-efi grub-efi grub-config esp)
     (delete-file grub-config)))
-

gnu/build/chromium-extension.scm

@@ -1,6 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2021 Marius Bakke <marius@gnu.org>
-;;; Copyright © 2022 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,9 +19,10 @@
 (define-module (gnu build chromium-extension)
   #:use-module (guix gexp)
   #:use-module (guix packages)
+  #:use-module (gnu packages chromium)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages tls)
-  #:use-module (gnu packages node-xyz)
+  #:use-module (gnu packages xorg)
   #:use-module (guix build-system trivial)
   #:export (make-chromium-extension))
 
@@ -69,14 +69,24 @@ in PACKAGE-OUTPUT of PACKAGE.  The extension will be signed with SIGNING-KEY."
    (string-append name "-" version ".crx")
    (with-imported-modules '((guix build utils))
      #~(begin
+         ;; This is not great.  We pull Xorg and Chromium just to Zip and
+         ;; sign an extension.  This should be implemented with something
+         ;; lighter.  (TODO: where is the CRXv3 documentation..?)
          (use-modules (guix build utils))
-         (let ((crx3 #+(file-append node-crx3 "/bin/crx3"))
+         (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
+               (xvfb #$(file-append xorg-server "/bin/Xvfb"))
                (packdir (string-append (getcwd) "/extension")))
            (mkdir packdir)
            (copy-recursively (ungexp package package-output) packdir
                              ;; Ensure consistent file modification times.
                              #:keep-mtime? #t)
-           (invoke crx3 "--keyPath" #$signing-key packdir)
+           (system (string-append xvfb " :1 &"))
+           (setenv "DISPLAY" ":1")
+           (sleep 2)                    ;give Xorg some time to initialize...
+           (invoke chromium
+                   "--user-data-dir=chromium-profile"
+                   (string-append "--pack-extension=" packdir)
+                   (string-append "--pack-extension-key=" #$signing-key))
            (copy-file (string-append packdir ".crx") #$output))))
    #:local-build? #t))
 

gnu/build/dbus-service.scm

@@ -1,213 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021, 2022 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 module contains procedures to interact with D-Bus via the 'dbus-send'
-;;; command line utility.  Before using any public procedure
-;;;
-;;; Code:
-
-(define-module (gnu build dbus-service)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-19)
-  #:use-module (srfi srfi-26)
-  #:autoload (d-bus protocol connections) (d-bus-conn?
-                                           d-bus-conn-flush
-                                           d-bus-connect
-                                           d-bus-disconnect
-                                           d-bus-session-bus-address
-                                           d-bus-system-bus-address)
-  #:autoload (d-bus protocol messages) (MESSAGE_TYPE_METHOD_CALL
-                                        d-bus-headers-ref
-                                        d-bus-message-body
-                                        d-bus-message-headers
-                                        d-bus-read-message
-                                        d-bus-write-message
-                                        header-PATH
-                                        header-DESTINATION
-                                        header-INTERFACE
-                                        header-MEMBER
-                                        header-SIGNATURE
-                                        make-d-bus-message)
-  #:export (%dbus-query-timeout
-
-            initialize-dbus-connection!
-            %current-dbus-connection
-            send-dbus
-            call-dbus-method
-
-            dbus-available-services
-            dbus-service-available?
-
-            with-retries))
-
-(define %dbus-query-timeout 2)          ;in seconds
-
-;;; Use Fibers' sleep to enable cooperative scheduling in Shepherd >= 0.9.0,
-;;; which is required at least for the Jami service.
-(define sleep*
-  (lambda ()                            ;delay execution
-    (if (resolve-module '(fibers) #f)
-        (module-ref (resolve-interface '(fibers)) 'sleep)
-        (begin
-          (format #f "fibers not available -- blocking 'sleep' in use")
-          sleep))))
-
-;;;
-;;; Utilities.
-;;;
-
-(define-syntax-rule (with-retries n delay body ...)
-  "Retry the code in BODY up to N times until it doesn't raise an exception nor
-return #f, else raise an error.  A delay of DELAY seconds is inserted before
-each retry."
-  (let loop ((attempts 0))
-    (catch #t
-      (lambda ()
-        (let ((result (begin body ...)))
-          (if (not result)
-              (error "failed attempt" attempts)
-              result)))
-      (lambda args
-        (if (< attempts n)
-            (begin
-              ((sleep*) delay)            ;else wait and retry
-              (loop (+ 1 attempts)))
-            (error "maximum number of retry attempts reached"
-                   body ... args))))))
-
-
-;;;
-;;; Low level wrappers above AC/D-Bus.
-;;;
-
-;; The active D-Bus connection (a parameter) used by the other procedures.
-(define %current-dbus-connection (make-parameter #f))
-
-(define* (initialize-dbus-connection!
-          #:key (address (or (d-bus-session-bus-address)
-                             (d-bus-system-bus-address))))
-  "Initialize the D-Bus connection.  ADDRESS should be the address of the D-Bus
-session, e.g. \"unix:path=/var/run/dbus/system_bus_socket\", the default value
-if ADDRESS is not provided and DBUS_SESSION_BUS_ADDRESS is not set.  Return
-the initialized D-Bus connection."
-  ;; Clear current correction if already active.
-  (when (d-bus-conn? (%current-dbus-connection))
-    (d-bus-disconnect (%current-dbus-connection)))
-
-  (let ((connection (d-bus-connect address)))
-    (%current-dbus-connection connection) ;update connection parameter
-    (call-dbus-method "Hello"))           ;initial handshake
-
-  (%current-dbus-connection))
-
-(define* (send-dbus message #:key
-                    (connection (%current-dbus-connection))
-                    timeout)
-  "Send a D-Bus MESSAGE to CONNECTION and return the body of its reply.  Up to
-READ-RETRIES replies are read until a matching reply is found, else an error
-is raised.  MESSAGE is to be constructed with `make-d-bus-message'.  When the
-body contains a single element, it is returned directly, else the body
-elements are returned as a list.  TIMEOUT is a timeout value in seconds."
-  (let ((serial     (d-bus-write-message connection message))
-        (start-time (current-time time-monotonic))
-        (timeout* (or timeout %dbus-query-timeout)))
-    (d-bus-conn-flush connection)
-    (let retry ()
-      (when (> (time-second (time-difference (current-time time-monotonic)
-                                             start-time))
-               timeout*)
-        (error 'dbus "fail to get reply in timeout" timeout*))
-      (let* ((reply (d-bus-read-message connection))
-             (reply-headers (d-bus-message-headers reply))
-             (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL))
-             (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME))
-             (body (d-bus-message-body reply)))
-        ;; Validate the reply matches the message.
-        (when error-name
-          (error 'dbus "method failed with error" error-name body))
-        ;; Some replies do not include a serial header, such as the for the
-        ;; org.freedesktop.DBus NameAcquired one.
-        (if (and reply-serial (= serial reply-serial))
-            (match body
-              ((x x* ..1)               ;contains 2 ore more elements
-               body)
-              ((x)
-               x)                       ;single element; return it directly
-              (#f #f))
-            (retry))))))
-
-(define (argument->signature-type argument)
-  "Infer the D-Bus signature type from ARGUMENT."
-  ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match).
-  (match argument
-    ((? boolean?) "b")
-    ((? string?) "s")
-    (#((? string?) (? string?) ...) "as")
-    (#(((? string?) . (? string?))
-       ((? string?) . (? string?)) ...) "a{ss}")
-    (_ (error 'dbus "no rule to infer type from argument" argument))))
-
-(define* (call-dbus-method method
-                           #:key
-                           (path "/org/freedesktop/DBus")
-                           (destination "org.freedesktop.DBus")
-                           (interface "org.freedesktop.DBus")
-                           (connection (%current-dbus-connection))
-                           arguments
-                           timeout)
-  "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE.
-The currently active D-Bus CONNECTION is used unless explicitly provided.
-Method arguments may be provided via ARGUMENTS sent as the message body.
-TIMEOUT limit the maximum time to allow for the reply.  Return the body of the
-reply."
-  (let ((message (make-d-bus-message
-                  MESSAGE_TYPE_METHOD_CALL 0 #f '()
-                  `#(,(header-PATH        path)
-                     ,(header-DESTINATION destination)
-                     ,(header-INTERFACE   interface)
-                     ,(header-MEMBER      method)
-                     ,@(if arguments
-                           (list (header-SIGNATURE
-                                  (string-join
-                                   (map argument->signature-type arguments)
-                                   "")))
-                           '()))
-                  arguments)))
-    (send-dbus message #:connection connection #:timeout timeout)))
-
-
-;;;
-;;; Higher-level, D-Bus procedures.
-;;;
-
-(define (dbus-available-services)
-  "Return the list of available (acquired) D-Bus services."
-  (let ((names (vector->list (call-dbus-method "ListNames"))))
-    ;; Remove entries such as ":1.7".
-    (remove (cut string-prefix? ":" <>) names)))
-
-(define (dbus-service-available? service)
-  "Predicate to check for the D-Bus SERVICE availability."
-  (member service (dbus-available-services)))
-
-;; Local Variables:
-;; eval: (put 'with-retries 'scheme-indent-function 2)
-;; End:

gnu/build/file-systems.scm

@@ -1,12 +1,11 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
 ;;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -53,11 +52,8 @@
             read-partition-uuid
             read-luks-partition-uuid
 
-            cleanly-unmounted-ext2?
-
             bind-mount
 
-            system*/tty
             mount-flags->bit-mask
             check-file-system
             mount-file-system
@@ -71,45 +67,6 @@
 ;;;
 ;;; Code:
 
-(define (system*/console program . args)
-  "Run PROGRAM with ARGS in a tty on top of /dev/console.  The return value is
-as for 'system*'."
-  (match (primitive-fork)
-    (0
-     (dynamic-wind
-       (const #t)
-       (lambda ()
-         (login-tty (open-fdes "/dev/console" O_RDWR))
-         (apply execlp program program args))
-       (lambda ()
-         (primitive-_exit 127))))
-    (pid
-     (cdr (waitpid pid)))))
-
-(define (system*/tty program . args)
-  "Run PROGRAM with ARGS, creating a tty if its standard input isn't one.
-The return value is as for 'system*'.
-
-This is necessary for commands such as 'cryptsetup open' or 'fsck' that may
-need to interact with the user but might be invoked from shepherd, where
-standard input is /dev/null."
-  (apply (if (isatty? (current-input-port))
-             system*
-             system*/console)
-         program args))
-
-(define (call-with-input-file file proc)
-  "Like 'call-with-input-file', but pass O_CLOEXEC."
-  (let ((port #f))
-    (dynamic-wind
-      (lambda ()
-        (set! port (open file (logior O_RDONLY O_CLOEXEC))))
-      (lambda ()
-        (proc port))
-      (lambda ()
-        (close-port port)
-        (set! port #f)))))
-
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
@@ -208,23 +165,6 @@ NUL terminator, return the size of the bytevector."
 if DEVICE does not contain an ext2 file system."
   (read-superblock device 1024 264 ext2-superblock?))
 
-(define (ext2-superblock-cleanly-unmounted? sblock)
-  "Return true if SBLOCK denotes a file system that was cleanly unmounted,
-false otherwise."
-  (define EXT2_VALID_FS 1)                        ;cleanly unmounted
-  (define EXT2_ERROR_FS 2)                        ;errors detected
-
-  (define EXT3_FEATURE_INCOMPAT_RECOVER #x0004)   ;journal needs recovery
-
-  (let ((state (bytevector-u16-ref sblock 58 %ext2-endianness)))
-    (cond ((= state EXT2_VALID_FS)
-           (let ((incompatible-features
-                  (bytevector-u32-ref sblock 96 %ext2-endianness)))
-             (zero? (logand incompatible-features
-                            EXT3_FEATURE_INCOMPAT_RECOVER))))
-          ((= state EXT2_ERROR_FS) #f)
-          (else (error "invalid ext2 superblock state" state)))))
-
 (define (ext2-superblock-uuid sblock)
   "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
   (sub-bytevector sblock 104 16))
@@ -240,23 +180,18 @@ true, check the file system even if it's marked as clean.  If REPAIR is false,
 do not write to the file system to fix errors.  If it's #t, fix all
 errors.  Otherwise, fix only those considered safe to repair automatically."
   (match (status:exit-val
-          (apply system*/tty "e2fsck" "-v" "-C" "0"
-                 `(,@(if force? '("-f") '())
-                   ,@(match repair
-                       (#f '("-n"))
-                       (#t '("-y"))
-                       (_  '("-p")))
-                   ,device)))
+          (apply system* `("e2fsck" "-v" "-C" "0"
+                           ,@(if force? '("-f") '())
+                           ,@(match repair
+                               (#f '("-n"))
+                               (#t '("-y"))
+                               (_  '("-p")))
+                           ,device)))
     (0 'pass)
     (1 'errors-corrected)
     (2 'reboot-required)
     (_ 'fatal-error)))
 
-(define (cleanly-unmounted-ext2? device)          ;convenience procedure
-  "Return true if DEVICE is an ext2 file system and if it was cleanly
-unmounted."
-  (ext2-superblock-cleanly-unmounted? (read-ext2-superblock device)))
-
 
 ;;;
 ;;; Linux swap.
@@ -377,14 +312,14 @@ errors. Otherwise, fix only those considered safe to repair automatically."
         (status
          ;; A number, or #f on abnormal termination (e.g., assertion failure).
          (status:exit-val
-          (apply system*/tty "bcachefs" "fsck" "-v"
-                 `(,@(if force? '("-f") '())
-                   ,@(match repair
-                       (#f '("-n"))
-                       (#t '("-y"))
-                       (_  '("-p")))
-                   ;; Make each multi-device member a separate argument.
-                   ,@(string-split device #\:))))))
+          (apply system* `("bcachefs" "fsck" "-v"
+                           ,@(if force? '("-f") '())
+                           ,@(match repair
+                               (#f '("-n"))
+                               (#t '("-y"))
+                               (_  '("-p")))
+                           ;; Make each multi-device member a separate argument.
+                           ,@(string-split device #\:))))))
     (match (and=> status (cut logand <> (lognot ignored-bits)))
       (0 'pass)
       (1 'errors-corrected)
@@ -429,17 +364,17 @@ false, do not write to DEVICE.  If it's #t, fix any errors found.  Otherwise,
 fix only those considered safe to repair automatically."
   (if force?
       (match (status:exit-val
-              (apply system*/tty "btrfs" "check" "--progress"
-                     ;; Btrfs's ‘--force’ is not relevant to us here.
-                     `(,@(match repair
-                           ;; Upstream considers ALL repairs dangerous
-                           ;; and will warn the user at run time.
-                           (#t '("--repair"))
-                           (_  '("--readonly"     ; a no-op for clarity
-                                 ;; A 466G file system with 180G used is
-                                 ;; enough to kill btrfs with 6G of RAM.
-                                 "--mode" "lowmem")))
-                       ,device)))
+              (apply system* `("btrfs" "check" "--progress"
+                               ;; Btrfs's ‘--force’ is not relevant to us here.
+                               ,@(match repair
+                                   ;; Upstream considers ALL repairs dangerous
+                                   ;; and will warn the user at run time.
+                                   (#t '("--repair"))
+                                   (_  '("--readonly" ; a no-op for clarity
+                                         ;; A 466G file system with 180G used is
+                                         ;; enough to kill btrfs with 6G of RAM.
+                                         "--mode" "lowmem")))
+                               ,device)))
         (0 'pass)
         (_ 'fatal-error))
       'pass))
@@ -477,11 +412,11 @@ ignored: a full file system scan is always performed.  If REPAIR is false, do
 not write to the file system to fix errors. Otherwise, automatically fix them
 using the least destructive approach."
   (match (status:exit-val
-          (system*/tty "fsck.vfat" "-v"
-                       (match repair
-                         (#f "-n")
-                         (_  "-a"))               ;no 'safe/#t distinction
-                       device))
+          (apply system* `("fsck.vfat" "-v"
+                           ,@(match repair
+                               (#f '("-n"))
+                               (_  '("-a"))) ; no 'safe/#t distinction
+                           ,device)))
     (0 'pass)
     (1 'errors-corrected)
     (_ 'fatal-error)))
@@ -610,7 +545,7 @@ do not write to the file system to fix errors, and replay the transaction log
 only if FORCE?  is true. Otherwise, replay the transaction log before checking
 and automatically fix found errors."
   (match (status:exit-val
-          (apply system*/tty
+          (apply system*
                  `("jfs_fsck" "-v"
                    ;; The ‘LEVEL’ logic is convoluted.  To quote fsck/xchkdsk.c
                    ;; (‘-p’, ‘-a’, and ‘-r’ are aliases in every way):
@@ -686,10 +621,10 @@ REPAIR are true, automatically fix found errors."
             "warning: forced check of F2FS ~a implies repairing any errors~%"
             device))
   (match (status:exit-val
-          (apply system*/tty "fsck.f2fs"
-                 `(,@(if force? '("-f") '())
-                   ,@(if repair '("-p") '("--dry-run"))
-                   ,device)))
+          (apply system* `("fsck.f2fs"
+                           ,@(if force? '("-f") '())
+                           ,@(if repair '("-p") '("--dry-run"))
+                           ,device)))
     ;; 0 and -1 are the only two possibilities according to the man page.
     (0 'pass)
     (_ 'fatal-error)))
@@ -774,9 +709,9 @@ ignored: a full check is always performed.  Repair is not possible: if REPAIR is
 true and the volume has been repaired by an external tool, clear the volume
 dirty flag to indicate that it's now safe to mount."
   (match (status:exit-val
-          (system*/tty "ntfsfix"
-                       (if repair "--clear-dirty" "--no-action")
-                       device))
+          (apply system* `("ntfsfix"
+                           ,@(if repair '("--clear-dirty") '("--no-action"))
+                           ,device)))
     (0 'pass)
     (_ 'fatal-error)))
 
@@ -819,11 +754,11 @@ write to DEVICE.  If it's #t, replay the log, check, and fix any errors found.
 Otherwise, only replay the log, and check without attempting further repairs."
   (define (xfs_repair)
     (status:exit-val
-     (system*/tty "xfs_repair" "-Pv"
-                  (match repair
-                    (#t "-e")
-                    (_  "-n"))                    ;will miss some errors
-                  device)))
+     (apply system* `("xfs_repair" "-Pv"
+                      ,@(match repair
+                          (#t '("-e"))
+                          (_  '("-n"))) ; will miss some errors
+                      ,device))))
   (if force?
       ;; xfs_repair fails with exit status 2 if the log is dirty, which is
       ;; likely in situations where you're running xfs_repair.  Only the kernel
@@ -899,10 +834,6 @@ caught and lead to a warning and #f as the result."
                  (format (current-error-port)
                          "warning: failed to read from device '~a'~%" device)
                  #f)
-                ((= EMEDIUMTYPE errno)            ;inaccessible, like DRBD secondaries
-                 (format (current-error-port)
-                         "warning: failed to open device '~a'~%" device)
-                 #f)
                 (else
                  (apply throw args))))))))
 
@@ -1127,7 +1058,7 @@ corresponds to the symbols listed in FLAGS."
       (('read-only rest ...)
        (logior MS_RDONLY (loop rest)))
       (('bind-mount rest ...)
-       (logior MS_REC (logior MS_BIND (loop rest))))
+       (logior MS_BIND (loop rest)))
       (('no-suid rest ...)
        (logior MS_NOSUID (loop rest)))
       (('no-dev rest ...)
@@ -1136,14 +1067,10 @@ corresponds to the symbols listed in FLAGS."
        (logior MS_NOEXEC (loop rest)))
       (('no-atime rest ...)
        (logior MS_NOATIME (loop rest)))
-      (('no-diratime rest ...)
-       (logior MS_NODIRATIME (loop rest)))
       (('strict-atime rest ...)
        (logior MS_STRICTATIME (loop rest)))
       (('lazy-time rest ...)
        (logior MS_LAZYTIME (loop rest)))
-      (('shared rest ...)
-       (loop rest))
       (()
        0))))
 
@@ -1201,16 +1128,12 @@ corresponds to the symbols listed in FLAGS."
                  (not (file-is-directory? source)))
             (unless (file-exists? target)
               (mkdir-p (dirname target))
-              (close-fdes
-               (open-fdes target (logior O_WRONLY O_CREAT O_CLOEXEC))))
+              (call-with-output-file target (const #t)))
             (mkdir-p target))
 
         (cond
          ((string-prefix? "nfs" type)
           (mount-nfs source target type flags options))
-         ((memq 'shared (file-system-flags fs))
-          (mount source target type flags options)
-          (mount "none" target #f MS_SHARED))
          (else
           (mount source target type flags options)))
 

gnu/build/image.scm

@@ -5,8 +5,6 @@
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,7 +26,6 @@
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
   #:use-module (guix store database)
-  #:use-module (guix utils)
   #:use-module (gnu build bootloader)
   #:use-module (gnu build install)
   #:use-module (gnu build linux-boot)
@@ -43,7 +40,6 @@
             convert-disk-image
             genimage
             initialize-efi-partition
-            initialize-efi32-partition
             initialize-root-partition
 
             make-iso9660-image))
@@ -52,13 +48,12 @@
   "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
 <partition> record."
   (match sexp
-    ((size file-system file-system-options label uuid flags)
+    ((size file-system file-system-options label uuid)
      (partition (size size)
                 (file-system file-system)
                 (file-system-options file-system-options)
                 (label label)
-                (uuid uuid)
-                (flags flags)))))
+                (uuid uuid)))))
 
 (define (size-in-kib size)
   "Convert SIZE expressed in bytes, to kilobytes and return it as a string."
@@ -86,10 +81,7 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
         (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
     (apply invoke
            `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
-             "-L" ,label
-             ,@(if uuid
-                   `("-U" ,(uuid->string uuid))
-                   '())
+             "-L" ,label "-U" ,(uuid->string uuid)
              "-E" ,(format #f "root_owner=~a:~a,~a"
                            owner-uid owner-gid journal-options)
              ,@fs-options
@@ -100,18 +92,16 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
                            (estimate-partition-size root)
                            size)))))))
 
-(define* (make-vfat-image partition target root fs-bits)
+(define* (make-vfat-image partition target root)
   "Handle the creation of VFAT partition images.  See 'make-partition-image'."
   (let ((size (partition-size partition))
-        (label (partition-label partition))
-        (flags (partition-flags partition)))
-    (apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
-                          "-F" (number->string fs-bits)
-                          (size-in-kib
-                           (if (eq? size 'guess)
-                               (estimate-partition-size root)
-                               size))
-                    (if (member 'esp flags) (list "-S" "1024") '()))
+        (label (partition-label partition)))
+    (invoke "fakeroot" "mkdosfs" "-n" label "-C" target
+            "-F" "16" "-S" "1024"
+            (size-in-kib
+             (if (eq? size 'guess)
+                 (estimate-partition-size root)
+                 size)))
     (for-each (lambda (file)
                 (unless (member file '("." ".."))
                   (invoke "mcopy" "-bsp" "-i" target
@@ -127,10 +117,8 @@ ROOT directory to populate the image."
     (cond
      ((string-prefix? "ext" type)
       (make-ext-image partition target root))
-     ((or (string=? type "vfat") (string=? type "fat16"))
-      (make-vfat-image partition target root 16))
-     ((string=? type "fat32")
-      (make-vfat-image partition target root 32))
+     ((string=? type "vfat")
+      (make-vfat-image partition target root))
      (else
       (raise (condition
               (&message
@@ -174,17 +162,6 @@ produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
   "Install in ROOT directory, an EFI loader using GRUB-EFI."
   (install-efi-loader grub-efi root))
 
-(define* (initialize-efi32-partition root
-                                     #:key
-                                     grub-efi32
-                                     #:allow-other-keys)
-  "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
-  (install-efi-loader grub-efi32 root
-                      #:targets (cond ((target-x86?)
-                                       '("i386-efi" . "BOOTIA32.EFI"))
-                                      ((target-arm?)
-                                       '("arm-efi" . "BOOTARM.EFI")))))
-
 (define* (initialize-root-partition root
                                     #:key
                                     bootcfg

gnu/build/install.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,24 +56,19 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
 (define* (evaluate-populate-directive directive target
                                       #:key
                                       (default-gid 0)
-                                      (default-uid 0)
-                                      (error-on-dangling-symlink? #t))
+                                      (default-uid 0))
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
 directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
 the context of the caller.  If the directive matches those defaults then,
-'chown' won't be run.  When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
-error when a dangling symlink would be created."
-  (define target* (if (string-suffix? "/" target)
-                      target
-                      (string-append target "/")))
+'chown' won't be run."
   (let loop ((directive directive))
     (catch 'system-error
       (lambda ()
         (match directive
           (('directory name)
-           (mkdir-p (string-append target* name)))
+           (mkdir-p (string-append target name)))
           (('directory name uid gid)
-           (let ((dir (string-append target* name)))
+           (let ((dir (string-append target name)))
              (mkdir-p dir)
              ;; If called from a context without "root" permissions, "chown"
              ;; to root will fail.  In that case, do not try to run "chown"
@@ -84,38 +78,27 @@ error when a dangling symlink would be created."
                  (chown dir uid gid))))
           (('directory name uid gid mode)
            (loop `(directory ,name ,uid ,gid))
-           (chmod (string-append target* name) mode))
+           (chmod (string-append target name) mode))
           (('file name)
-           (call-with-output-file (string-append target* name)
+           (call-with-output-file (string-append target name)
              (const #t)))
           (('file name (? string? content))
-           (call-with-output-file (string-append target* name)
+           (call-with-output-file (string-append target name)
              (lambda (port)
                (display content port))))
           ((new '-> old)
-           (let ((new* (string-append target* new)))
-             (let try ()
-               (catch 'system-error
-                 (lambda ()
-                   (when error-on-dangling-symlink?
-                     ;; When the symbolic link points to a relative path,
-                     ;; checking if its target exists must be done relatively
-                     ;; to the link location.
-                     (unless (if (string-prefix? "/" old)
-                                 (file-exists? old)
-                                 (with-directory-excursion (dirname new*)
-                                   (file-exists? old)))
-                       (error (format #f "symlink `~a' points to nonexistent \
-file `~a'" new* old))))
-                   (symlink old new*))
-                 (lambda args
-                   ;; When doing 'guix system init' on the current '/', some
-                   ;; symlinks may already exists.  Override them.
-                   (if (= EEXIST (system-error-errno args))
-                       (begin
-                         (delete-file new*)
-                         (try))
-                       (apply throw args)))))))))
+           (let try ()
+             (catch 'system-error
+               (lambda ()
+                 (symlink old (string-append target new)))
+               (lambda args
+                 ;; When doing 'guix system init' on the current '/', some
+                 ;; symlinks may already exists.  Override them.
+                 (if (= EEXIST (system-error-errno args))
+                     (begin
+                       (delete-file (string-append target new))
+                       (try))
+                     (apply throw args))))))))
       (lambda args
         ;; Usually we can only get here when installing to an existing root,
         ;; as with 'guix system init foo.scm /'.
@@ -159,10 +142,7 @@ STORE."
 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
 EXTRAS is a list of directives appended to the built-in directives to populate
 TARGET."
-  ;; It's expected that some symbolic link targets do not exist yet, so do not
-  ;; error on dangling links.
-  (for-each (cut evaluate-populate-directive <> target
-                 #:error-on-dangling-symlink? #f)
+  (for-each (cut evaluate-populate-directive <> target)
             (append (directives (%store-directory)) extras))
 
   ;; Add system generation 1.
@@ -282,31 +262,12 @@ disk."
     (mount "/.rw-store" (%store-directory) "" MS_MOVE)
     (rmdir "/.rw-store")))
 
-(define (umount* directory)
-  "Unmount DIRECTORY, but retry a few times upon EBUSY."
-  (let loop ((attempts 5))
-    (catch 'system-error
-      (lambda ()
-        (umount directory))
-      (lambda args
-        (if (and (= EBUSY (system-error-errno args))
-                 (> attempts 0))
-            (begin
-              (sleep 1)
-              (loop (- attempts 1)))
-            (apply throw args))))))
-
 (define (unmount-cow-store target backing-directory)
   "Unmount copy-on-write store."
   (let ((tmp-dir "/remove"))
     (mkdir-p tmp-dir)
     (mount (%store-directory) tmp-dir "" MS_MOVE)
-
-    ;; We might get EBUSY at this point, possibly because of lingering
-    ;; processes with open file descriptors.  Use 'umount*' to retry upon
-    ;; EBUSY, leaving a bit of time.  See <https://issues.guix.gnu.org/59884>.
-    (umount* tmp-dir)
-
+    (umount tmp-dir)
     (rmdir tmp-dir)
     (delete-file-recursively
      (string-append target backing-directory))))

gnu/build/jami-service.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,16 +24,16 @@
 ;;; Code:
 
 (define-module (gnu build jami-service)
-  #:use-module (gnu build dbus-service)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 peg)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
+  #:use-module (rnrs io ports)
+  #:autoload (shepherd service) (fork+exec-command)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:export (jami-service-available?
-
-            account-fingerprint?
+  #:export (account-fingerprint?
             account-details->recutil
             get-accounts
             get-usernames
@@ -51,12 +51,43 @@
             set-all-moderators
             set-moderator
             username->all-moderators?
-            username->moderators))
+            username->moderators
+
+            dbus-available-services
+            dbus-service-available?
+
+            %send-dbus-binary
+            %send-dbus-bus
+            %send-dbus-user
+            %send-dbus-group
+            %send-dbus-debug
+            send-dbus
+
+            with-retries))
 
 ;;;
 ;;; Utilities.
 ;;;
 
+(define-syntax-rule (with-retries n delay body ...)
+  "Retry the code in BODY up to N times until it doesn't raise an exception
+nor return #f, else raise an error.  A delay of DELAY seconds is inserted
+before each retry."
+  (let loop ((attempts 0))
+    (catch #t
+      (lambda ()
+        (let ((result (begin body ...)))
+          (if (not result)
+              (error "failed attempt" attempts)
+              result)))
+      (lambda args
+        (if (< attempts n)
+            (begin
+              (sleep delay)             ;else wait and retry
+              (loop (+ 1 attempts)))
+            (error "maximum number of retry attempts reached"
+                   body ... args))))))
+
 (define (alist->list alist)
   "Flatten ALIST into a list."
   (append-map (match-lambda
@@ -73,34 +104,212 @@ hexadecimal characters."
   (and (string? val)
        (regexp-exec account-fingerprint-rx val)))
 
+
+;;;
+;;; D-Bus reply parser.
+;;;
+
+(define (parse-dbus-reply reply)
+  "Return the parse tree of REPLY, a string returned by the 'dbus-send'
+command."
+  ;; Refer to 'man 1 dbus-send' for the grammar reference.  Note that the
+  ;; format of the replies doesn't match the format of the input, which is the
+  ;; one documented, but it gives an idea.  For an even better reference, see
+  ;; the `print_iter' procedure of the 'dbus-print-message.c' file from the
+  ;; 'dbus' package sources.
+  (define-peg-string-patterns
+    "contents <- header (item / container (item / container*)?)
+     item <-- WS type WS value NL
+     container <- array / dict / variant
+     array <-- array-start (item / container)* array-end
+     dict <-- array-start dict-entry* array-end
+     dict-entry <-- dict-entry-start item item dict-entry-end
+     variant <-- variant-start item
+     type <-- 'string' / 'int16' / 'uint16' / 'int32' / 'uint32' / 'int64' /
+              'uint64' / 'double' / 'byte' / 'boolean' / 'objpath'
+     value <-- (!NL .)* NL
+     header < (!NL .)* NL
+     variant-start < WS 'variant'
+     array-start < WS 'array [' NL
+     array-end < WS ']' NL
+     dict-entry-start < WS 'dict entry(' NL
+     dict-entry-end < WS ')' NL
+     DQ < '\"'
+     WS < ' '*
+     NL < '\n'*")
+
+  (peg:tree (match-pattern contents reply)))
+
+(define (strip-quotes text)
+  "Strip the leading and trailing double quotes (\") characters from TEXT."
+  (let* ((text* (if (string-prefix? "\"" text)
+                    (string-drop text 1)
+                    text))
+         (text** (if (string-suffix? "\"" text*)
+                     (string-drop-right text* 1)
+                     text*)))
+    text**))
+
+(define (deserialize-item item)
+  "Return the value described by the ITEM parse tree as a Guile object."
+  ;; Strings are printed wrapped in double quotes (see the print_iter
+  ;; procedure in dbus-print-message.c).
+  (match item
+    (('item ('type "string") ('value value))
+     (strip-quotes value))
+    (('item ('type "boolean") ('value value))
+     (if (string=? "true" value)
+         #t
+         #f))
+    (('item _ ('value value))
+     value)))
+
+(define (serialize-boolean bool)
+  "Return the serialized format expected by dbus-send for BOOL."
+  (format #f "boolean:~:[false~;true~]" bool))
+
+(define (dict->alist dict-parse-tree)
+  "Translate a dict parse tree to an alist."
+  (define (tuples->alist tuples)
+    (map (lambda (x) (apply cons x)) tuples))
+
+  (match dict-parse-tree
+    ('dict
+     '())
+    (('dict ('dict-entry keys values) ...)
+     (let ((keys* (map deserialize-item keys))
+           (values* (map deserialize-item values)))
+       (tuples->alist (zip keys* values*))))))
+
+(define (array->list array-parse-tree)
+  "Translate an array parse tree to a list."
+  (match array-parse-tree
+    ('array
+     '())
+    (('array items ...)
+     (map deserialize-item items))))
+
+
+;;;
+;;; Low-level, D-Bus-related procedures.
+;;;
+
+;;; The following parameters are used in the jami-service-type service
+;;; definition to conveniently customize the behavior of the send-dbus helper,
+;;; even when called indirectly.
+(define %send-dbus-binary (make-parameter "dbus-send"))
+(define %send-dbus-bus (make-parameter #f))
+(define %send-dbus-user (make-parameter #f))
+(define %send-dbus-group (make-parameter #f))
+(define %send-dbus-debug (make-parameter #f))
+
+(define* (send-dbus #:key service path interface method
+                    bus
+                    dbus-send
+                    user group
+                    timeout
+                    arguments)
+  "Return the response of DBUS-SEND, else raise an error.  Unless explicitly
+provided, DBUS-SEND takes the value of the %SEND-DBUS-BINARY parameter.  BUS
+can be used to specify the bus address, such as 'unix:path=/var/run/jami/bus'.
+Alternatively, the %SEND-DBUS-BUS parameter can be used.  ARGUMENTS can be
+used to pass input values to a D-Bus method call.  TIMEOUT is the amount of
+time to wait for a reply in milliseconds before giving up with an error.  USER
+and GROUP allow choosing under which user/group the DBUS-SEND command is
+executed.  Alternatively, the %SEND-DBUS-USER and %SEND-DBUS-GROUP parameters
+can be used instead."
+  (let* ((command `(,(if dbus-send
+                         dbus-send
+                         (%send-dbus-binary))
+                    ,@(if (or bus (%send-dbus-bus))
+                          (list (string-append "--bus="
+                                               (or bus (%send-dbus-bus))))
+                          '())
+                    "--print-reply"
+                    ,@(if timeout
+                          (list (format #f "--reply-timeout=~d" timeout))
+                          '())
+                    ,(string-append "--dest=" service) ;e.g., cx.ring.Ring
+                    ,path            ;e.g., /cx/ring/Ring/ConfigurationManager
+                    ,(string-append interface "." method)
+                    ,@(or arguments '())))
+         (temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX")))
+         (temp-file (port-filename temp-port)))
+    (dynamic-wind
+      (lambda ()
+        (let* ((uid (or (and=> (or user (%send-dbus-user))
+                               (compose passwd:uid getpwnam)) -1))
+               (gid (or (and=> (or group (%send-dbus-group))
+                               (compose group:gid getgrnam)) -1)))
+          (chown temp-port uid gid)))
+      (lambda ()
+        (let ((pid (fork+exec-command command
+                                      #:user (or user (%send-dbus-user))
+                                      #:group (or group (%send-dbus-group))
+                                      #:log-file temp-file)))
+          (match (waitpid pid)
+            ((_ . status)
+             (let ((exit-status (status:exit-val status))
+                   (output (call-with-port temp-port get-string-all)))
+               (if (= 0 exit-status)
+                   output
+                   (error "the send-dbus command exited with: "
+                          command exit-status output)))))))
+      (lambda ()
+        (false-if-exception (delete-file temp-file))))))
+
+(define (parse-account-ids reply)
+  "Return the Jami account IDs from REPLY, which is assumed to be the output
+of the Jami D-Bus `getAccountList' method."
+  (array->list (parse-dbus-reply reply)))
+
+(define (parse-account-details reply)
+  "Parse REPLY, which is assumed to be the output of the Jami D-Bus
+`getAccountDetails' method, and return its content as an alist."
+  (dict->alist (parse-dbus-reply reply)))
+
+(define (parse-contacts reply)
+  "Parse REPLY, which is assumed to be the output of the Jamid D-Bus
+`getContacts' method, and return its content as an alist."
+  (match (parse-dbus-reply reply)
+    ('array
+     '())
+    (('array dicts ...)
+     (map dict->alist dicts))))
+
+
+;;;
+;;; Higher-level, D-Bus-related procedures.
+;;;
+
 (define (validate-fingerprint fingerprint)
   "Validate that fingerprint is 40 characters long."
   (unless (account-fingerprint? fingerprint)
     (error "Account fingerprint is not valid:" fingerprint)))
 
-(define (jami-service-available?)
-  "Whether the Jami D-Bus service was acquired by the D-Bus daemon."
-  (unless (%current-dbus-connection)
-    (initialize-dbus-connection!))
-  (dbus-service-available? "cx.ring.Ring"))
+(define (dbus-available-services)
+  "Return the list of available (acquired) D-Bus services."
+  (let ((reply (parse-dbus-reply
+                (send-dbus #:service "org.freedesktop.DBus"
+                           #:path "/org/freedesktop/DBus"
+                           #:interface "org.freedesktop.DBus"
+                           #:method "ListNames"))))
+    ;; Remove entries such as ":1.7".
+    (remove (cut string-prefix? ":" <>)
+            (array->list reply))))
 
-
-;;;
-;;; Bindings for the Jami D-Bus API.
-;;;
+(define (dbus-service-available? service)
+  "Predicate to check for the D-Bus SERVICE availability."
+  (member service (dbus-available-services)))
 
-(define* (call-configuration-manager-method method #:optional arguments
-                                            #:key timeout)
-  "Query the Jami D-Bus ConfigurationManager interface with METHOD applied to
-ARGUMENTS.  TIMEOUT can optionally be provided as a value in seconds."
-  (unless (%current-dbus-connection)
-    (initialize-dbus-connection!))
-  (call-dbus-method method
-                    #:path "/cx/ring/Ring/ConfigurationManager"
-                    #:destination "cx.ring.Ring"
-                    #:interface "cx.ring.Ring.ConfigurationManager"
-                    #:arguments arguments
-                    #:timeout timeout))
+(define* (send-dbus/configuration-manager #:key method arguments timeout)
+  "Query the Jami D-Bus ConfigurationManager service."
+  (send-dbus #:service "cx.ring.Ring"
+             #:path "/cx/ring/Ring/ConfigurationManager"
+             #:interface "cx.ring.Ring.ConfigurationManager"
+             #:method method
+             #:arguments arguments
+             #:timeout timeout))
 
 ;;; The following methods are for internal use; they make use of the account
 ;;; ID, an implementation detail of Jami the user should not need to be
@@ -108,17 +317,22 @@ ARGUMENTS.  TIMEOUT can optionally be provided as a value in seconds."
 (define (get-account-ids)
   "Return the available Jami account identifiers (IDs).  Account IDs are an
 implementation detail used to identify the accounts in Jami."
-  (vector->list (call-configuration-manager-method "getAccountList")))
+  (parse-account-ids
+   (send-dbus/configuration-manager #:method "getAccountList")))
 
 (define (id->account-details id)
   "Retrieve the account data associated with the given account ID."
-  (vector->list (call-configuration-manager-method "getAccountDetails"
-                                                   (list id))))
+  (parse-account-details
+   (send-dbus/configuration-manager
+    #:method "getAccountDetails"
+    #:arguments (list (string-append "string:" id)))))
 
 (define (id->volatile-account-details id)
   "Retrieve the account data associated with the given account ID."
-  (vector->list (call-configuration-manager-method "getVolatileAccountDetails"
-                                                   (list id))))
+  (parse-account-details
+   (send-dbus/configuration-manager
+    #:method "getVolatileAccountDetails"
+    #:arguments (list (string-append "string:" id)))))
 
 (define (id->account id)
   "Retrieve the complete account data associated with the given account ID."
@@ -148,16 +362,19 @@ implementation detail used to identify the accounts in Jami."
                        '()))))
            (get-account-ids))))
   (or (assoc-ref %username-to-id-cache username)
-      (let ((message (format #f "no account ID for ~:[username~;fingerprint~]"
-                             (account-fingerprint? username))))
+      (let ((message (format #f "Could not retrieve a local account ID\
+ for ~:[username~;fingerprint~]" (account-fingerprint? username))))
         (error message username))))
 
 (define (account->username account)
-  "Return the public key fingerprint of ACCOUNT."
-  (assoc-ref account "Account.username"))
+  "Return USERNAME, the registered username associated with ACCOUNT, else its
+public key fingerprint."
+  (or (assoc-ref account "Account.registeredName")
+      (assoc-ref account "Account.username")))
 
 (define (id->username id)
-  "Return the public key fingerprint corresponding to account with ID, else #f."
+  "Return USERNAME, the registered username associated with ID, else its
+public key fingerprint, else #f."
   (account->username (id->account id)))
 
 (define (get-accounts)
@@ -183,21 +400,27 @@ registered username."
 should *not* be encrypted with a password.  Return the username associated
 with the account."
   (invalidate-username-to-id-cache!)
-  (let ((id (call-configuration-manager-method
-             "addAccount" (list `#(("Account.archivePath" . ,archive)
-                                   ("Account.type" . "RING"))))))
+  (let ((reply (send-dbus/configuration-manager
+                #:method "addAccount"
+                #:arguments (list (string-append
+                                   "dict:string:string:Account.archivePath,"
+                                   archive
+                                   ",Account.type,RING")))))
     ;; The account information takes some time to be populated.
-    (with-retries 20 1
-      (let ((username (id->username id)))
-        (if (and=> username (negate string-null?))
-            username
-            #f)))))
+    (let ((id (deserialize-item (parse-dbus-reply reply))))
+      (with-retries 20 1
+        (let ((username (id->username id)))
+          (if (string-null? username)
+              #f
+              username))))))
 
 (define (remove-account username)
   "Delete the Jami account associated with USERNAME, the account 40 characters
 fingerprint or a registered username."
   (let ((id (username->id username)))
-    (call-configuration-manager-method "removeAccount" (list id)))
+    (send-dbus/configuration-manager
+     #:method "removeAccount"
+     #:arguments (list (string-append "string:" id))))
   (invalidate-username-to-id-cache!))
 
 (define* (username->contacts username)
@@ -207,16 +430,15 @@ contacts.  USERNAME can be either the account 40 characters public key
 fingerprint or a registered username.  The contacts returned are represented
 using their 40 characters fingerprint."
   (let* ((id (username->id username))
-         ;; The contacts are returned as "aa{ss}", that is, an array of arrays
-         ;; containing (string . string) pairs.
-         (contacts (map vector->list
-                        (vector->list (call-configuration-manager-method
-                                       "getContacts" (list id)))))
+         (reply (send-dbus/configuration-manager
+                 #:method "getContacts"
+                 #:arguments (list (string-append "string:" id))))
+         (all-contacts (parse-contacts reply))
          (banned? (lambda (contact)
                     (and=> (assoc-ref contact "banned")
                            (cut string=? "true" <>))))
-         (banned (filter banned? contacts))
-         (not-banned (filter (negate banned?) contacts))
+         (banned (filter banned? all-contacts))
+         (not-banned (filter (negate banned?) all-contacts))
          (fingerprint (cut assoc-ref <> "id")))
     (values (map fingerprint not-banned)
             (map fingerprint banned))))
@@ -227,20 +449,27 @@ the account associated with USERNAME (either a fingerprint or a registered
 username).  When BAN? is true, also mark the contact as banned."
   (validate-fingerprint contact)
   (let ((id (username->id username)))
-    (call-configuration-manager-method "removeContact" (list id contact ban?))))
+    (send-dbus/configuration-manager
+     #:method "removeContact"
+     #:arguments (list (string-append "string:" id)
+                       (string-append "string:" contact)
+                       (serialize-boolean ban?)))))
 
 (define (add-contact contact username)
   "Add CONTACT, the 40 characters public key fingerprint of a contact, to the
 account of USERNAME (either a fingerprint or a registered username)."
   (validate-fingerprint contact)
   (let ((id (username->id username)))
-    (call-configuration-manager-method "addContact" (list id contact))))
+    (send-dbus/configuration-manager
+     #:method "addContact"
+     #:arguments (list (string-append "string:" id)
+                       (string-append "string:" contact)))))
 
 (define* (set-account-details details username #:key timeout)
   "Set DETAILS, an alist containing the key value pairs to set for the account
 of USERNAME, a registered username or account fingerprint.  The value of the
 parameters not provided are unchanged.  TIMEOUT is a value in milliseconds to
-pass to the `call-configuration-manager-method' procedure."
+pass to the `send-dbus/configuration-manager' procedure."
   (let* ((id (username->id username))
          (current-details (id->account-details id))
          (updated-details (map (match-lambda
@@ -248,29 +477,52 @@ pass to the `call-configuration-manager-method' procedure."
                                   (or (and=> (assoc-ref details key)
                                              (cut cons key <>))
                                       (cons key value))))
-                               current-details)))
-    (call-configuration-manager-method
-     "setAccountDetails" (list id (list->vector updated-details))
-     #:timeout timeout)))
+                               current-details))
+         ;; dbus-send does not permit sending null strings (it throws a
+         ;; "malformed dictionary" error).  Luckily they seem to have the
+         ;; semantic of "default account value" in Jami; so simply drop them.
+         (updated-details* (remove (match-lambda
+                                     ((_ . value)
+                                      (string-null? value)))
+                                   updated-details)))
+    (send-dbus/configuration-manager
+     #:timeout timeout
+     #:method "setAccountDetails"
+     #:arguments
+     (list (string-append "string:" id)
+           (string-append "dict:string:string:"
+                          (string-join (alist->list updated-details*)
+                                       ","))))))
 
 (define (set-all-moderators enabled? username)
   "Set the 'AllModerators' property to enabled? for the account of USERNAME, a
 registered username or account fingerprint."
   (let ((id (username->id username)))
-    (call-configuration-manager-method "setAllModerators" (list id enabled?))))
+    (send-dbus/configuration-manager
+     #:method "setAllModerators"
+     #:arguments
+     (list (string-append "string:" id)
+           (serialize-boolean enabled?)))))
 
 (define (username->all-moderators? username)
   "Return the 'AllModerators' property for the account of USERNAME, a
 registered username or account fingerprint."
-  (let ((id (username->id username)))
-    (call-configuration-manager-method "isAllModerators" (list id))))
+  (let* ((id (username->id username))
+         (reply (send-dbus/configuration-manager
+                 #:method "isAllModerators"
+                 #:arguments
+                 (list (string-append "string:" id)))))
+    (deserialize-item (parse-dbus-reply reply))))
 
 (define (username->moderators username)
   "Return the moderators for the account of USERNAME, a registered username or
 account fingerprint."
-  (let* ((id (username->id username)))
-    (vector->list (call-configuration-manager-method "getDefaultModerators"
-                                                     (list id)))))
+  (let* ((id (username->id username))
+         (reply (send-dbus/configuration-manager
+                 #:method "getDefaultModerators"
+                 #:arguments
+                 (list (string-append "string:" id)))))
+    (array->list (parse-dbus-reply reply))))
 
 (define (set-moderator contact enabled? username)
   "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public
@@ -278,8 +530,11 @@ key fingerprint of a contact for the account of USERNAME, a registered
 username or account fingerprint."
   (validate-fingerprint contact)
   (let* ((id (username->id username)))
-    (call-configuration-manager-method "setDefaultModerator"
-                                       (list id contact enabled?))))
+    (send-dbus/configuration-manager #:method "setDefaultModerator"
+                                     #:arguments
+                                     (list (string-append "string:" id)
+                                           (string-append "string:" contact)
+                                           (serialize-boolean enabled?)))))
 
 (define (disable-account username)
   "Disable the account known by USERNAME, a registered username or account
@@ -288,7 +543,7 @@ fingerprint."
                        ;; Waiting for the reply on this command takes a very
                        ;; long time that trips the default D-Bus timeout value
                        ;; (25 s), for some reason.
-                        #:timeout 60))
+                        #:timeout 60000))
 
 (define (enable-account username)
   "Enable the account known by USERNAME, a registered username or account
@@ -326,3 +581,7 @@ requirements."
               (fold alist-delete account-details first-items))))
 
   (string-join (map pair->recutil-property sorted-account-details) "\n"))
+
+;; Local Variables:
+;; eval: (put 'with-retries 'scheme-indent-function 2)
+;; End:

gnu/build/linux-boot.scm

@@ -589,6 +589,15 @@ upon error."
         (load-linux-modules-from-directory linux-modules
                                            linux-module-directory)
 
+        (unless (or (member "hibernate=noresume" args)
+                    ;; Also handle the equivalent old-style argument.
+                    ;; See Documentation/admin-guide/kernel-parameters.txt.
+                    (member "noresume" args))
+          ;; Try to resume immediately after loading (storage) modules
+          ;; but before any on-disk file systems have been mounted.
+          (false-if-exception           ; failure is not fatal
+           (resume-if-hibernated (find-long-option "resume" args))))
+
         (when keymap-file
           (let ((status (system* "loadkeys" keymap-file)))
             (unless (zero? status)
@@ -622,15 +631,6 @@ the root file system...\n" root-delay)
           (unless (pre-mount)
             (error "pre-mount actions failed")))
 
-        (unless (or (member "hibernate=noresume" args)
-                    ;; Also handle the equivalent old-style argument.
-                    ;; See Documentation/admin-guide/kernel-parameters.txt.
-                    (member "noresume" args))
-          ;; Try to resume immediately after loading (storage) modules
-          ;; but before any on-disk file systems have been mounted.
-          (false-if-exception           ; failure is not fatal
-           (resume-if-hibernated (find-long-option "resume" args))))
-
         (setenv "EXT2FS_NO_MTAB_OK" "1")
 
         ;; Mount the root file system.

gnu/build/linux-container.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017-2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -233,7 +233,7 @@ that host UIDs (respectively GIDs) map to in the namespace."
   ;; The parent process must initialize the user namespace for the child
   ;; before it can boot.  To negotiate this, a pipe is used such that the
   ;; child process blocks until the parent writes to it.
-  (match (socketpair PF_UNIX (logior SOCK_CLOEXEC SOCK_STREAM) 0)
+  (match (socketpair PF_UNIX SOCK_STREAM 0)
     ((child . parent)
      (let ((flags (namespaces->bit-mask namespaces)))
        (match (clone flags)
@@ -301,28 +301,8 @@ delete it when leaving the dynamic extent of this call."
       (lambda ()
         (false-if-exception (delete-file-recursively tmp-dir))))))
 
-(define (wait-child-process)
-  "Wait for one child process and return a pair, like 'waitpid', or return #f
-if there are no child processes left."
-  (catch 'system-error
-    (lambda ()
-      (waitpid WAIT_ANY))
-    (lambda args
-      (if (= ECHILD (system-error-errno args))
-          #f
-          (apply throw args)))))
-
-(define (status->exit-status status)
-  "Reify STATUS as an exit status."
-  (or (status:exit-val status)
-      ;; See <http://www.tldp.org/LDP/abs/html/exitcodes.html#EXITCODESREF>.
-      (+ 128 (or (status:term-sig status)
-                 (status:stop-sig status)))))
-
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1) (guest-uid 0) (guest-gid 0)
-                              (relayed-signals (list SIGINT SIGTERM))
-                              (child-is-pid1? #t)
                               (process-spawned-hook (const #t)))
   "Run THUNK in a new container process and return its exit status; call
 PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
@@ -340,64 +320,20 @@ can map more than a single uid/gid.
 GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host
 UIDs (respectively GIDs) map to in the namespace.
 
-RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
-process when caught by its parent.
-
-When CHILD-IS-PID1? is true, and if NAMESPACES contains 'pid', then the child
-process runs directly as PID 1.  As such, it is responsible for (1) installing
-signal handlers and (2) reaping terminated processes by calling 'waitpid'.
-When CHILD-IS-PID1? is false, a new intermediate process is created instead
-that takes this responsibility.
-
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
-  (define thunk*
-    (if (and (memq 'pid namespaces)
-             (not child-is-pid1?))
-        (lambda ()
-          ;; Behave like an init process: create a sub-process that calls
-          ;; THUNK, and wait for child processes.  Furthermore, forward
-          ;; RELAYED-SIGNALS to the child process.
-          (match (primitive-fork)
-            (0
-             (call-with-clean-exit thunk))
-            (pid
-             (install-signal-handlers pid)
-             (let loop ()
-               (match (wait-child-process)
-                 ((child . status)
-                  (if (= child pid)
-                      (primitive-exit (status->exit-status status))
-                      (loop)))
-                 (#f
-                  (primitive-exit 128)))))))      ;cannot happen
-        thunk))
-
-  (define (periodically-schedule-asyncs)
-    ;; XXX: In Guile there's a time window where a signal-handling async could
-    ;; be queued without being processed by the time we enter a blocking
-    ;; syscall like waitpid(2) (info "(guile) Signals").  This terrible hack
-    ;; ensures pending asyncs get a chance to run periodically.
-    (sigaction SIGALRM (lambda _ (alarm 1)))
-    (alarm 1))
-
-  (define (install-signal-handlers pid)
-    ;; Install handlers that forward signals to PID.
-    (define (relay-signal signal)
-      (false-if-exception (kill pid signal)))
-
-    (periodically-schedule-asyncs)
-    (for-each (lambda (signal)
-                (sigaction signal relay-signal))
-              relayed-signals))
-
   (call-with-temporary-directory
    (lambda (root)
-     (let ((pid (run-container root mounts namespaces host-uids thunk*
+     (let ((pid (run-container root mounts namespaces host-uids thunk
                                #:guest-uid guest-uid
                                #:guest-gid guest-gid)))
-       (install-signal-handlers pid)
+       ;; Catch SIGINT and kill the container process.
+       (sigaction SIGINT
+         (lambda (signum)
+           (false-if-exception
+            (kill pid SIGKILL))))
+
        (process-spawned-hook pid)
        (match (waitpid pid)
          ((_ . status) status))))))
@@ -442,10 +378,6 @@ return the exit status."
   "Like 'container-excursion', but return the return value of THUNK."
   (match (pipe)
     ((in . out)
-     ;; Make sure IN and OUT are not inherited if THUNK forks + execs.
-     (fcntl in F_SETFD FD_CLOEXEC)
-     (fcntl out F_SETFD FD_CLOEXEC)
-
      (match (container-excursion pid
               (lambda ()
                 (close-port in)

gnu/build/linux-modules.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
@@ -28,7 +28,6 @@
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 ftw)
@@ -51,17 +50,6 @@
             load-linux-module*
             load-linux-modules-from-directory
 
-            pci-devices
-            pci-device?
-            pci-device-vendor
-            pci-device-id
-            pci-device-class
-            pci-device-module-alias
-            storage-pci-device?
-            network-pci-device?
-            display-pci-device?
-            load-pci-device-database
-
             current-module-debugging-port
 
             device-module-aliases
@@ -441,127 +429,6 @@ key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
       (line
        (loop (cons (key=value->pair line) result))))))
 
-;; PCI device known to the Linux kernel.
-(define-immutable-record-type <pci-device>
-  (pci-device vendor device class module-alias)
-  pci-device?
-  (vendor       pci-device-vendor)                ;integer
-  (device       pci-device-id)                    ;integer
-  (class        pci-device-class)                 ;integer
-  (module-alias pci-device-module-alias))         ;string | #f
-
-(define (pci-device-class-predicate mask bits)
-  (lambda (device)
-    "Return true if DEVICE has the chosen class."
-    (= (logand mask (pci-device-class device)) bits)))
-
-(define storage-pci-device?                   ;"Mass storage controller" class
-  (pci-device-class-predicate #xff0000 #x010000))
-(define network-pci-device?                       ;"Network controller" class
-  (pci-device-class-predicate #xff0000 #x020000))
-(define display-pci-device?                       ;"Display controller" class
-  (pci-device-class-predicate #xff0000 #x030000))
-
-(define (pci-devices)
-  "Return the list of PCI devices of the system (<pci-device> records)."
-  (define (read-hex port)
-    (let ((line (read-line port)))
-      (and (string? line)
-           (string-prefix? "0x" line)
-           (string->number (string-drop line 2) 16))))
-
-  (filter-map (lambda (directory)
-                (define properties
-                  (call-with-input-file (string-append directory "/uevent")
-                    read-uevent))
-                (define vendor
-                  (call-with-input-file (string-append directory "/vendor")
-                    read-hex))
-                (define device
-                  (call-with-input-file (string-append directory "/device")
-                    read-hex))
-                (define class
-                  (call-with-input-file (string-append directory "/class")
-                    read-hex))
-
-                (pci-device vendor device class
-                            (assq-ref properties 'MODALIAS)))
-              (find-files "/sys/bus/pci/devices"
-                          #:stat lstat)))
-
-(define (read-pci-device-database port)
-  "Parse the 'pci.ids' database that ships with the pciutils package and is
-maintained at <https://pci-ids.ucw.cz/>."
-  (define (comment? str)
-    (string-prefix? "#" (string-trim str)))
-  (define (blank? str)
-    (string-null? (string-trim-both str)))
-  (define (device? str)
-    (eqv? #\tab (string-ref str 0)))
-  (define (subvendor? str)
-    (string-prefix? "\t\t" str))
-  (define (class? str)
-    (string-prefix? "C " str))
-  (define (parse-id-line str)
-    (let* ((str   (string-trim-both str))
-           (space (string-index str char-set:whitespace)))
-      (values (string->number (string-take str space) 16)
-              (string-trim (string-drop str (+ 1 space))))))
-  (define (finish vendor vendor-id devices table)
-    (fold (lambda (device table)
-            (match device
-              ((device-id . name)
-               (vhash-consv (logior (ash vendor-id 16) device-id)
-                            (cons vendor name)
-                            table))))
-          table
-          devices))
-
-  (let loop ((table vlist-null)
-             (vendor-id #f)
-             (vendor #f)
-             (devices '()))
-    (match (read-line port)
-      ((? eof-object?)
-       (let ((table (if (and vendor vendor-id)
-                        (finish vendor vendor-id devices table)
-                        table)))
-         (lambda (vendor device)
-           (match (vhash-assv (logior (ash vendor 16) device) table)
-             (#f
-              (values #f #f))
-             ((_ . (vendor . name))
-              (values vendor name))))))
-      ((? comment?)
-       (loop table vendor-id vendor devices))
-      ((? blank?)
-       (loop table vendor-id vendor devices))
-      ((? subvendor?)                             ;currently ignored
-       (loop table vendor-id vendor devices))
-      ((? class?)                                 ;currently ignored
-       (loop table vendor-id vendor devices))
-      ((? device? line)
-       (let-values (((id name) (parse-id-line line)))
-         (loop table vendor-id vendor
-               (if (and vendor-id vendor)         ;class or device?
-                   (alist-cons id name devices)
-                   devices))))
-      (line
-       (let ((table (if (and vendor vendor-id)
-                        (finish vendor vendor-id devices table)
-                        table)))
-         (let-values (((vendor-id vendor) (parse-id-line line)))
-           (loop table vendor-id vendor '())))))))
-
-(define (load-pci-device-database file)
-  "Read the 'pci.ids' database at FILE (get it from the pciutils package or
-from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI
-vendor ID and a device ID (two integers) and returns the vendor name and
-device name as two values."
-  (let ((port (open-file file "r0")))
-    (call-with-gzip-input-port port
-      read-pci-device-database)))
-
 (define (device-module-aliases device)
   "Return the list of module aliases required by DEVICE, a /dev file name, as
 in this example:

gnu/build/marionette.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,19 +21,18 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
-  #:use-module (srfi srfi-71)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 regex)
   #:export (marionette?
-            marionette-pid
             make-marionette
             marionette-eval
             wait-for-file
             wait-for-tcp-port
             wait-for-unix-socket
             marionette-control
+            marionette-screen-text
             wait-for-screen-text
             %qwerty-us-keystrokes
             marionette-type
@@ -107,14 +105,11 @@ QEMU monitor and to the guest's backdoor REPL."
           "-monitor" (string-append "unix:" socket-directory "/monitor")
           "-chardev" (string-append "socket,id=repl,path=" socket-directory
                                     "/repl")
-          "-chardev" (string-append "socket,id=qga,server=on,wait=off,path="
-                                    socket-directory "/qemu-ga")
 
           ;; See
           ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
           "-device" "virtio-serial"
-          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"
-          "-device" "virtserialport,chardev=qga,name=org.qemu.guest_agent.0"))
+          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"))
 
   (define (accept* port)
     (match (select (list port) '() (list port) timeout)
@@ -179,18 +174,7 @@ QEMU monitor and to the guest's backdoor REPL."
     (($ <marionette> command pid monitor (= force repl))
      (write exp repl)
      (newline repl)
-     (with-exception-handler
-         (lambda (exn)
-           (simple-format
-            (current-error-port)
-            "error reading marionette response: ~A
-  remaining response: ~A\n"
-            exn
-            (get-line repl))
-           (raise-exception exn))
-       (lambda ()
-         (read repl))
-       #:unwind? #t))))
+     (read repl))))
 
 (define* (wait-for-file file marionette
                         #:key (timeout 10) (read 'read))
@@ -199,14 +183,7 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
   (match (marionette-eval
           `(let loop ((i ,timeout))
              (cond ((file-exists? ,file)
-                    (cons 'success
-                          (let ((content
-                                 (call-with-input-file ,file ,read)))
-                            (if (eof-object? content)
-                                ;; #<eof> can't be read, so convert to the
-                                ;; empty string
-                                ""
-                                content))))
+                    (cons 'success (call-with-input-file ,file ,read)))
                    ((> i 0)
                     (sleep 1)
                     (loop (- i 1)))
@@ -219,38 +196,31 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
      (error "file didn't show up" file))))
 
 (define* (wait-for-tcp-port port marionette
-                            #:key
-                            (timeout 20)
-                            (address `(make-socket-address AF_INET
-                                                           INADDR_LOOPBACK
-                                                           ,port)))
+                            #:key (timeout 20))
   "Wait for up to TIMEOUT seconds for PORT to accept connections in
-MARIONETTE.  ADDRESS must be an expression that returns a socket address,
-typically a call to 'make-socket-address'.  Raise an error on failure."
+MARIONETTE.  Raise an error on failure."
   ;; Note: The 'connect' loop has to run within the guest because, when we
   ;; forward ports to the host, connecting to the host never raises
   ;; ECONNREFUSED.
   (match (marionette-eval
-          `(let* ((address ,address)
-                  (sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
-             (let loop ((i 0))
-               (catch 'system-error
-                 (lambda ()
-                   (connect sock address)
-                   (close-port sock)
-                   'success)
-                 (lambda args
-                   (if (< i ,timeout)
-                       (begin
-                         (sleep 1)
-                         (loop (+ 1 i)))
-                       (list 'failure address))))))
+          `(begin
+             (let ((sock (socket PF_INET SOCK_STREAM 0)))
+               (let loop ((i 0))
+                 (catch 'system-error
+                   (lambda ()
+                     (connect sock AF_INET INADDR_LOOPBACK ,port)
+                     (close-port sock)
+                     'success)
+                   (lambda args
+                     (if (< i ,timeout)
+                         (begin
+                           (sleep 1)
+                           (loop (+ 1 i)))
+                         'failure))))))
           marionette)
     ('success #t)
-    (('failure address)
-     (error "nobody's listening on port"
-            (list (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
-                  (sockaddr:port address))))))
+    ('failure
+     (error "nobody's listening on port" port))))
 
 (define* (wait-for-unix-socket file-name marionette
                                 #:key (timeout 20))
@@ -278,8 +248,8 @@ accept connections in MARIONETTE.  Raise an error on failure."
 
 (define (marionette-control command marionette)
   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
-\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(QEMU) QEMU
-Monitor\")."
+\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
+pcsys_monitor\")."
   (match marionette
     (($ <marionette> _ _ monitor)
      (display command monitor)
@@ -287,87 +257,54 @@ Monitor\")."
      ;; The "quit" command terminates QEMU immediately, with no output.
      (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
 
-(define* (invoke-ocrad-ocr image #:key (ocrad "ocrad"))
-  "Invoke the OCRAD command on image, and return the recognized text."
-  (let* ((pipe (open-pipe* OPEN_READ ocrad "-i" "-s" "10" image))
-         (text (get-string-all pipe)))
-    (unless (zero? (close-pipe pipe))
-      (error "'ocrad' failed" ocrad))
-    text))
+(define* (marionette-screen-text marionette
+                                 #:key
+                                 (ocrad "ocrad"))
+  "Take a screenshot of MARIONETTE, perform optical character
+recognition (OCR), and return the text read from the screen as a string.  Do
+this by invoking OCRAD (file name for GNU Ocrad's command)"
+  (define (random-file-name)
+    (string-append "/tmp/marionette-screenshot-"
+                   (number->string (random (expt 2 32)) 16)
+                   ".ppm"))
 
-(define* (invoke-tesseract-ocr image #:key (tesseract "tesseract"))
-  "Invoke the TESSERACT command on IMAGE, and return the recognized text."
-  (let* ((output-basename (tmpnam))
-         (output-basename* (string-append output-basename ".txt")))
+  (let ((image (random-file-name)))
     (dynamic-wind
       (const #t)
       (lambda ()
-        (let ((exit-val (status:exit-val
-                         (system* tesseract image output-basename))))
-          (unless (zero? exit-val)
-            (error "'tesseract' failed" tesseract))
-          (call-with-input-file output-basename* get-string-all)))
-      (lambda ()
-        (false-if-exception (delete-file output-basename))
-        (false-if-exception (delete-file output-basename*))))))
+        (marionette-control (string-append "screendump " image)
+                            marionette)
 
-(define* (marionette-screen-text marionette #:key (ocr "ocrad"))
-  "Take a screenshot of MARIONETTE, perform optical character
-recognition (OCR), and return the text read from the screen as a string, along
-the screen dump image used.  Do this by invoking OCR, which should be the file
-name of GNU Ocrad's@command{ocrad} or Tesseract OCR's @command{tesseract}
-command.  The screen dump image returned as the second value should be deleted
-if it is not needed."
-  (define image (string-append (tmpnam) ".ppm"))
-  ;; Use the QEMU Monitor to save an image of the screen to the host.
-  (marionette-control (string-append "screendump " image) marionette)
-  ;; Process it via the OCR.
-  (cond
-   ((string-contains ocr "ocrad")
-    (values (invoke-ocrad-ocr image #:ocrad ocr) image))
-   ((string-contains ocr "tesseract")
-    (values (invoke-tesseract-ocr image #:tesseract ocr) image))
-   (else (error "unsupported ocr command"))))
+        ;; Tell Ocrad to invert the image colors (make it black on white) and
+        ;; to scale the image up, which significantly improves the quality of
+        ;; the result.  In spite of this, be aware that OCR confuses "y" and
+        ;; "V" and sometimes erroneously introduces white space.
+        (let* ((pipe (open-pipe* OPEN_READ ocrad
+                                 "-i" "-s" "10" image))
+               (text (get-string-all pipe)))
+          (unless (zero? (close-pipe pipe))
+            (error "'ocrad' failed" ocrad))
+          text))
+      (lambda ()
+        (false-if-exception (delete-file image))))))
 
 (define* (wait-for-screen-text marionette predicate
-                               #:key
-                               (ocr "ocrad")
-                               (timeout 30)
-                               pre-action
-                               post-action)
+                               #:key (timeout 30) (ocrad "ocrad"))
   "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
-PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded.
-The error contains the recognized text along the preserved file name of the
-screen dump, which is relative to the current working directory.  If
-PRE-ACTION is provided, it should be a thunk to call before each OCR attempt.
-Likewise for POST-ACTION, except it runs at the end of a successful OCR."
+PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
   (define start
     (car (gettimeofday)))
 
   (define end
     (+ start timeout))
 
-  (let loop ((last-text #f)
-             (last-screendump #f))
+  (let loop ()
     (if (> (car (gettimeofday)) end)
-        (let ((screendump-backup (string-drop last-screendump 5)))
-          ;; Move the file from /tmp/fileXXXXXX.pmm to the current working
-          ;; directory, so that it is preserved in the test derivation output.
-          (copy-file last-screendump screendump-backup)
-          (delete-file last-screendump)
-          (error "'wait-for-screen-text' timeout"
-                 'ocr-text: last-text
-                 'screendump: screendump-backup))
-        (let* ((_ (and (procedure? pre-action) (pre-action)))
-               (text screendump (marionette-screen-text marionette #:ocr ocr))
-               (_ (and (procedure? post-action) (post-action)))
-               (result (predicate text)))
-          (cond (result
-                 (delete-file screendump)
-                 result)
-                (else
-                 (sleep 1)
-                 (loop text screendump)))))))
+        (error "'wait-for-screen-text' timeout" predicate)
+        (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
+            (begin
+              (sleep 1)
+              (loop))))))
 
 (define %qwerty-us-keystrokes
   ;; Maps "special" characters to their keystrokes.
@@ -389,10 +326,8 @@ Likewise for POST-ACTION, except it runs at the end of a successful OCR."
     (#\> . "shift-dot")
     (#\. . "dot")
     (#\, . "comma")
-    (#\: . "shift-semicolon")
     (#\; . "semicolon")
     (#\' . "apostrophe")
-    (#\! . "shift-1")
     (#\" . "shift-apostrophe")
     (#\` . "grave_accent")
     (#\bs . "backspace")

gnu/build/secret-service.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -47,52 +47,6 @@
          ;; to syslog.
          #'(format (current-output-port) fmt args ...))))))
 
-(define-syntax with-modules
-  (syntax-rules ()
-    "Dynamically load the given MODULEs at run time, making the chosen
-bindings available within the lexical scope of BODY."
-    ((_ ((module #:select (bindings ...)) rest ...) body ...)
-     (let* ((iface (resolve-interface 'module))
-            (bindings (module-ref iface 'bindings))
-            ...)
-       (with-modules (rest ...) body ...)))
-    ((_ () body ...)
-     (begin body ...))))
-
-(define (wait-for-readable-fd port timeout)
-  "Wait until PORT has data available for reading or TIMEOUT has expired.
-Return #t in the former case and #f in the latter case."
-  (match (resolve-module '(fibers) #f)            ;using Fibers?
-    (#f
-     (log "blocking on socket...~%")
-     (match (select (list port) '() '() timeout)
-       (((_) () ()) #t)
-       ((() () ())  #f)))
-    (fibers
-     ;; We're running on the Shepherd 0.9+ with Fibers.  Arrange to make a
-     ;; non-blocking wait so that other fibers can be scheduled in while we
-     ;; wait for PORT.
-     (with-modules (((fibers) #:select (spawn-fiber sleep))
-                    ((fibers channels)
-                     #:select (make-channel put-message get-message)))
-       ;; Make PORT non-blocking.
-       (let ((flags (fcntl port F_GETFL)))
-         (fcntl port F_SETFL (logior O_NONBLOCK flags)))
-
-       (let ((channel (make-channel)))
-         (spawn-fiber
-          (lambda ()
-            (sleep timeout)                       ;suspends the fiber
-            (put-message channel 'timeout)))
-         (spawn-fiber
-          (lambda ()
-            (lookahead-u8 port)                   ;suspends the fiber
-            (put-message channel 'readable)))
-         (log "suspending fiber on socket...~%")
-         (match (get-message channel)
-           ('readable #t)
-           ('timeout  #f)))))))
-
 (define* (secret-service-send-secrets port secret-root
                                       #:key (retry 60)
                                       (handshake-timeout 120))
@@ -119,11 +73,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
                 files)))
 
   (log "sending secrets to ~a~%" port)
-  (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0))
-        (addr (make-socket-address AF_INET INADDR_LOOPBACK port))
-        (sleep (if (resolve-module '(fibers) #f)
-                   (module-ref (resolve-interface '(fibers)) 'sleep)
-                   sleep)))
+  (let ((sock (socket AF_INET SOCK_STREAM 0))
+        (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
     ;; Connect to QEMU on the forwarded port.  The 'connect' call succeeds as
     ;; soon as QEMU is ready, even if there's no server listening on the
     ;; forward port inside the guest.
@@ -142,22 +93,23 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
 
     ;; Wait for "hello" message from the server.  This is the only way to know
     ;; that we're really connected to the server inside the guest.
-    (if (wait-for-readable-fd sock handshake-timeout)
-        (match (read sock)
-          (('secret-service-server ('version version ...))
-           (log "sending files from ~s...~%" secret-root)
-           (send-files sock)
-           (log "done sending files to port ~a~%" port)
-           (close-port sock)
-           secret-root)
-          (x
-           (log "invalid handshake ~s~%" x)
-           (close-port sock)
-           #f))
-        (begin                                    ;timeout
-         (log "timeout while sending files to ~a~%" port)
-         (close-port sock)
-         #f))))
+    (match (select (list sock) '() '() handshake-timeout)
+      (((_) () ())
+       (match (read sock)
+         (('secret-service-server ('version version ...))
+          (log "sending files from ~s...~%" secret-root)
+          (send-files sock)
+          (log "done sending files to port ~a~%" port)
+          (close-port sock)
+          secret-root)
+         (x
+          (log "invalid handshake ~s~%" x)
+          (close-port sock)
+          #f)))
+      ((() () ())                                 ;timeout
+       (log "timeout while sending files to ~a~%" port)
+       (close-port sock)
+       #f))))
 
 (define (delete-file* file)
   "Ensure FILE does not exist."
@@ -177,7 +129,7 @@ and #f otherwise."
     ;; Wait for a TCP connection on PORT.  Note: We cannot use the
     ;; virtio-serial ports, which would be safer, because they are
     ;; (presumably) unsupported on GNU/Hurd.
-    (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0)))
+    (let ((sock (socket AF_INET SOCK_STREAM 0)))
       (bind sock AF_INET INADDR_ANY port)
       (listen sock 1)
       (log "waiting for secrets on port ~a...~%" port)
@@ -250,8 +202,4 @@ and #f otherwise."
       (close-port port))
     result))
 
-;;; Local Variables:
-;;; eval: (put 'with-modules 'scheme-indent-function 1)
-;;; End:
-
 ;;; secret-service.scm ends here

gnu/build/shepherd.scm

@@ -1,8 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
-;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,8 +30,7 @@
                                  exec-command
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
-  #:export (default-mounts
-            make-forkexec-constructor/container
+  #:export (make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
@@ -106,13 +103,8 @@
 separate mount and PID name space.  Return the \"outer\" PID. "
   (match (container-excursion* pid
            (lambda ()
-             ;; XXX: Trick for Shepherd 0.9: prevent 'read-pid-file' from
-             ;; using (@ (fibers) sleep), which would try to suspend the
-             ;; current task, which doesn't work in this extra process.
-             (with-continuation-barrier
-              (lambda ()
-                (read-pid-file pid-file
-                               #:max-delay max-delay)))))
+             (read-pid-file pid-file
+                            #:max-delay max-delay)))
     (#f
      ;; Send SIGTERM to the whole process group.
      (catch-system-error (kill (- pid) SIGTERM))
@@ -122,28 +114,6 @@ separate mount and PID name space.  Return the \"outer\" PID. "
      ;; PID is always 1, but that's not what Shepherd needs to know.
      pid)))
 
-(define* (exec-command* command #:key user group log-file pid-file
-                        (supplementary-groups '())
-                        (directory "/") (environment-variables (environ)))
-  "Like 'exec-command', but first restore signal handles modified by
-shepherd (PID 1)."
-  ;; First restore the default handlers.
-  (for-each (cut sigaction <> SIG_DFL) %precious-signals)
-
-  ;; Unblock any signals that have been blocked by the parent process.
-  (unblock-signals %precious-signals)
-
-  (mkdir-p "/var/run")
-  (clean-up pid-file)
-
-  (exec-command command
-                #:user user
-                #:group group
-                #:supplementary-groups supplementary-groups
-                #:log-file log-file
-                #:directory directory
-                #:environment-variables environment-variables))
-
 (define* (make-forkexec-constructor/container command
                                               #:key
                                               (namespaces
@@ -151,7 +121,6 @@ shepherd (PID 1)."
                                               (mappings '())
                                               (user #f)
                                               (group #f)
-                                              (supplementary-groups '())
                                               (log-file #f)
                                               pid-file
                                               (pid-file-timeout 5)
@@ -187,7 +156,7 @@ namespace, in addition to essential bind-mounts such /proc."
     (when log-file
       ;; Create LOG-FILE so we can map it in the container.
       (unless (file-exists? log-file)
-        (close (open log-file (logior O_CREAT O_APPEND O_CLOEXEC) #o640))
+        (call-with-output-file log-file (const #t))
         (when user
           (let ((pw (getpwnam user)))
             (chown log-file (passwd:uid pw) (passwd:gid pw))))))
@@ -195,16 +164,24 @@ namespace, in addition to essential bind-mounts such /proc."
     (let ((pid (run-container container-directory
                               mounts namespaces 1
                               (lambda ()
-                                (exec-command* command
-                                               #:user user
-                                               #:group group
-                                               #:supplementary-groups
-                                               supplementary-groups
-                                               #:pid-file pid-file
-                                               #:log-file log-file
-                                               #:directory directory
-                                               #:environment-variables
-                                               environment-variables)))))
+                                ;; First restore the default handlers.
+                                (for-each (cut sigaction <> SIG_DFL)
+                                          %precious-signals)
+
+                                ;; Unblock any signals that have been blocked
+                                ;; by the parent process.
+                                (unblock-signals %precious-signals)
+
+                                (mkdir-p "/var/run")
+                                (clean-up pid-file)
+
+                                (exec-command command
+                                              #:user user
+                                              #:group group
+                                              #:log-file log-file
+                                              #:directory directory
+                                              #:environment-variables
+                                              environment-variables)))))
       (if pid-file
           (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
               (read-pid-file/container pid pid-file
@@ -232,24 +209,14 @@ on Hurd systems for instance, fallback to direct forking."
         ((head . rest)
          (loop rest (cons head result))))))
 
-  (let ((container-support? (file-exists? "/proc/self/ns")))
-    (if (and container-support?
-             (not (and pid (= pid (getpid)))))
-        (container-excursion* pid
-          (lambda ()
-            ;; Note: In the Shepherd 0.9, 'fork+exec-command' expects to be
-            ;; called from the shepherd process (because it creates a pipe to
-            ;; capture stdout/stderr and spawns a logging fiber) so we cannot
-            ;; use it here.
-            (match (primitive-fork)
-              (0 (dynamic-wind
-                   (const #t)
-                   (lambda ()
-                     (apply exec-command* command (strip-pid args)))
-                   (lambda ()
-                     (primitive-_exit 127))))
-              (pid pid))))               ;XXX: assuming the same PID namespace
-        (apply fork+exec-command command (strip-pid args)))))
+  (let ((container-support?
+         (file-exists? "/proc/self/ns"))
+        (fork-proc (lambda ()
+                     (apply fork+exec-command command
+                            (strip-pid args)))))
+    (if container-support?
+        (container-excursion* pid fork-proc)
+        (fork-proc))))
 
 ;; Local Variables:
 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)

gnu/ci.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
@@ -21,16 +21,18 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu ci)
-  #:use-module (guix build-system channel)
+  #:use-module (guix channels)
   #:use-module (guix config)
-  #:autoload   (guix describe) (package-channels)
+  #:use-module (guix describe)
   #:use-module (guix store)
+  #:use-module (guix grafts)
   #:use-module (guix profiles)
   #:use-module (guix packages)
   #:autoload   (guix transformations) (tunable-package? tuned-package)
   #:use-module (guix channels)
   #:use-module (guix config)
   #:use-module (guix derivations)
+  #:use-module (guix build-system)
   #:use-module (guix monads)
   #:use-module (guix gexp)
   #:use-module (guix ui)
@@ -39,10 +41,9 @@
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module ((guix scripts system) #:select (read-operating-system))
   #:use-module ((guix scripts pack)
-                #:select (self-contained-tarball))
+                #:select (lookup-compressor self-contained-tarball))
   #:use-module (gnu bootloader)
   #:use-module (gnu bootloader u-boot)
-  #:use-module (gnu compression)
   #:use-module (gnu image)
   #:use-module (gnu packages)
   #:use-module (gnu packages gcc)
@@ -54,7 +55,6 @@
   #:use-module (gnu packages multiprecision)
   #:use-module (gnu packages make-bootstrap)
   #:use-module (gnu packages package-management)
-  #:use-module (guix platform)
   #:use-module (gnu system)
   #:use-module (gnu system image)
   #:use-module (gnu system vm)
@@ -71,6 +71,8 @@
             image->job
 
             %core-packages
+            %cross-targets
+            channel-source->package
 
             arguments->systems
             cuirass-jobs))
@@ -167,6 +169,17 @@ SYSTEM."
       (drop-right %core-packages 6)
       %core-packages))
 
+(define %cross-targets
+  '("mips64el-linux-gnu"
+    "arm-linux-gnueabihf"
+    "aarch64-linux-gnu"
+    "powerpc-linux-gnu"
+    "powerpc64le-linux-gnu"
+    "riscv64-linux-gnu"
+    "i586-pc-gnu"                                 ;aka. GNU/Hurd
+    "i686-w64-mingw32"
+    "x86_64-w64-mingw32"))
+
 (define (cross-jobs store system)
   "Return a list of cross-compilation jobs for SYSTEM."
   (define (from-32-to-64? target)
@@ -208,7 +221,7 @@ SYSTEM."
                                           package target system))
                      (packages-to-cross-build target)))
               (remove (either from-32-to-64? same? pointless?)
-                      (targets))))
+                      %cross-targets)))
 
 (define* (guix-jobs store systems #:key source commit)
   "Return a list of jobs for Guix itself."
@@ -251,44 +264,77 @@ otherwise use the IMAGE name."
          (drv (run-with-store store
                 (mbegin %store-monad
                   (set-guile-for-build (default-guile))
-                  (lower-object (system-image image) system)))))
+                  (lower-object (system-image image))))))
     (parameterize ((%graft? #f))
       (derivation->job name drv))))
 
-(define* (image-jobs store system
-                     #:key source commit)
+(define (image-jobs store system)
   "Return a list of jobs that build images for SYSTEM."
   (define MiB
     (expt 2 20))
 
-  (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
-    (if (member system %guix-system-supported-systems)
-        `(,(image->job store
-                       (image
-                        (inherit efi-disk-image)
-                        (operating-system installation-os))
-                       #:name "usb-image"
-                       #:system system)
-          ,(image->job
-            store
-            (image
-             (inherit (image-with-label
-                       iso9660-image
-                       (string-append "GUIX_" system "_"
-                                      (if (> (string-length %guix-version) 7)
-                                          (substring %guix-version 0 7)
-                                          %guix-version))))
-             (operating-system installation-os))
-            #:name "iso9660-image"
-            #:system system)
-          ;; Only cross-compile Guix System images from x86_64-linux for now.
-          ,@(if (string=? system "x86_64-linux")
-                (map (cut image->job store <>
-                          #:system system)
-                     %guix-system-images)
-                '()))
-        '())))
+  (if (member system %guix-system-supported-systems)
+      `(,(image->job store
+                     (image
+                      (inherit efi-disk-image)
+                      (operating-system installation-os))
+                     #:name "usb-image"
+                     #:system system)
+        ,(image->job
+          store
+          (image
+           (inherit (image-with-label
+                     iso9660-image
+                     (string-append "GUIX_" system "_"
+                                    (if (> (string-length %guix-version) 7)
+                                        (substring %guix-version 0 7)
+                                        %guix-version))))
+           (operating-system installation-os))
+          #:name "iso9660-image"
+          #:system system)
+        ;; Only cross-compile Guix System images from x86_64-linux for now.
+        ,@(if (string=? system "x86_64-linux")
+              (map (cut image->job store <>
+                        #:system system)
+                   %guix-system-images)
+              '()))
+      '()))
+
+(define channel-build-system
+  ;; Build system used to "convert" a channel instance to a package.
+  (let* ((build (lambda* (name inputs
+                               #:key source commit system
+                               #:allow-other-keys)
+                  (mlet* %store-monad ((source (if (string? source)
+                                                   (return source)
+                                                   (lower-object source)))
+                                       (instance
+                                        -> (checkout->channel-instance
+                                            source #:commit commit)))
+                    (channel-instances->derivation (list instance)))))
+         (lower (lambda* (name #:key system source commit
+                               #:allow-other-keys)
+                  (bag
+                    (name name)
+                    (system system)
+                    (build build)
+                    (arguments `(#:source ,source
+                                 #:commit ,commit))))))
+    (build-system (name 'channel)
+                  (description "Turn a channel instance into a package.")
+                  (lower lower))))
+
+(define* (channel-source->package source #:key commit)
+  "Return a package for the given channel SOURCE, a lowerable object."
+  (package
+    (inherit guix)
+    (version (string-append (package-version guix) "+"))
+    (build-system channel-build-system)
+    (arguments `(#:source ,source
+                 #:commit ,commit))
+    (inputs '())
+    (native-inputs '())
+    (propagated-inputs '())))
 
 (define* (system-test-jobs store system
                            #:key source commit)
@@ -531,9 +577,7 @@ names."
                                hello system))))
          ('images
           ;; Build Guix System images only.
-          (image-jobs store system
-                      #:source source
-                      #:commit commit))
+          (image-jobs store system))
          ('system-tests
           ;; Build Guix System tests only.
           (system-test-jobs store system

gnu/compression.scm

@@ -1,69 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
-;;;
-;;; 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 (gnu compression)
-  #:use-module (guix gexp)
-  #:use-module (guix ui)
-  #:use-module ((gnu packages compression) #:hide (zip))
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (ice-9 match)
-  #:export (compressor
-            compressor?
-            compressor-name
-            compressor-extension
-            compressor-command
-            %compressors
-            lookup-compressor))
-
-;; Type of a compression tool.
-(define-record-type <compressor>
-  (compressor name extension command)
-  compressor?
-  (name       compressor-name)      ;string (e.g., "gzip")
-  (extension  compressor-extension) ;string (e.g., ".lz")
-  (command    compressor-command))  ;gexp (e.g., #~(list "/gnu/store/…/gzip"
-                                    ;                    "-9n" ))
-
-(define %compressors
-  ;; Available compression tools.
-  (list (compressor "gzip"  ".gz"
-                    #~(list #+(file-append gzip "/bin/gzip") "-9n"))
-        (compressor "lzip"  ".lz"
-                    #~(list #+(file-append lzip "/bin/lzip") "-9"))
-        (compressor "xz"    ".xz"
-                    #~(append (list #+(file-append xz "/bin/xz")
-                                    "-e")
-                              (%xz-parallel-args)))
-        (compressor "bzip2" ".bz2"
-                    #~(list #+(file-append bzip2 "/bin/bzip2") "-9"))
-        (compressor "zstd" ".zst"
-                    ;; The default level 3 compresses better than gzip in a
-                    ;; fraction of the time, while the highest level 19
-                    ;; (de)compresses more slowly and worse than xz.
-                    #~(list #+(file-append zstd "/bin/zstd") "-3"))
-        (compressor "none" "" #f)))
-
-(define (lookup-compressor name)
-  "Return the compressor object called NAME.  Error out if it could not be
-found."
-  (or (find (match-lambda
-              (($ <compressor> name*)
-               (string=? name* name)))
-            %compressors)
-      (leave (G_ "~a: compressor not found~%") name)))

gnu/home.scm

@@ -1,6 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,8 +27,7 @@
   #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix store)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 regex)
+
   #:export (home-environment
             home-environment?
             this-home-environment
@@ -40,9 +38,7 @@
             home-environment-services
             home-environment-location
 
-            home-environment-with-provenance
-
-            home-generation-base))
+            home-environment-with-provenance))
 
 ;;; Comment:
 ;;;
@@ -96,7 +92,7 @@
            (home-environment-essential-services he))))
 
 (define* (home-environment-derivation he)
-  "Return a derivation that builds home environment."
+  "Return a derivation that builds OS."
   (let* ((services         (home-environment-services he))
          (home (fold-services services
                               #:target-type home-service-type)))
@@ -118,21 +114,3 @@ of HOME-PROVENANCE-SERVICE-TYPE to its services."
       (run-with-store store (home-environment-derivation he)
                       #:system system
                       #:target target)))))
-
-(define %profile-generation-rx
-  ;; Regexp that matches profile generation.
-  (make-regexp "(.*)-([0-9]+)-link$"))
-
-(define (home-generation-base file)
-  "If FILE is a Home generation GC root such as \"guix-home-42-link\",
-return its corresponding base---e.g., \"guix-home\".  Otherwise return #f.
-
-This is similar to the 'generation-profile' procedure but applied to Home
-generations."
-  (match (regexp-exec %profile-generation-rx file)
-    (#f #f)
-    (m  (let ((profile (match:substring m 1)))
-          ;; Distinguish from a "real" profile and from a system generation.
-          (and (file-exists? (string-append profile "/on-first-login"))
-               (file-exists? (string-append profile "/profile/manifest"))
-               profile)))))

gnu/home/services.scm

@@ -20,7 +20,6 @@
 (define-module (gnu home services)
   #:use-module (gnu services)
   #:use-module ((gnu packages package-management) #:select (guix))
-  #:use-module ((gnu packages base) #:select (coreutils))
   #:use-module (guix channels)
   #:use-module (guix monads)
   #:use-module (guix store)
@@ -34,26 +33,21 @@
   #:use-module (guix modules)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 vlist)
 
   #:export (home-service-type
             home-profile-service-type
             home-environment-variables-service-type
             home-files-service-type
             home-xdg-configuration-files-service-type
-            home-xdg-data-files-service-type
             home-run-on-first-login-service-type
             home-activation-service-type
             home-run-on-change-service-type
             home-provenance-service-type
 
-            environment-variable-shell-definitions
             home-files-directory
             xdg-configuration-files-directory
-            xdg-data-files-directory
 
             fold-home-service-types
-            lookup-home-service-types
             home-provenance
 
             %initialize-gettext)
@@ -171,34 +165,6 @@ packages, configuration files, activation script, and so on.")))
 configuration files that the user has declared in their
 @code{home-environment} record.")))
 
-(define (environment-variable-shell-definitions variables)
-  "Return a gexp that evaluates to a list of POSIX shell statements defining
-VARIABLES, a list of environment variable name/value pairs.  The returned code
-ensures variable values are properly quoted."
-  #~(let ((shell-quote
-           (lambda (value)
-             ;; Double-quote VALUE, leaving dollar sign as is.
-             (let ((quoted (list->string
-                            (string-fold-right
-                             (lambda (chr lst)
-                               (case chr
-                                 ((#\" #\\)
-                                  (append (list chr #\\) lst))
-                                 (else (cons chr lst))))
-                             '()
-                             value))))
-               (string-append "\"" quoted "\"")))))
-      (string-append
-       #$@(map (match-lambda
-                 ((key . #f)
-                  "")
-                 ((key . #t)
-                  #~(string-append "export " #$key "\n"))
-                 ((key . value)
-                  #~(string-append "export " #$key "="
-                                   (shell-quote #$value) "\n")))
-               variables))))
-
 (define (environment-variables->setup-environment-script vars)
   "Return a file that can be sourced by a POSIX compliant shell which
 initializes the environment.  The file will source the home
@@ -211,7 +177,7 @@ If value is @code{#f} variable will be omitted.
 If value is @code{#t} variable will be just exported.
 For any other, value variable will be set to the @code{value} and
 exported."
-  (define (warn-about-duplicate-definitions)
+  (define (warn-about-duplicate-defenitions)
     (fold
      (lambda (x acc)
        (when (equal? (car x) (car acc))
@@ -222,18 +188,15 @@ exported."
      (sort vars (lambda (a b)
                   (string<? (car a) (car b))))))
 
-  (warn-about-duplicate-definitions)
+  (warn-about-duplicate-defenitions)
   (with-monad
    %store-monad
    (return
     `(("setup-environment"
        ;; TODO: It's necessary to source ~/.guix-profile too
        ;; on foreign distros
-       ,(computed-file "setup-environment"
-                       #~(call-with-output-file #$output
-                           (lambda (port)
-                             (set-port-encoding! port "UTF-8")
-                             (display "\
+       ,(apply mixed-text-file "setup-environment"
+               "\
 HOME_ENVIRONMENT=$HOME/.guix-home
 GUIX_PROFILE=\"$HOME_ENVIRONMENT/profile\"
 PROFILE_FILE=\"$HOME_ENVIRONMENT/profile/etc/profile\"
@@ -260,10 +223,17 @@ case $XCURSOR_PATH in
   *) export XCURSOR_PATH=$HOME_ENVIRONMENT/profile/share/icons:$XCURSOR_PATH ;;
 esac
 
-" port)
-                             (display
-                              #$(environment-variable-shell-definitions vars)
-                              port)))))))))
+"
+
+               (append-map
+                (match-lambda
+                  ((key . #f)
+                   '())
+                  ((key . #t)
+                   (list "export " key "\n"))
+                  ((key . value)
+                   (list "export " key "=" value "\n")))
+                vars)))))))
 
 (define home-environment-variables-service-type
   (service-type (name 'home-environment-variables)
@@ -315,10 +285,10 @@ directory containing FILES."
                 (description "Files that will be put in
 @file{~~/.guix-home/files}, and further processed during activation.")))
 
-(define xdg-configuration-files-directory ".config")
+(define xdg-configuration-files-directory "config")
 
 (define (xdg-configuration-files files)
-  "Add .config/ prefix to each file-path in FILES."
+  "Add config/ prefix to each file-path in FILES."
   (map (match-lambda
          ((file-path . rest)
           (cons (string-append xdg-configuration-files-directory "/" file-path)
@@ -326,7 +296,7 @@ directory containing FILES."
          files))
 
 (define home-xdg-configuration-files-service-type
-  (service-type (name 'home-xdg-configuration)
+  (service-type (name 'home-files)
                 (extensions
                  (list (service-extension home-files-service-type
                                           xdg-configuration-files)))
@@ -334,30 +304,7 @@ directory containing FILES."
                 (extend append)
                 (default-value '())
                 (description "Files that will be put in
-@file{~~/.guix-home/files/.config}, and further processed during activation.")))
-
-(define xdg-data-files-directory ".local/share")
-
-(define (xdg-data-files files)
-  "Add .local/share prefix to each file-path in FILES."
-  (map (match-lambda
-         ((file-path . rest)
-          (cons (string-append xdg-data-files-directory "/" file-path)
-                rest)))
-         files))
-
-(define home-xdg-data-files-service-type
-  (service-type (name 'home-xdg-data)
-                (extensions
-                 (list (service-extension home-files-service-type
-                                          xdg-data-files)))
-                (compose concatenate)
-                (extend append)
-                (default-value '())
-                (description "Files that will be put in
-@file{~~/.guix-home/files/.local/share}, and further processed during
-activation.")))
-
+@file{~~/.guix-home/files/config}, and further processed during activation.")))
 
 (define %initialize-gettext
   #~(begin
@@ -368,11 +315,9 @@ activation.")))
 (define (compute-on-first-login-script _ gexps)
   (program-file
    "on-first-login"
-   (with-imported-modules (source-module-closure '((guix i18n)
-                                                   (guix diagnostics)))
+   (with-imported-modules (source-module-closure '((guix i18n)))
      #~(begin
-         (use-modules (guix i18n)
-                      (guix diagnostics))
+       (use-modules (guix i18n))
        #$%initialize-gettext
 
        (let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
@@ -389,7 +334,7 @@ activation.")))
                (begin #$@gexps (touch flag-file-path)))
              ;; TRANSLATORS: 'on-first-login' is the name of a service and
              ;; shouldn't be translated
-             (warning (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
+             (display (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
 won't execute anything.  You can check if xdg runtime directory exists,
 XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the
 script by running '$HOME/.guix-home/on-first-login'"))))))))
@@ -420,9 +365,8 @@ extended with one gexp.")))
             (he-path (string-append (getenv "HOME") "/.guix-home"))
             (new-home-env (getenv "GUIX_NEW_HOME"))
             (new-home (or new-home-env
-                          ;; Absolute path of the directory of the activation
-                          ;; file if called interactively.
-                          (canonicalize-path (dirname (car (command-line))))))
+                          ;; Path of the activation file if called interactively
+                          (dirname (car (command-line)))))
             (old-home-env (getenv "GUIX_OLD_HOME"))
             (old-home (or old-home-env
                           (if (file-exists? (he-init-file he-path))
@@ -430,9 +374,8 @@ extended with one gexp.")))
                               #f))))
        (if (file-exists? (he-init-file new-home))
            (let* ((port   ((@ (ice-9 popen) open-input-pipe)
-                           (format #f "source ~a && ~a -0"
-                                   (he-init-file new-home)
-                                   #$(file-append coreutils "/bin/env"))))
+                           (format #f "source ~a && env -0"
+                                   (he-init-file new-home))))
                   (result ((@ (ice-9 rdelim) read-delimited) "" port))
                   (vars (map (lambda (x)
                                (let ((si (string-index x #\=)))
@@ -637,13 +580,3 @@ environment, and its configuration file, when available.")))
 
 (define* (fold-home-service-types proc seed)
   (fold-service-types proc seed (all-home-service-modules)))
-
-(define lookup-home-service-types
-  (let ((table
-         (delay (fold-home-service-types (lambda (type result)
-                                           (vhash-consq (service-type-name type)
-                                                        type result))
-                                         vlist-null))))
-    (lambda (name)
-      "Return the list of services with the given NAME (a symbol)."
-      (vhash-foldq* cons '() name (force table)))))

gnu/home/services/desktop.scm

@@ -1,6 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2022 ( <paren@disroot.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +20,6 @@
   #:use-module (gnu home services)
   #:use-module (gnu home services shepherd)
   #:use-module (gnu services configuration)
-  #:autoload   (gnu packages glib)    (dbus)
   #:autoload   (gnu packages xdisorg) (redshift)
   #:use-module (guix records)
   #:use-module (guix gexp)
@@ -29,10 +27,8 @@
   #:use-module (ice-9 match)
   #:export (home-redshift-configuration
             home-redshift-configuration?
-            home-redshift-service-type
 
-            home-dbus-configuration
-            home-dbus-service-type))
+            home-redshift-service-type))
 
 
 ;;;
@@ -95,26 +91,26 @@ queried for location information.")
    "Nighttime color temperature (kelvins).")
 
   (daytime-brightness
-   maybe-inexact-number
+   (maybe-inexact-number 'disabled)
    "Daytime screen brightness, between 0.1 and 1.0.")
   (nighttime-brightness
-   maybe-inexact-number
+   (maybe-inexact-number 'disabled)
    "Nighttime screen brightness, between 0.1 and 1.0.")
 
   (latitude
-   maybe-inexact-number
+   (maybe-inexact-number 'disabled)
    "Latitude, when @code{location-provider} is @code{'manual}.")
   (longitude
-   maybe-inexact-number
+   (maybe-inexact-number 'disabled)
    "Longitude, when @code{location-provider} is @code{'manual}.")
 
   (dawn-time
-   maybe-string
+   (maybe-string 'disabled)
    "Custom time for the transition from night to day in the
 morning---@code{\"HH:MM\"} format.  When specified, solar elevation is not
 used to determine the daytime/nighttime period.")
   (dusk-time
-   maybe-string
+   (maybe-string 'disabled)
    "Likewise, custom time for the transition from day to night in the
 evening.")
 
@@ -165,8 +161,7 @@ format."))
          (start #~(make-forkexec-constructor
                    (list #$(file-append redshift "/bin/redshift")
                          "-c" #$config-file)))
-         (stop #~(make-kill-destructor))
-         (actions (list (shepherd-configuration-action config-file))))))
+         (stop #~(make-kill-destructor)))))
 
 (define home-redshift-service-type
   (service-type
@@ -177,52 +172,3 @@ format."))
    (description
     "Run Redshift, a program that adjusts the color temperature of display
 according to time of day.")))
-
-
-;;;
-;;; D-Bus.
-;;;
-
-(define-record-type* <home-dbus-configuration>
-  home-dbus-configuration make-home-dbus-configuration
-  home-dbus-configuration?
-  (dbus home-dbus-dbus                  ;file-like
-        (default dbus)))
-
-(define (home-dbus-shepherd-services config)
-  (list (shepherd-service
-         (documentation "Run the D-Bus daemon in session-specific mode.")
-         (provision '(dbus))
-         (start #~(make-forkexec-constructor
-                   (list #$(file-append (home-dbus-dbus config)
-                                        "/bin/dbus-daemon")
-                         "--nofork" "--session"
-                         (format #f "--address=unix:path=~a/bus"
-                                 (or (getenv "XDG_RUNTIME_DIR")
-                                     (format #f "/run/user/~a"
-                                             (getuid)))))
-                   #:environment-variables
-                   (cons "DBUS_VERBOSE=1"
-                         (default-environment-variables))
-                   #:log-file
-                   (format #f "~a/dbus.log"
-                           (or (getenv "XDG_LOG_HOME")
-                               (format #f "~a/.local/var/log"
-                                       (getenv "HOME"))))))
-         (stop #~(make-kill-destructor)))))
-
-(define (home-dbus-environment-variables config)
-  '(("DBUS_SESSION_BUS_ADDRESS"
-     . "unix:path=${XDG_RUNTIME_DIR:-/run/user/$UID}/bus")))
-
-(define home-dbus-service-type
-  (service-type
-   (name 'home-dbus)
-   (extensions
-    (list (service-extension home-shepherd-service-type
-                             home-dbus-shepherd-services)
-          (service-extension home-environment-variables-service-type
-                             home-dbus-environment-variables)))
-   (default-value (home-dbus-configuration))
-   (description
-    "Run the session-specific D-Bus inter-process message bus.")))

gnu/home/services/guix.scm

@@ -1,44 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Reily Siegel <mail@reilysiegel.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 (gnu home services guix)
-  #:use-module (gnu home services)
-  #:use-module (guix channels)
-  #:use-module (guix gexp)
-  #:use-module (ice-9 pretty-print)
-  #:use-module (srfi srfi-1)
-  #:export (home-channels-service-type))
-
-(define (channels-xdg-files channels)
-  `(("guix/channels.scm"
-     ,(plain-file
-       "channels.scm"
-       (call-with-output-string
-         (lambda (port)
-           (pretty-print (cons 'list (map channel->code channels)) port)))))))
-
-(define home-channels-service-type
-  (service-type
-   (name 'home-channels)
-   (default-value %default-channels)
-   (compose concatenate)
-   (extend append)
-   (extensions
-    (list (service-extension home-xdg-configuration-files-service-type
-                             channels-xdg-files)))
-   (description "Manages the per-user Guix channels specification.")))

gnu/home/services/mcron.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +20,6 @@
 (define-module (gnu home services mcron)
   #:use-module (gnu packages guile-xyz)
   #:use-module (gnu home services)
-  #:use-module (gnu services configuration)
   #:use-module (gnu services shepherd)
   #:use-module (gnu home services shepherd)
   #:use-module (guix records)
@@ -55,59 +53,45 @@
 ;;
 ;;; Code:
 
-(define list-of-gexps?
-  (list-of gexp?))
-
-(define-configuration/no-serialization home-mcron-configuration
-  (mcron (file-like mcron) "The mcron package to use.")
-  (jobs
-   (list-of-gexps '())
-   "This is a list of gexps (@pxref{G-Expressions}), where each gexp
-corresponds to an mcron job specification (@pxref{Syntax, mcron job
-specifications,, mcron, GNU@tie{}mcron}).")
-  (log? (boolean #t) "Log messages to standard output.")
-  (log-format
-   (string "~1@*~a ~a: ~a~%")
-   "@code{(ice-9 format)} format string for log messages.  The default value
-produces messages like \"@samp{@var{pid} @var{name}:
-@var{message}\"} (@pxref{Invoking mcron, Invoking,, mcron, GNU@tie{}mcron}).
-Each message is also prefixed by a timestamp by GNU Shepherd."))
+(define-record-type* <home-mcron-configuration> home-mcron-configuration
+  make-home-mcron-configuration
+  home-mcron-configuration?
+  (package home-mcron-configuration-package ; package
+           (default mcron))
+  (jobs home-mcron-configuration-jobs   ; list of jobs
+        (default '())))
 
 (define job-files (@@ (gnu services mcron) job-files))
 (define shepherd-schedule-action
   (@@ (gnu services mcron) shepherd-schedule-action))
 
-(define (home-mcron-shepherd-services config)
-  (match-record config <home-mcron-configuration>
-    (mcron jobs log? log-format)
-    (if (null? jobs)
-        '()                                       ;no jobs to run
-        (let ((files (job-files mcron jobs)))
-          (list (shepherd-service
-                 (documentation "User cron jobs.")
-                 (provision '(mcron))
-                 (modules `((srfi srfi-1)
-                            (srfi srfi-26)
-                            (ice-9 popen)         ;for the 'schedule' action
-                            (ice-9 rdelim)
-                            (ice-9 match)
-                            ,@%default-modules))
-                 (start #~(make-forkexec-constructor
-                           (list (string-append #$mcron "/bin/mcron")
-                                 #$@(if log?
-                                        #~("--log" "--log-format" #$log-format)
-                                        #~())
-                                 #$@files)
-                           #:log-file (string-append
-                                       (or (getenv "XDG_LOG_HOME")
-                                           (format #f "~a/.local/var/log"
-                                                   (getenv "HOME")))
-                                       "/mcron.log")))
-                 (stop #~(make-kill-destructor))
-                 (actions
-                  (list (shepherd-schedule-action mcron files)))))))))
+(define home-mcron-shepherd-services
+  (match-lambda
+    (($ <home-mcron-configuration> mcron '()) ; no jobs to run
+     '())
+    (($ <home-mcron-configuration> mcron jobs)
+     (let ((files (job-files mcron jobs)))
+       (list (shepherd-service
+              (documentation "User cron jobs.")
+              (provision '(mcron))
+              (modules `((srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 popen)            ; for the 'schedule' action
+                         (ice-9 rdelim)
+                         (ice-9 match)
+                         ,@%default-modules))
+              (start #~(make-forkexec-constructor
+                        (list #$(file-append mcron "/bin/mcron") #$@files)
+                        #:log-file (string-append
+                                    (or (getenv "XDG_LOG_HOME")
+                                        (format #f "~a/.local/var/log"
+                                                (getenv "HOME")))
+                                    "/mcron.log")))
+              (stop #~(make-kill-destructor))
+              (actions
+               (list (shepherd-schedule-action mcron files)))))))))
 
-(define home-mcron-profile (compose list home-mcron-configuration-mcron))
+(define home-mcron-profile (compose list home-mcron-configuration-package))
 
 (define (home-mcron-extend config jobs)
   (home-mcron-configuration
@@ -129,12 +113,3 @@ Each message is also prefixed by a timestamp by GNU Shepherd."))
                 (default-value (home-mcron-configuration))
                 (description
                  "Install and configure the GNU mcron cron job manager.")))
-
-
-;;;
-;;; Generate documentation.
-;;;
-(define (generate-doc)
-  (configuration->documentation 'home-mcron-configuration))
-
-;;; mcron.scm ends here

gnu/home/services/pm.scm

@@ -1,145 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 ( <paren@disroot.org>
-;;;
-;;; 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 (gnu home services pm)
-  #:use-module (guix gexp)
-  #:use-module (guix packages)
-  #:use-module (guix records)
-  #:use-module (gnu home services)
-  #:use-module (gnu home services shepherd)
-  #:use-module (gnu packages monitoring)
-  #:use-module (gnu services shepherd)
-
-  #:export (home-batsignal-configuration
-            home-batsignal-service-type))
-
-;;;
-;;; batsignal
-;;;
-;;; Daemon for running commands and displaying notifications on
-;;; battery events.
-;;;
-
-(define-record-type* <home-batsignal-configuration>
-  home-batsignal-configuration make-home-batsignal-configuration
-  home-batsignal-configuration?
-  (warning-level batsignal-warning-level                    ;integer
-                 (default 15))
-  (warning-message batsignal-warning-message                ;string | #f
-                   (default #f))
-  (critical-level batsignal-critical-level                  ;integer
-                 (default 5))
-  (critical-message batsignal-critical-message              ;string | #f
-                    (default #f))
-  (danger-level batsignal-danger-level                      ;integer
-                (default 2))
-  (danger-command batsignal-danger-command                  ;file-like | string | #f
-                  (default #f))
-  (full-level batsignal-full-level                          ;integer | #f
-              (default #f))
-  (full-message batsignal-full-message                      ;string | #f
-                (default #f))
-  (batteries batsignal-batteries                            ;list of string
-             (default '()))
-  (poll-delay batsignal-poll-delay                          ;integer
-              (default 60))
-  (icon batsignal-icon                                      ;file-like | #f
-        (default #f))
-  (notifications? batsignal-notifications?                  ;boolean
-                  (default #t))
-  (notifications-expire? batsignal-notifications-expire?    ;boolean
-                         (default #f))
-  (notification-command batsignal-notification-command      ;string | #f
-                        (default #f))
-  (ignore-missing? batsignal-ignore-missing?                ;boolean
-                   (default #f)))
-
-(define (home-batsignal-shepherd-services config)
-  (let ((warning-level (batsignal-warning-level config))
-        (warning-message (batsignal-warning-message config))
-        (critical-level (batsignal-critical-level config))
-        (critical-message (batsignal-critical-message config))
-        (danger-level (batsignal-danger-level config))
-        (danger-command (batsignal-danger-command config))
-        (full-level (batsignal-full-level config))
-        (full-message (batsignal-full-message config))
-        (batteries (batsignal-batteries config))
-        (poll-delay (batsignal-poll-delay config))
-        (icon (batsignal-icon config))
-        (notifications? (batsignal-notifications? config))
-        (notifications-expire? (batsignal-notifications-expire? config))
-        (notification-command (batsignal-notification-command config))
-        (ignore-missing? (batsignal-ignore-missing? config)))
-    (list (shepherd-service
-           (provision '(batsignal))
-           (documentation "Run the batsignal battery-watching daemon.")
-           (start #~(make-forkexec-constructor
-                     (append (list #$(file-append batsignal "/bin/batsignal")
-                                   "-w" (number->string #$warning-level)
-                                   "-c" (number->string #$critical-level)
-                                   "-d" (number->string #$danger-level)
-                                   "-m" (number->string #$poll-delay))
-                             (if #$warning-message
-                                 (list "-W" #$warning-message)
-                                 (list))
-                             (if #$critical-message
-                                 (list "-C" #$critical-message)
-                                 (list))
-                             (if #$danger-command
-                                 (list "-D" #$danger-command)
-                                 (list))
-                             (if #$full-level
-                                 (list "-f" (number->string #$full-level))
-                                 (list))
-                             (if #$full-message
-                                 (list "-F" #$full-message)
-                                 (list))
-                             (if (null? (list #$@batteries))
-                                 (list)
-                                 (list "-n" (string-join (list #$@batteries) ",")))
-                             (if #$icon
-                                 (list "-I" #$icon)
-                                 (list))
-                             (if #$notifications?
-                                 (list)
-                                 (list "-N"))
-                             (if #$notifications-expire?
-                                 (list "-e")
-                                 (list))
-                             (if #$notification-command
-                                 (list "-M" #$notification-command)
-                                 (list))
-                             (if #$ignore-missing?
-                                 (list "-i")
-                                 (list)))
-                     #:log-file (string-append
-                                 (or (getenv "XDG_LOG_HOME")
-                                     (format #f "~a/.local/var/log"
-                                               (getenv "HOME")))
-                                 "/batsignal.log")))
-           (stop #~(make-kill-destructor))))))
-
-(define home-batsignal-service-type
-  (service-type
-   (name 'home-batsignal)
-   (extensions
-    (list (service-extension home-shepherd-service-type
-                             home-batsignal-shepherd-services)))
-   (default-value (home-batsignal-configuration))
-   (description
-    "Run batsignal, a battery watching and notification daemon.")))

gnu/home/services/shells.scm

@@ -25,7 +25,6 @@
   #:use-module (gnu packages bash)
   #:use-module (guix gexp)
   #:use-module (guix packages)
-  #:use-module (guix records)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -78,7 +77,7 @@ user's customizations.  Extend home-shell-profile service only if you
 really know what you do."))
 
 (define (add-shell-profile-file config)
-  `((".profile"
+  `(("profile"
      ,(mixed-text-file
        "shell-profile"
        "\
@@ -112,7 +111,16 @@ service type can be extended with a list of file-like objects.")))
 
 (define (serialize-boolean field-name val) "")
 (define (serialize-posix-env-vars field-name val)
-  (environment-variable-shell-definitions val))
+  #~(string-append
+     #$@(map
+         (match-lambda
+           ((key . #f)
+            "")
+           ((key . #t)
+            #~(string-append "export " #$key "\n"))
+           ((key . value)
+            #~(string-append "export " #$key "=" #$value "\n")))
+         val)))
 
 
 ;;;
@@ -184,9 +192,9 @@ another process for example)."))
   (mixed-text-file
    "zprofile"
    "\
-# Set up the system, user profile, and related variables.
+# Setups system and user profiles and related variables
 source /etc/profile
-# Set up the home environment profile.
+# Setups home environment profile
 source ~/.profile
 
 # It's only necessary if zsh is a login shell, otherwise profiles will
@@ -203,18 +211,18 @@ source ~/.profile
         (zsh-serialize-field config field)))))
 
 (define (zsh-get-configuration-files config)
-  `((".zprofile" ,(zsh-file-by-field config 'zprofile)) ;; Always non-empty
-    ,@(if (or (zsh-field-not-empty? config 'zshenv)
-              (zsh-field-not-empty? config 'environment-variables))
-          `((".zshenv" ,(zsh-file-by-field config 'zshenv))) '())
+  `(("zprofile" ,(zsh-file-by-field config 'zprofile)) ;; Always non-empty
+    ,@(if (and (zsh-field-not-empty? config 'zshenv)
+               (zsh-field-not-empty? config 'environment-variables))
+          `(("zshenv" ,(zsh-file-by-field config 'zshenv))) '())
     ,@(if (zsh-field-not-empty? config 'zshrc)
-          `((".zshrc" ,(zsh-file-by-field config 'zshrc))) '())
+          `(("zshrc" ,(zsh-file-by-field config 'zshrc))) '())
     ,@(if (zsh-field-not-empty? config 'zlogin)
-          `((".zlogin" ,(zsh-file-by-field config 'zlogin))) '())
+          `(("zlogin" ,(zsh-file-by-field config 'zlogin))) '())
     ,@(if (zsh-field-not-empty? config 'zlogout)
-          `((".zlogout" ,(zsh-file-by-field config 'zlogout))) '())))
+          `(("zlogout" ,(zsh-file-by-field config 'zlogout))) '())))
 
-(define (add-zsh-dot-configuration config)
+(define (zsh-home-files config)
   (define zshenv-auxiliary-file
     (mixed-text-file
      "zshenv-auxiliary"
@@ -222,14 +230,14 @@ source ~/.profile
      "[[ -f $ZDOTDIR/.zshenv ]] && source $ZDOTDIR/.zshenv\n"))
 
   (if (home-zsh-configuration-xdg-flavor? config)
-      `((".zshenv" ,zshenv-auxiliary-file))
+      `(("zshenv" ,zshenv-auxiliary-file))
       (zsh-get-configuration-files config)))
 
-(define (add-zsh-xdg-configuration config)
+(define (zsh-xdg-configuration-files config)
   (if (home-zsh-configuration-xdg-flavor? config)
       (map
        (lambda (lst)
-         (cons (string-append "zsh/" (car lst))
+         (cons (string-append "zsh/." (car lst))
                (cdr lst)))
        (zsh-get-configuration-files config))
       '()))
@@ -290,10 +298,10 @@ source ~/.profile
                 (extensions
                  (list (service-extension
                         home-files-service-type
-                        add-zsh-dot-configuration)
+                        zsh-home-files)
                        (service-extension
                         home-xdg-configuration-files-service-type
-                        add-zsh-xdg-configuration)
+                        zsh-xdg-configuration-files)
                        (service-extension
                         home-profile-service-type
                         add-zsh-packages)))
@@ -422,7 +430,7 @@ alias grep='grep --color=auto'\n")
           (field-obj (car (filter-fields field))))
       (if (or extra-content
               (not (null? ((configuration-field-getter field-obj) config))))
-          `(,(string-append "." (object->snake-case-string file-name))
+          `(,(object->snake-case-string file-name)
             ,(apply mixed-text-file
                     (object->snake-case-string file-name)
                     (append (or extra-content '())
@@ -431,13 +439,13 @@ alias grep='grep --color=auto'\n")
 
   (filter
    (compose not null?)
-   `((".bash_profile"
+   `(("bash_profile"
       ,(mixed-text-file
         "bash_profile"
         "\
-# Set up the system, user profile, and related variables.
+# Setups system and user profiles and related variables
 # /etc/profile will be sourced by bash automatically
-# Set up the home environment profile.
+# Setups home environment profile
 if [ -f ~/.profile ]; then source ~/.profile; fi
 
 # Honor per-interactive-shell startup file
@@ -480,30 +488,31 @@ with text blocks from other extensions and the base service.")
 with text blocks from other extensions and the base service."))
 
 (define (home-bash-extensions original-config extension-configs)
-  (match-record original-config <home-bash-configuration>
-    (environment-variables aliases bash-profile bashrc bash-logout)
-    (home-bash-configuration
-     (inherit original-config)
-     (environment-variables
-      (append environment-variables
-              (append-map
-               home-bash-extension-environment-variables extension-configs)))
-     (aliases
-      (append aliases
-              (append-map
-               home-bash-extension-aliases extension-configs)))
-     (bash-profile
-      (append bash-profile
-              (append-map
-               home-bash-extension-bash-profile extension-configs)))
-     (bashrc
-      (append bashrc
-              (append-map
-               home-bash-extension-bashrc extension-configs)))
-     (bash-logout
-      (append bash-logout
-              (append-map
-               home-bash-extension-bash-logout extension-configs))))))
+  (match original-config
+    (($ <home-bash-configuration> _ _ _ environment-variables aliases
+                                  bash-profile bashrc bash-logout)
+     (home-bash-configuration
+      (inherit original-config)
+      (environment-variables
+       (append environment-variables
+               (append-map
+                home-bash-extension-environment-variables extension-configs)))
+      (aliases
+       (append aliases
+               (append-map
+                home-bash-extension-aliases extension-configs)))
+      (bash-profile
+       (append bash-profile
+               (append-map
+                home-bash-extension-bash-profile extension-configs)))
+      (bashrc
+       (append bashrc
+               (append-map
+                home-bash-extension-bashrc extension-configs)))
+      (bash-logout
+       (append bash-logout
+               (append-map
+                home-bash-extension-bash-logout extension-configs)))))))
 
 (define home-bash-service-type
   (service-type (name 'home-bash)
@@ -546,9 +555,9 @@ with text blocks from other extensions and the base service."))
                ((key . #f)
                 "")
                ((key . #t)
-                #~(string-append "set -x " #$key "\n"))
+                #~(string-append "set " #$key "\n"))
                ((key . value)
-                #~(string-append "set -x " #$key " "  #$value "\n")))
+                #~(string-append "set " #$key " "  #$value "\n")))
              val)))
 
 (define-configuration home-fish-configuration
@@ -577,7 +586,7 @@ when typed in the shell, will automatically expand to the full text."
    serialize-fish-abbreviations))
 
 (define (fish-files-service config)
-  `(("fish/config.fish"
+  `(("config/fish/config.fish"
      ,(mixed-text-file
        "fish-config.fish"
        #~(string-append "\
@@ -641,7 +650,7 @@ end\n\n")
   (service-type (name 'home-fish)
                 (extensions
                  (list (service-extension
-                        home-xdg-configuration-files-service-type
+                        home-files-service-type
                         fish-files-service)
                        (service-extension
                         home-profile-service-type

gnu/home/services/shepherd.scm

@@ -45,32 +45,28 @@
                shepherd-service-auto-start?
                shepherd-service-modules
 
-               shepherd-action
-               shepherd-configuration-action))
+               shepherd-action))
 
 (define-record-type* <home-shepherd-configuration>
   home-shepherd-configuration make-home-shepherd-configuration
   home-shepherd-configuration?
   (shepherd home-shepherd-configuration-shepherd
-            (default shepherd-0.9)) ; package
+            (default shepherd)) ; package
   (auto-start? home-shepherd-configuration-auto-start?
                (default #t))
-  (daemonize? home-shepherd-configuration-daemonize?
-              (default #t))
   (services home-shepherd-configuration-services
             (default '())))
 
-(define (home-shepherd-configuration-file config)
+(define (home-shepherd-configuration-file services shepherd)
   "Return the shepherd configuration file for SERVICES.  SHEPHERD is used
 as shepherd package."
-  (let* ((daemonize? (home-shepherd-configuration-daemonize? config))
-         (services (home-shepherd-configuration-services config))
-         (_ (assert-valid-graph services))
-         (files (map shepherd-service-file services))
-         ;; TODO: Add compilation of services, it can improve start
-         ;; time.
-         ;; (scm->go (cute scm->go <> shepherd))
-         )
+  (assert-valid-graph services)
+
+  (let ((files (map shepherd-service-file services))
+        ;; TODO: Add compilation of services, it can improve start
+        ;; time.
+        ;; (scm->go (cute scm->go <> shepherd))
+        )
     (define config
       #~(begin
           (use-modules (srfi srfi-34)
@@ -80,53 +76,42 @@ as shepherd package."
            (map
             (lambda (file) (load file))
             '#$files))
-
-          #$@(if daemonize?
-                 `((action 'root 'daemonize))
-                 '())
-
+          (action 'root 'daemonize)
           (format #t "Starting services...~%")
-          (let ((services-to-start
-                 '#$(append-map shepherd-service-provision
-                                (filter shepherd-service-auto-start?
-                                        services))))
-            (if (defined? 'start-in-the-background)
-                (start-in-the-background services-to-start)
-                (for-each start services-to-start))
-
-            (redirect-port (open-input-file "/dev/null")
-                           (current-input-port)))))
+          (for-each
+           (lambda (service) (start service))
+           '#$(append-map shepherd-service-provision
+                          (filter shepherd-service-auto-start?
+                                  services)))
+          (newline)))
 
     (scheme-file "shepherd.conf" config)))
 
 (define (launch-shepherd-gexp config)
-  (let* ((shepherd (home-shepherd-configuration-shepherd config)))
+  (let* ((shepherd (home-shepherd-configuration-shepherd config))
+         (services (home-shepherd-configuration-services config)))
     (if (home-shepherd-configuration-auto-start? config)
         (with-imported-modules '((guix build utils))
-          #~(unless (file-exists?
-                     (string-append
-                      (or (getenv "XDG_RUNTIME_DIR")
-                          (format #f "/run/user/~a" (getuid)))
-                      "/shepherd/socket"))
-              (let ((log-dir (or (getenv "XDG_LOG_HOME")
-                                 (format #f "~a/.local/var/log"
-                                         (getenv "HOME")))))
-                ;; TODO: Remove it, 0.9.2 creates it automatically?
-                ((@ (guix build utils) mkdir-p) log-dir)
-                (system*
-                 #$(file-append shepherd "/bin/shepherd")
-                 "--logfile"
-                 (string-append log-dir "/shepherd.log")
-                 "--config"
-                 #$(home-shepherd-configuration-file config)))))
+          #~(let ((log-dir (or (getenv "XDG_LOG_HOME")
+                               (format #f "~a/.local/var/log" (getenv "HOME")))))
+              ((@ (guix build utils) mkdir-p) log-dir)
+              (system*
+               #$(file-append shepherd "/bin/shepherd")
+               "--logfile"
+               (string-append
+                log-dir
+                "/shepherd.log")
+               "--config"
+               #$(home-shepherd-configuration-file services shepherd))))
         #~"")))
 
 (define (reload-configuration-gexp config)
-  (let* ((shepherd (home-shepherd-configuration-shepherd config)))
+  (let* ((shepherd (home-shepherd-configuration-shepherd config))
+         (services (home-shepherd-configuration-services config)))
     #~(system*
        #$(file-append shepherd "/bin/herd")
        "load" "root"
-       #$(home-shepherd-configuration-file config))))
+       #$(home-shepherd-configuration-file services shepherd))))
 
 (define (ensure-shepherd-gexp config)
   #~(if (file-exists?
@@ -137,18 +122,12 @@ as shepherd package."
         #$(reload-configuration-gexp config)
         #$(launch-shepherd-gexp config)))
 
-(define (shepherd-xdg-configuration-files config)
-  `(("shepherd/init.scm" ,(home-shepherd-configuration-file config))))
-
 (define-public home-shepherd-service-type
   (service-type (name 'home-shepherd)
                 (extensions
                  (list (service-extension
                         home-run-on-first-login-service-type
                         launch-shepherd-gexp)
-                       (service-extension
-                        home-xdg-configuration-files-service-type
-                        shepherd-xdg-configuration-files)
                        (service-extension
                         home-activation-service-type
                         ensure-shepherd-gexp)

gnu/home/services/ssh.scm

@@ -1,256 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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 (gnu home services ssh)
-  #:use-module (guix gexp)
-  #:use-module (guix records)
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
-  #:use-module (gnu services)
-  #:use-module (gnu services configuration)
-  #:use-module (guix modules)
-  #:use-module (gnu home services)
-  #:use-module ((gnu home services utils)
-                #:select (object->camel-case-string))
-  #:autoload   (gnu packages base) (glibc-utf8-locales)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
-  #:use-module (ice-9 match)
-  #:export (home-openssh-configuration
-            home-openssh-configuration-authorized-keys
-            home-openssh-configuration-known-hosts
-            home-openssh-configuration-hosts
-
-            openssh-host
-            openssh-host-host-name
-            openssh-host-identity-file
-            openssh-host-name
-            openssh-host-port
-            openssh-host-user
-            openssh-host-forward-x11?
-            openssh-host-forward-x11-trusted?
-            openssh-host-forward-agent?
-            openssh-host-compression?
-            openssh-host-proxy-command
-            openssh-host-host-key-algorithms
-            openssh-host-accepted-key-types
-            openssh-host-extra-content
-
-            home-openssh-service-type))
-
-(define (serialize-field-name name)
-  (match name
-    ('accepted-key-types "PubkeyAcceptedKeyTypes")
-    (_
-     (let ((name (let ((str (symbol->string name)))
-                   (if (string-suffix? "?" str)
-                       (string->symbol (string-drop-right str 1))
-                       name))))
-       (object->camel-case-string name 'upper)))))
-
-(define (serialize-string field value)
-  (string-append "  " (serialize-field-name field)
-                 " " value "\n"))
-
-(define (address-family? obj)
-  (memv obj (list AF_INET AF_INET6)))
-
-(define-maybe address-family)
-
-(define (serialize-address-family field family)
-  (if (maybe-value-set? family)
-      (string-append "  " (serialize-field-name field) " "
-                     (cond ((= family AF_INET) "inet")
-                           ((= family AF_INET6) "inet6")
-                           ;; The 'else' branch is unreachable.
-                           (else (raise (condition (&error)))))
-                     "\n")
-      ""))
-
-(define (natural-number? obj)
-  (and (integer? obj) (exact? obj) (> obj 0)))
-
-(define (serialize-natural-number field value)
-  (string-append "  " (serialize-field-name field) " "
-                 (number->string value) "\n"))
-
-(define (serialize-boolean field value)
-  (string-append "  " (serialize-field-name field) " "
-                 (if value "yes" "no") "\n"))
-
-(define-maybe string)
-(define-maybe natural-number)
-
-(define (serialize-raw-configuration-string field value)
-  (string-append value "\n"))
-(define raw-configuration-string? string?)
-
-(define (string-list? lst)
-  (and (pair? lst) (every string? lst)))
-(define (serialize-string-list field lst)
-  (string-append "  " (serialize-field-name field) " "
-                 (string-join lst ",") "\n"))
-
-(define-maybe string-list)
-
-(define-configuration openssh-host
-  (name
-   (string)
-   "Name of this host declaration.")
-  (host-name
-   maybe-string
-   "Host name---e.g., @code{\"foo.example.org\"} or @code{\"192.168.1.2\"}.")
-  (address-family
-   maybe-address-family
-   "Address family to use when connecting to this host: one of
-@code{AF_INET} (for IPv4 only), @code{AF_INET6} (for IPv6 only).
-Additionally, the field can be left unset to allow any address family.")
-  (identity-file
-   maybe-string
-   "The identity file to use---e.g.,
-@code{\"/home/charlie/.ssh/id_ed25519\"}.")
-  (port
-   maybe-natural-number
-   "TCP port number to connect to.")
-  (user
-   maybe-string
-   "User name on the remote host.")
-  (forward-x11?
-   (boolean #f)
-   "Whether to forward remote client connections to the local X11 graphical
-display.")
-  (forward-x11-trusted?
-   (boolean #f)
-   "Whether remote X11 clients have full access to the original X11 graphical
-display.")
-  (forward-agent?
-   (boolean #f)
-   "Whether the authentication agent (if any) is forwarded to the remote
-machine.")
-  (compression?
-   (boolean #f)
-   "Whether to compress data in transit.")
-  (proxy-command
-   maybe-string
-   "The command to use to connect to the server.  As an example, a command
-to connect via an HTTP proxy at 192.0.2.0 would be: @code{\"nc -X
-connect -x 192.0.2.0:8080 %h %p\"}.")
-  (host-key-algorithms
-   maybe-string-list
-   "The list of accepted host key algorithms---e.g.,
-@code{'(\"ssh-ed25519\")}.")
-  (accepted-key-types
-   maybe-string-list
-   "The list of accepted user public key types.")
-  (extra-content
-   (raw-configuration-string "")
-   "Extra content appended as-is to this @code{Host} block in
-@file{~/.ssh/config}."))
-
-(define (serialize-openssh-host config)
-  (define (openssh-host-name-field? field)
-    (eq? (configuration-field-name field) 'name))
-
-  (string-append
-   "Host " (openssh-host-name config) "\n"
-   (string-concatenate
-    (map (lambda (field)
-           ((configuration-field-serializer field)
-            (configuration-field-name field)
-            ((configuration-field-getter field) config)))
-         (remove openssh-host-name-field?
-                 openssh-host-fields)))))
-
-(define-record-type* <home-openssh-configuration>
-  home-openssh-configuration make-home-openssh-configuration
-  home-openssh-configuration?
-  (authorized-keys home-openssh-configuration-authorized-keys ;list of file-like
-                   (default '()))
-  (known-hosts     home-openssh-configuration-known-hosts ;unspec | list of file-like
-                   (default *unspecified*))
-  (hosts           home-openssh-configuration-hosts   ;list of <openssh-host>
-                   (default '())))
-
-(define (openssh-configuration->string config)
-  (string-join (map serialize-openssh-host
-                    (home-openssh-configuration-hosts config))
-               "\n"))
-
-(define* (file-join name files #:optional (delimiter " "))
-  "Return a file in the store called @var{name} that is the concatenation
-of all the file-like objects listed in @var{files}, with @var{delimited}
-inserted after each of them."
-  (computed-file name
-                 (with-imported-modules '((guix build utils))
-                   #~(begin
-                       (use-modules (guix build utils))
-
-                       ;; Support non-ASCII file names.
-                       (setenv "GUIX_LOCPATH"
-                               #+(file-append glibc-utf8-locales
-                                              "/lib/locale"))
-                       (setlocale LC_ALL "en_US.utf8")
-
-                       (call-with-output-file #$output
-                         (lambda (output)
-                           (for-each (lambda (file)
-                                       (call-with-input-file file
-                                         (lambda (input)
-                                           (dump-port input output)))
-                                       (display #$delimiter output))
-                                     '#$files)))))))
-
-(define (openssh-configuration-files config)
-  (let ((config (plain-file "ssh.conf"
-                            (openssh-configuration->string config)))
-        (known-hosts (home-openssh-configuration-known-hosts config))
-        (authorized-keys (file-join
-                          "authorized_keys"
-                          (home-openssh-configuration-authorized-keys config)
-                          "\n")))
-    `((".ssh/authorized_keys" ,authorized-keys)
-      ,@(if (unspecified? known-hosts)
-            '()
-            `((".ssh/known_hosts"
-               ,(file-join "known_hosts" known-hosts "\n"))))
-      (".ssh/config" ,config))))
-
-(define openssh-activation
-  (with-imported-modules (source-module-closure
-                          '((gnu build activation)))
-    #~(begin
-        (use-modules (gnu build activation))
-
-        ;; Make sure ~/.ssh is #o700.
-        (let* ((home (getenv "HOME"))
-               (dot-ssh (string-append home "/.ssh")))
-          (mkdir-p/perms dot-ssh (getpw (getuid)) #o700)))))
-
-(define home-openssh-service-type
-  (service-type
-   (name 'home-openssh)
-   (extensions
-    (list (service-extension home-files-service-type
-                             openssh-configuration-files)
-          (service-extension home-activation-service-type
-                             (const openssh-activation))))
-   (description "Configure the OpenSSH @acronym{SSH, secure shell} client
-by providing a @file{~/.ssh/config} file, which is honored by the OpenSSH
-client,@command{ssh}, and by other tools such as @command{guix deploy}.")
-   (default-value (home-openssh-configuration))))

gnu/home/services/symlink-manager.scm

@@ -54,10 +54,6 @@
            (or (getenv "XDG_CONFIG_HOME")
                (string-append (getenv "HOME") "/.config")))
 
-         (define xdg-data-home
-           (or (getenv "XDG_DATA_HOME")
-               (string-append (getenv "HOME") "/.local/share")))
-
          (define backup-directory
            (string-append home-directory "/" (number->string (current-time))
                           "-guix-home-legacy-configs-backup"))
@@ -65,30 +61,19 @@
          (define (preprocess-file file)
            "If file is in XDG-CONFIGURATION-FILES-DIRECTORY use
 subdirectory from XDG_CONFIG_HOME to generate a target path."
-           (cond
-            ((string-prefix? #$xdg-configuration-files-directory file)
-             (string-append
-              (substring xdg-config-home
-                         (1+ (string-length home-directory)))
-              (substring file
-                         (string-length #$xdg-configuration-files-directory))))
-            ((string-prefix? #$xdg-data-files-directory file)
-             (string-append
-              (substring xdg-data-home
-                         (1+ (string-length home-directory)))
-              (substring file
-                         (string-length #$xdg-data-files-directory))))
-            (else file)))
+           (if (string-prefix? #$xdg-configuration-files-directory file)
+               (string-append
+                (substring xdg-config-home
+                           (1+ (string-length home-directory)))
+                (substring file
+                           (string-length #$xdg-configuration-files-directory)))
+               (string-append "." file)))
 
          (define (target-file file)
            ;; Return the target of FILE, a config file name sans leading dot
            ;; such as "config/fontconfig/fonts.conf" or "bashrc".
            (string-append home-directory "/" (preprocess-file file)))
 
-         (define (no-follow-file-exists? file)
-           "Return #t if file exists, even if it's a dangling symlink."
-           (->bool (false-if-exception (lstat file))))
-
          (define (symlink-to-store? file)
            (catch 'system-error
              (lambda ()
@@ -127,7 +112,7 @@ subdirectory from XDG_CONFIG_HOME to generate a target path."
             (const #t)
             (lambda (file stat _)                 ;leaf
               (let ((file (target-file (strip file))))
-                (when (no-follow-file-exists? file)
+                (when (file-exists? file)
                   ;; DO NOT remove the file if it is no longer a symlink to
                   ;; the store, it will be backed up later during
                   ;; create-symlinks phase.
@@ -157,7 +142,6 @@ subdirectory from XDG_CONFIG_HOME to generate a target path."
                            #t
                            (G_ "Skipping ~a (not an empty directory)... done\n")
                            directory))
-                         ((= ENOENT errno) #t)
                          ((= ENOTDIR errno) #t)
                          (else
                           (apply throw args)))))))))
@@ -187,7 +171,7 @@ subdirectory from XDG_CONFIG_HOME to generate a target path."
             (lambda (file stat result)            ;leaf
               (let ((source (source-file (strip file)))
                     (target (target-file (strip file))))
-                (when (no-follow-file-exists? target)
+                (when (file-exists? target)
                   (backup-file (strip file)))
                 (format #t (G_ "Symlinking ~a -> ~a...")
                         target source)
@@ -196,7 +180,7 @@ subdirectory from XDG_CONFIG_HOME to generate a target path."
             (lambda (directory stat result)       ;down
               (unless (string=? directory config-file-directory)
                 (let ((target (target-file (strip directory))))
-                  (when (and (no-follow-file-exists? target)
+                  (when (and (file-exists? target)
                              (not (file-is-directory? target)))
                     (backup-file (strip directory)))
 

gnu/home/services/xdg.scm

@@ -23,7 +23,6 @@
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu home services utils)
   #:use-module (guix gexp)
-  #:use-module (guix modules)
   #:use-module (guix records)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
@@ -107,21 +106,15 @@ services more consistent."))
 
 (define (ensure-xdg-base-dirs-on-activation config)
   #~(map (lambda (xdg-base-dir-variable)
-           ((@ (guix build utils) mkdir-p)
+           ((@@ (guix build utils) mkdir-p)
             (getenv
              xdg-base-dir-variable)))
-         '#$(filter-map
-             (lambda (field)
-               (let ((variable
-                      (string-append
-                       "XDG_"
-                       (object->snake-case-string
-                        (configuration-field-name field) 'upper))))
-                 ;; XDG_RUNTIME_DIR shouldn't be created during activation
-                 ;; and will be provided by elogind or other service.
-                 (and (not (string=? "XDG_RUNTIME_DIR" variable))
-                      variable)))
-             home-xdg-base-directories-configuration-fields)))
+         '#$(map (lambda (field)
+                   (format
+                    #f "XDG_~a"
+                    (object->snake-case-string
+                     (configuration-field-name field) 'upper)))
+                 home-xdg-base-directories-configuration-fields)))
 
 (define (last-extension-or-cfg config extensions)
   "Picks configuration value from last provided extension.  If there
@@ -214,8 +207,8 @@ pre-populated content.")
                    home-xdg-user-directories-configuration-fields)))
     #~(let ((ensure-dir
              (lambda (path)
-               ((@ (guix build utils) mkdir-p)
-                ((@ (ice-9 string-fun) string-replace-substring)
+               (mkdir-p
+                ((@@ (ice-9 string-fun) string-replace-substring)
                  path "$HOME" (getenv "HOME"))))))
         (display "Creating XDG user directories...")
         (map ensure-dir '#$dirs)
@@ -383,25 +376,25 @@ configuration."
   (define (serialize-alist config)
     (generic-serialize-alist append format-config config))
 
-  (define (serialize-xdg-desktop-action desktop-action)
-    (match-record desktop-action <xdg-desktop-action>
-      (action name config)
-      `(,(format #f "[Desktop Action ~a]\n"
-                 (string-capitalize (maybe-object->string action)))
-        ,(format #f "Name=~a\n" name)
-        ,@(serialize-alist config))))
+  (define (serialize-xdg-desktop-action action)
+    (match action
+      (($ <xdg-desktop-action> action name config)
+       `(,(format #f "[Desktop Action ~a]\n"
+                  (string-capitalize (maybe-object->string action)))
+         ,(format #f "Name=~a\n" name)
+         ,@(serialize-alist config)))))
 
-  (match-record entry <xdg-desktop-entry>
-    (file name type config actions)
-    (list (if (string-suffix? file ".desktop")
-              file
-              (string-append file ".desktop"))
-          `("[Desktop Entry]\n"
-            ,(format #f "Name=~a\n" name)
-            ,(format #f "Type=~a\n"
-                     (string-capitalize (symbol->string type)))
-            ,@(serialize-alist config)
-            ,@(append-map serialize-xdg-desktop-action actions)))))
+  (match entry
+    (($ <xdg-desktop-entry> file name type config actions)
+     (list (if (string-suffix? file ".desktop")
+               file
+               (string-append file ".desktop"))
+           `("[Desktop Entry]\n"
+             ,(format #f "Name=~a\n" name)
+             ,(format #f "Type=~a\n"
+                      (string-capitalize (symbol->string type)))
+             ,@(serialize-alist config)
+             ,@(append-map serialize-xdg-desktop-action actions))))))
 
 (define-configuration home-xdg-mime-applications-configuration
   (added
@@ -428,8 +421,7 @@ that the application cannot open the specified MIME type.")
   (define (add-xdg-desktop-entry-file entry)
     (let ((file (first entry))
           (config (second entry)))
-      ;; TODO: Use xdg-data-files instead of home-files here
-      (list (format #f "applications/~a" file)
+      (list (format #f "local/share/applications/~a" file)
           (apply mixed-text-file
                  (format #f "xdg-desktop-~a-entry" file)
                  config))))
@@ -476,7 +468,7 @@ that the application cannot open the specified MIME type.")
   (service-type (name 'home-xdg-mime-applications)
                 (extensions
                  (list (service-extension
-                        home-xdg-data-files-service-type
+                        home-files-service-type
                         home-xdg-mime-applications-files)
                        (service-extension
                         home-xdg-configuration-files-service-type

gnu/image.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,13 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu image)
-  #:use-module (guix platform)
+  #:use-module (gnu platform)
   #:use-module (guix records)
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:export (partition
             partition?
             partition-device
@@ -59,155 +54,61 @@
             os->image
             os+platform->image))
 
-
-;;;
-;;; Sanitizers.
-;;;
-
-;; Image and partition sizes can be either be a size in bytes or the 'guess
-;; symbol denoting that the size should be estimated by Guix, according to the
-;; image content.
-(define-with-syntax-properties (validate-size (value properties))
-  (unless (and value
-               (or (eq? value 'guess) (integer? value)))
-    (raise
-       (make-compound-condition
-        (condition
-         (&error-location
-          (location (source-properties->location properties))))
-        (formatted-message
-         (G_ "size (~a) can only be 'guess or a numeric expression ~%")
-         value 'field))))
-  value)
-
 
 ;;;
 ;;; Partition record.
 ;;;
 
-;; The partition offset should be a bytes count as an integer.
-(define-with-syntax-properties (validate-partition-offset (value properties))
-  (unless (and value (integer? value))
-    (raise
-       (make-compound-condition
-        (condition
-         (&error-location
-          (location (source-properties->location properties))))
-        (formatted-message
-         (G_ "the partition offset (~a) can only be a \
-numeric expression ~%") value 'field))))
-  value)
-
-;; The supported partition flags.
-(define-with-syntax-properties (validate-partition-flags (value properties))
-  (let ((bad-flags (lset-difference eq? value '(boot esp))))
-    (unless (and (list? value) (null? bad-flags))
-      (raise
-       (make-compound-condition
-        (condition
-         (&error-location
-          (location (source-properties->location properties))))
-        (formatted-message
-         (G_ "unsupported partition flag(s): ~a ~%") bad-flags)))))
-  value)
-
 (define-record-type* <partition> partition make-partition
   partition?
-  (size                 partition-size   ;size in bytes as integer or 'guess
-                        (default 'guess)
-                        (sanitize validate-size))
-  (offset               partition-offset
-                        (default 0)   ;offset in bytes as integer
-                        (sanitize validate-partition-offset))
-  (file-system          partition-file-system
-                        (default "ext4"))  ;string
+  (device               partition-device (default #f))
+  (size                 partition-size)
+  (offset               partition-offset (default 0))
+  (file-system          partition-file-system (default "ext4"))
   (file-system-options  partition-file-system-options
-                        (default '()))  ;list of strings
-  (label                partition-label)  ;string
-  (uuid                 partition-uuid
-                        (default #false))  ;<uuid>
-  (flags                partition-flags
-                        (default '())  ;list of symbols
-                        (sanitize validate-partition-flags))
-  (initializer          partition-initializer
-                        (default #false))) ;gexp | #false
+                        (default '()))
+  (label                partition-label (default #f))
+  (uuid                 partition-uuid (default #f))
+  (flags                partition-flags (default '()))
+  (initializer          partition-initializer (default #f)))
 
 
 ;;;
 ;;; Image record.
 ;;;
 
-(define-syntax-rule (define-set-sanitizer name field set)
-  "Define NAME as a procedure or macro that raises an error if passed a value
-that is not in SET, mentioning FIELD in the error message."
-  (define-with-syntax-properties (name (value properties))
-    (unless (memq value 'set)
-      (raise
-       (make-compound-condition
-        (condition
-         (&error-location
-          (location (source-properties->location properties))))
-        (formatted-message (G_ "~s: invalid '~a' value") value 'field))))
-    value))
-
-;; The supported image formats.
-(define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
-
-;; The supported partition table types.
-(define-set-sanitizer validate-partition-table-type partition-table-type
-  (mbr gpt))
-
 (define-record-type* <image>
   image make-image
   image?
   (name               image-name ;symbol
-                      (default #false))
-  (format             image-format                ;symbol
-                      (sanitize validate-image-format))
+                      (default #f))
+  (format             image-format) ;symbol
   (platform           image-platform ;<platform>
-                      (default #false))
+                      (default #f))
   (size               image-size  ;size in bytes as integer
-                      (default 'guess)
-                      (sanitize validate-size))
-  (operating-system   image-operating-system)  ;<operating-system>
+                      (default 'guess))
+  (operating-system   image-operating-system  ;<operating-system>
+                      (default #f))
   (partition-table-type image-partition-table-type ; 'mbr or 'gpt
-                      (default 'mbr)
-                      (sanitize validate-partition-table-type))
+                      (default 'mbr))
   (partitions         image-partitions ;list of <partition>
                       (default '()))
   (compression?       image-compression? ;boolean
-                      (default #true))
+                      (default #t))
   (volatile-root?     image-volatile-root? ;boolean
-                      (default #true))
+                      (default #t))
   (shared-store?      image-shared-store? ;boolean
-                      (default #false))
+                      (default #f))
   (shared-network?    image-shared-network? ;boolean
-                      (default #false))
+                      (default #f))
   (substitutable?     image-substitutable? ;boolean
-                      (default #true)))
+                      (default #t)))
 
 
 ;;;
 ;;; Image type.
 ;;;
 
-;; The role of this record is to provide a constructor that is able to turn an
-;; <operating-system> record into an <image> record.  Some basic <image-type>
-;; records are defined in the (gnu system image) module.  They are able to
-;; turn an <operating-system> record into an EFI or an ISO 9660 bootable
-;; image, a Docker image or even a QCOW2 image.
-;;
-;; Other <image-type> records are defined in the (gnu system images ...)
-;; modules.  They are dedicated to specific machines such as Novena and Pine64
-;; SoC boards that require specific images.
-;;
-;; All the available <image-type> records are collected by the 'image-modules'
-;; procedure.  This allows the "guix system image" command to turn a given
-;; <operating-system> record into an image, thanks to the specified
-;; <image-type>.  In that case, the <image-type> look up is done using the
-;; name field of the <image-type> record.
-
 (define-record-type* <image-type>
   image-type make-image-type
   image-type?
@@ -220,15 +121,10 @@ that is not in SET, mentioning FIELD in the error message."
 ;;;
 
 (define* (os->image os #:key type)
-  "Use the image constructor from TYPE, an <image-type> record to turn the
-given OS, an <operating-system> record into an image and return it."
   (let ((constructor (image-type-constructor type)))
     (constructor os)))
 
 (define* (os+platform->image os platform #:key type)
-  "Use the image constructor from TYPE, an <image-type> record to turn the
-given OS, an <operating-system> record into an image targeting PLATFORM, a
-<platform> record and return it."
   (image
    (inherit (os->image os #:type type))
    (platform platform)))

gnu/installer.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;;
@@ -27,8 +27,6 @@
   #:use-module (guix utils)
   #:use-module (guix ui)
   #:use-module ((guix self) #:select (make-config.scm))
-  #:use-module (guix describe)
-  #:use-module (guix channels)
   #:use-module (guix packages)
   #:use-module (guix git-download)
   #:use-module (gnu installer utils)
@@ -48,13 +46,11 @@
   #:use-module (gnu packages nano)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages package-management)
-  #:use-module (gnu packages pciutils)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages xorg)
   #:use-module (gnu system locale)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:use-module (web uri)
   #:export (installer-program))
 
 (define module-to-import?
@@ -67,7 +63,6 @@
     (('gnu 'installer _ ...) #t)
     (('gnu 'build _ ...) #t)
     (('guix 'build _ ...) #t)
-    (('guix 'read-print) #t)
     (_ #f)))
 
 (define not-config?
@@ -230,9 +225,7 @@ selected keymap."
           (id 'welcome)
           (compute (lambda _
                      ((installer-welcome-page current-installer)
-                      #$(local-file "installer/aux-files/logo.txt")
-                      #:pci-database
-                      #$(file-append pciutils "/share/hwdata/pci.ids.gz")))))
+                      #$(local-file "installer/aux-files/logo.txt")))))
 
          ;; Ask the user to select a timezone under glibc format.
          (installer-step
@@ -318,25 +311,6 @@ selected keymap."
              ((installer-final-page current-installer)
               result prev-steps))))))))
 
-(define (provenance-sexp)
-  "Return an sexp representing the currently-used channels, for logging
-purposes."
-  (match (match (current-channels)
-           (() (and=> (repository->guix-channel (dirname (current-filename)))
-                      list))
-           (channels channels))
-    (#f
-     (warning (G_ "cannot determine installer provenance~%"))
-     '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))))
-          channels))))
-
 (define (installer-program)
   "Return a file-like object that runs the given INSTALLER."
   (define init-gettext
@@ -383,9 +357,7 @@ purposes."
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
                            guile-json-3 guile-git guile-webutils
-                           guile-gnutls
-                           guile-zlib           ;for (gnu build linux-modules)
-                           (current-guix))
+                           guix gnutls)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
@@ -416,12 +388,6 @@ purposes."
                          (ice-9 match)
                          (ice-9 textual-ports))
 
-            ;; Enable core dump generation.
-            (setrlimit 'core #f #f)
-            (call-with-output-file "/proc/sys/kernel/core_pattern"
-              (lambda (port)
-                (format port %core-dump)))
-
             ;; Initialize gettext support so that installers can use
             ;; (guix i18n) module.
             #$init-gettext
@@ -451,9 +417,6 @@ purposes."
             (define current-installer newt-installer)
             (define steps (#$steps current-installer))
 
-            (installer-log-line "installer provenance: ~s"
-                                '#$(provenance-sexp))
-
             (dynamic-wind
               (installer-init current-installer)
               (lambda ()
@@ -483,21 +446,11 @@ purposes."
                                           key args)
                       (define dump-dir
                         (prepare-dump key args #:result %current-result))
-
-                      (define user-abort?
-                        (match args
-                          (((? user-abort-error? obj)) #t)
-                          (_ #f)))
-
                       (define action
-                        (if user-abort?
-                            'dump
-                            ((installer-exit-error current-installer)
-                             (get-string-all
-                              (open-input-file
-                               (string-append dump-dir
-                                              "/installer-backtrace"))))))
-
+                        ((installer-exit-error current-installer)
+                         (get-string-all
+                          (open-input-file
+                           (string-append dump-dir "/installer-backtrace")))))
                       (match action
                         ('dump
                          (let* ((dump-files

gnu/installer/dump.scm

@@ -28,17 +28,13 @@
   #:use-module (web http)
   #:use-module (web response)
   #:use-module (webutils multipart)
-  #:export (%core-dump
-            prepare-dump
+  #:export (prepare-dump
             make-dump
             send-dump-report))
 
 ;; The installer crash dump type.
 (define %dump-type "installer-dump")
 
-;; The core dump file.
-(define %core-dump "/tmp/installer-core-dump")
-
 (define (result->list result)
   "Return the alist for the given RESULT."
   (hash-map->list (lambda (k v)
@@ -70,10 +66,6 @@ RESULT is the installer result hash table.  Returns the created directory path."
     ;; syslog
     (copy-file "/var/log/messages" "syslog")
 
-    ;; core dump
-    (when (file-exists? %core-dump)
-      (copy-file %core-dump "core-dump"))
-
     ;; dmesg
     (let ((pipe (open-pipe* OPEN_READ "dmesg")))
       (call-with-output-file "dmesg"

gnu/installer/final.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -114,8 +114,6 @@ it can interact with the rest of the system."
     ;; Catch SIGINT and kill the container process.
     (sigaction SIGINT
       (lambda (signum)
-        ;: FIXME: Use of SIGKILL prevents the dynamic-wind exit handler of
-        ;; THUNK to run.
         (false-if-exception
          (kill pid SIGKILL))))
 
@@ -198,16 +196,14 @@ or #f.  Return #t on success and #f on failure."
              ;; the loaded cow-store locale files will prevent umounting.
              (install-locale locale)
 
-             ;; Stop the daemon and save the database, so that it can be
-             ;; restored once the cow-store is umounted.
-             (stop-service 'guix-daemon)
+             ;; Save the database, so that it can be restored once the
+             ;; cow-store is umounted.
              (copy-file database-file saved-database)
-
-             (installer-log-line "mounting copy-on-write store")
              (mount-cow-store (%installer-target-dir) backing-directory))
            (lambda ()
              ;; We need to drag the guix-daemon to the container MNT
              ;; namespace, so that it can operate on the cow-store.
+             (stop-service 'guix-daemon)
              (start-service 'guix-daemon (list (number->string (getpid))))
 
              (setvbuf (current-output-port) 'none)
@@ -215,27 +211,13 @@ or #f.  Return #t on success and #f on failure."
 
              (setenv "PATH" "/run/current-system/profile/bin/")
 
-             (set! ret (run-command install-command #:tty? #t)))
+             (set! ret (run-command install-command)))
            (lambda ()
-             ;; Stop guix-daemon so that it does no keep the MNT namespace
+             ;; Restart guix-daemon so that it does no keep the MNT namespace
              ;; alive.
-             (stop-service 'guix-daemon)
-
-             ;; Restore the database and restart it.  As part of restoring the
-             ;; database, remove the WAL and shm files in case they were left
-             ;; behind after guix-daemon was stopped.  Failing to do so,
-             ;; sqlite might behave as if transactions that appear in the WAL
-             ;; file were committed.  (See <https://www.sqlite.org/wal.html>.)
-             (installer-log-line "restoring store database from '~a'"
-                                 saved-database)
+             (restart-service 'guix-daemon)
              (copy-file saved-database database-file)
-             (for-each (lambda (suffix)
-                         (false-if-exception
-                          (delete-file (string-append database-file suffix))))
-                       '("-wal" "-shm"))
-             (start-service 'guix-daemon)
 
              ;; Finally umount the cow-store and exit the container.
-             (installer-log-line "unmounting copy-on-write store")
              (unmount-cow-store (%installer-target-dir) backing-directory)
              (assert-exit ret))))))))

gnu/installer/hardware.scm

@@ -1,90 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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
-;;;
-;;; 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 (gnu installer hardware)
-  #:use-module (gnu build linux-modules)
-  #:use-module (guix i18n)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-71)
-  #:export (unsupported-pci-device?
-            pci-device-description))
-
-(define %unsupported-linux-modules
-  ;; List of Linux modules that are useless without non-free firmware.
-  ;;
-  ;; Currently only drivers for PCI devices are listed.  USB devices such as
-  ;; "btintel" would require support to list USB devices and read the USB
-  ;; device ID database.  Punt for now as this is usually less critical.
-  ;;
-  ;; This list is currently manually maintained based on information on
-  ;; non-free firmware available from
-  ;; <https://packages.debian.org/search?keywords=firmware&searchon=names&suite=stable&section=all>.
-  '(;; WiFi.
-    "brcmfmac"
-    "ipw2100"
-    "ipw2200"
-    "iwlwifi"
-    "mwl8k"
-    "rtl8188ee"
-    "rtl818x_pci"
-    "rtl8192ce"
-    "rtl8192de"
-    "rtl8192ee"
-
-    ;; Ethernet.
-    "bnx2"
-    "bnx2x"
-    "liquidio"
-
-    ;; Graphics.
-    "amdgpu"
-    "radeon"
-
-    ;; Multimedia.
-    "ivtv"))
-
-(define unsupported-pci-device?
-  ;; Arrange to load the module alias database only once.
-  (let ((aliases (delay (known-module-aliases))))
-    (lambda (device)
-      "Return true if DEVICE is known to not be supported by free software."
-      (any (lambda (module)
-             (member module %unsupported-linux-modules))
-           (matching-modules (pci-device-module-alias device)
-                             (force aliases))))))
-
-(define (pci-device-description pci-database)
-  "Return a procedure that, given a PCI device, returns a string describing
-it."
-  (define (with-fallback lookup)
-    (lambda (vendor-id id)
-      (let ((vendor name (lookup vendor-id id)))
-        (values (or vendor (number->string vendor-id 16))
-                (or name (number->string id 16))))))
-
-  (define pci-lookup
-    (with-fallback (load-pci-device-database pci-database)))
-
-  (lambda (device)
-    (let ((vendor name (pci-lookup (pci-device-vendor device)
-                                   (pci-device-id device))))
-      (if (network-pci-device? device)
-          ;; TRANSLATORS: The two placeholders are the manufacturer
-          ;; and name of a PCI device.
-          (format #f (G_ "~a ~a (networking device)")
-                  vendor name)
-          (string-append vendor " " name)))))

gnu/installer/newt.scm

@@ -62,9 +62,6 @@
   (clear-screen))
 
 (define (exit-error error)
-  ;; Newt may be suspended in the context of the "install-system"
-  ;; procedure. Resume it unconditionnally.
-  (newt-resume)
   (newt-set-color COLORSET-ROOT "white" "red")
   (define action
     (run-textbox-page
@@ -116,7 +113,11 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address)
   (define command-output "")
   (define (line-accumulator line)
     (set! command-output
-          (string-append/shared command-output line)))
+          (string-append/shared command-output line "\n")))
+  (define displayed-command
+    (string-join
+     (map (lambda (s) (string-append "\"" s "\"")) args)
+     " "))
   (define result (run-external-command-with-line-hooks (list line-accumulator)
                                                        args))
   (define exit-val (status:exit-val result))
@@ -172,8 +173,8 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address)
 (define (timezone-page zonetab)
   (run-timezone-page zonetab))
 
-(define* (welcome-page logo #:key pci-database)
-  (run-welcome-page logo #:pci-database pci-database))
+(define (welcome-page logo)
+  (run-welcome-page logo))
 
 (define (menu-page steps)
   (run-menu-page steps))

gnu/installer/newt/final.scm

@@ -80,20 +80,16 @@ press the button to reboot.")))
 (define (run-install-failed-page)
   (match (current-clients)
     (()
-     (match (ternary-window
+     (match (choice-window
              (G_ "Installation failed")
              (G_ "Resume")
              (G_ "Restart the installer")
-             (G_ "Report the failure")
              (G_ "The final system installation step failed.  You can resume from \
 a specific step, or restart the installer."))
        (1 (abort-to-prompt 'installer-step 'abort))
        (2
         ;; Keep going, the installer will be restarted later on.
-        #t)
-       (3 (raise
-            (condition
-             (&user-abort-error))))))
+        #t)))
     (_
      (send-to-clients '(installation-failure))
      #t)))

gnu/installer/newt/network.scm

@@ -115,11 +115,6 @@ network devices were found. Do you want to continue anyway?"))
 (define (wait-service-online)
   "Display a newt scale until connman detects an Internet access. Do
 FULL-VALUE tentatives, spaced by 1 second."
-  (define (url-alive? url)
-    (false-if-exception
-     (= (response-code (http-request url))
-        200)))
-
   (define (ci-available?)
     (dynamic-wind
       (lambda ()
@@ -127,8 +122,10 @@ FULL-VALUE tentatives, spaced by 1 second."
           (lambda _ #f))
         (alarm 3))
       (lambda ()
-        (or (url-alive? "https://ci.guix.gnu.org")
-            (url-alive? "https://bordeaux.guix.gnu.org")))
+        (false-if-exception
+         (= (response-code
+             (http-request "https://ci.guix.gnu.org"))
+            200)))
       (lambda ()
         (alarm 0))))
 

gnu/installer/newt/page.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -278,12 +278,12 @@ input box, such as FLAG-PASSWORD."
                    (destroy-form-and-pop form)
                    input))))))))
 
-(define* (run-error-page text title #:key (width 40))
-  "Run a page to inform the user of an error.  The page is WIDTH column wide
-and contains the given TEXT to explain the error and an \"OK\" button to
-acknowledge the error.  The title of the page is set to TITLE."
+(define (run-error-page text title)
+  "Run a page to inform the user of an error. The page contains the given TEXT
+to explain the error and an \"OK\" button to acknowledge the error. The title
+of the page is set to TITLE."
   (let* ((text-box
-          (make-reflowed-textbox -1 -1 text width
+          (make-reflowed-textbox -1 -1 text 40
                                  #:flags FLAG-BORDER))
          (grid (make-grid 1 2))
          (ok-button (make-button -1 -1 "OK"))

gnu/installer/newt/partition.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2022 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
@@ -92,31 +92,17 @@ disk.  The installation device as well as the small devices are filtered.")
          (device (car result)))
     device))
 
-(define (run-label-confirmation-page callback)
-  (lambda (item)
-    (match (current-clients)
-      (()
-       (and (run-confirmation-page
-             (format #f (G_ "This will create a new ~a partition table, \
-all data on disk will be lost, are you sure you want to proceed?") item)
-             (G_ "Format disk?")
-             #:exit-button-procedure callback)
-            item))
-      (_ item))))
-
 (define (run-label-page button-text button-callback)
   "Run a page asking the user to select a partition table label."
   ;; Force the GPT label if UEFI is supported.
   (if (efi-installation?)
-      ((run-label-confirmation-page button-callback) "gpt")
+      "gpt"
       (run-listbox-selection-page
        #:info-text (G_ "Select a new partition table type. \
 Be careful, all data on the disk will be lost.")
        #:title (G_ "Partition table")
        #:listbox-items '("msdos" "gpt")
        #:listbox-item->text identity
-       #:listbox-callback-procedure
-       (run-label-confirmation-page button-callback)
        #:button-text button-text
        #:button-callback-procedure button-callback)))
 
@@ -202,7 +188,7 @@ encryption of partition ~a (label: ~a).") file-name crypt-label)
                    (if (string=? password confirmation)
                        (user-partition
                         (inherit user-part)
-                        (crypt-password (make-secret password)))
+                        (crypt-password password))
                        (begin
                          (run-error-page
                           (G_ "Password mismatch, please try again.")
@@ -809,13 +795,13 @@ by pressing the Exit button.~%~%")))
          (user-partitions (run-page eligible-devices))
          (user-partitions-with-pass (prompt-luks-passwords
                                      user-partitions))
-         (form (draw-formatting-page user-partitions-with-pass)))
+         (form (draw-formatting-page user-partitions)))
     ;; Make sure the disks are not in use before proceeding to formatting.
     (free-parted eligible-devices)
     (format-user-partitions user-partitions-with-pass)
     (installer-log-line "formatted ~a user partitions"
             (length user-partitions-with-pass))
-    (installer-log-line "user-partitions: ~a" user-partitions-with-pass)
+    (installer-log-line "user-partitions: ~a" user-partitions)
 
     (destroy-form-and-pop form)
-    user-partitions-with-pass))
+    user-partitions))

gnu/installer/newt/services.scm

@@ -99,8 +99,10 @@ non-graphical system.")
       #:item->text (compose G_ system-service-name)
       #:checkbox-tree-height 5
       #:exit-button-callback-procedure
-      (lambda _
-        (abort-to-prompt 'installer-step 'abort)))))
+      (lambda ()
+        (raise
+          (condition
+            (&installer-step-abort)))))))
 
 (define (run-network-management-page)
   "Run a page to select among several network management methods."

gnu/installer/newt/substitutes.scm

@@ -28,7 +28,7 @@
   (match (current-clients)
     (()
      (case (choice-window
-            (G_ "Substitute server discovery")
+            (G_ "Substitute server discovery.")
             (G_ "Enable") (G_ "Disable")
             (G_ " By turning this option on, you allow Guix to fetch \
 substitutes (pre-built binaries) during installation from servers \

gnu/installer/newt/user.scm

@@ -40,9 +40,6 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
   (define (pad-label label)
     (string-pad-right label 25))
 
-  (define (root-account? name)
-    (string=? name "root"))
-
   (let* ((label-name
           (make-label -1 -1 (pad-label (G_ "Name"))))
          (label-real-name
@@ -119,14 +116,10 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
                                GRID-ELEMENT-SUBGRID button-grid)
                               title)
 
-    (let ((error-empty-field-page
+    (let ((error-page
            (lambda ()
              (run-error-page (G_ "Empty inputs are not allowed.")
-                             (G_ "Empty input"))))
-          (error-root-page
-           (lambda ()
-             (run-error-page (G_ "Root account is automatically created.")
-                             (G_ "Root account")))))
+                             (G_ "Empty input")))))
       (receive (exit-reason argument)
           (run-form form)
         (dynamic-wind
@@ -139,28 +132,22 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
                       (real-name      (entry-value entry-real-name))
                       (home-directory (entry-value entry-home-directory))
                       (password       (entry-value entry-password)))
-                  (cond
-                   ;; Empty field.
-                   ((or (string=? name "")
-                        (string=? home-directory ""))
-                    (error-empty-field-page)
-                    (run-user-add-page))
-                   ;; Reject root account.
-                   ((root-account? name)
-                    (error-root-page)
-                    (run-user-add-page))
-                   (else
-                    (let ((password (confirm-password password)))
-                      (if password
-                          (user
-                           (name name)
-                           (real-name real-name)
-                           (home-directory home-directory)
-                           (password (make-secret password)))
-                          (run-user-add-page #:name name
-                                             #:real-name real-name
-                                             #:home-directory
-                                             home-directory))))))))))
+                  (if (or (string=? name "")
+                          (string=? home-directory ""))
+                      (begin
+                        (error-page)
+                        (run-user-add-page))
+                      (let ((password (confirm-password password)))
+                        (if password
+                            (user
+                             (name name)
+                             (real-name real-name)
+                             (home-directory home-directory)
+                             (password (make-secret password)))
+                            (run-user-add-page #:name name
+                                               #:real-name real-name
+                                               #:home-directory
+                                               home-directory)))))))))
           (lambda ()
             (destroy-form-and-pop form)))))))
 

gnu/installer/newt/welcome.scm

@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2020, 2022 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2022 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,11 +17,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu installer newt welcome)
-  #:use-module ((gnu build linux-modules)
-                #:select (modules-loaded
-                          pci-devices))
-  #:use-module (gnu installer dump)
-  #:use-module (gnu installer hardware)
   #:use-module (gnu installer steps)
   #:use-module (gnu installer utils)
   #:use-module (gnu installer newt page)
@@ -32,8 +26,6 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:use-module (srfi srfi-71)
-  #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 receive)
   #:use-module (newt)
@@ -125,52 +117,10 @@ we want this page to occupy all the screen space available."
         (lambda ()
           (destroy-form-and-pop form))))))
 
-(define (check-hardware-support pci-database)
-  "Warn about unsupported devices."
-  (when (member "uvesafb" (modules-loaded))
-    (run-error-page (G_ "\
-This may be a false alarm, but possibly your graphics hardware does not
-work well with only free software.  Expect trouble.  If after installation,
-the system does not boot, perhaps you will need to add nomodeset to the
-kernel arguments and need to configure the uvesafb kernel module.")
-                    (G_ "Pre-install warning")))
-
-  (let ((devices (pci-devices)))
-    (match (filter unsupported-pci-device? devices)
-      (()                                         ;no unsupported device
-       #t)
-      (unsupported
-       (run-error-page (format #f (G_ "\
-Devices not supported by free software were found on your computer:
-
-~{  - ~a~%~}
-Unfortunately, it means those devices will not be usable.
-
-To address it, we recommend choosing hardware that respects your freedom as a \
-user--hardware for which free drivers and firmware exist.  See \"Hardware \
-Considerations\" in the manual for more information.")
-                               (map (pci-device-description pci-database)
-                                    unsupported))
-                       (G_ "Hardware support warning")
-                       #:width 76)))))
-
-(define* (run-welcome-page logo #:key pci-database)
+(define (run-welcome-page logo)
   "Run a welcome page with the given textual LOGO displayed at the center of
 the page. Ask the user to choose between manual installation, graphical
 installation and reboot."
-  (when (file-exists? %core-dump)
-    (match (choice-window
-            (G_ "Previous installation failed")
-            (G_ "Continue")
-            (G_ "Report the failure")
-            (G_ "It seems that the previous installation exited unexpectedly \
-and generated a core dump.  Do you want to continue or to report the failure \
-first?"))
-      (1 #t)
-      (2 (raise
-          (condition
-           (&user-abort-error))))))
-
   (run-menu-page
    (G_ "GNU Guix install")
    (G_ "Welcome to GNU Guix system installer!
@@ -184,16 +134,14 @@ Documentation is accessible at any time by pressing Ctrl-Alt-F2.")
    #:listbox-items
    `((,(G_ "Graphical install using a terminal based interface")
       .
-      ,(lambda ()
-         (check-hardware-support pci-database)))
+      ,(const #t))
      (,(G_ "Install using the shell based process")
       .
       ,(lambda ()
-         (check-hardware-support pci-database)
          ;; Switch to TTY3, where a root shell is available for shell based
          ;; install. The other root TTY's would have been ok too.
          (system* "chvt" "3")
-         (run-welcome-page logo #:pci-database pci-database)))
+         (run-welcome-page logo)))
      (,(G_ "Reboot")
       .
       ,(lambda ()

gnu/installer/parted.scm

@@ -1,8 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,7 +38,6 @@
                 #:select (%base-initrd-modules))
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
-  #:use-module (guix read-print)
   #:use-module (guix records)
   #:use-module (guix utils)
   #:use-module (guix i18n)
@@ -81,6 +79,7 @@
             efi-installation?
             default-esp-mount-point
 
+            with-delay-device-in-use?
             force-device-sync
             eligible-devices
             partition-user-type
@@ -148,7 +147,7 @@
                         (default #f))
   (crypt-label          user-partition-crypt-label
                         (default #f))
-  (crypt-password       user-partition-crypt-password ; <secret>
+  (crypt-password       user-partition-crypt-password
                         (default #f))
   (fs-type              user-partition-fs-type
                         (default 'ext4))
@@ -319,25 +318,6 @@ PARTED-OBJECT field equals PARTITION, return #f if not found."
                   partition))
         user-partitions))
 
-(define (read-partition-uuid/retry file-name)
-  "Call READ-PARTITION-UUID with 5 retries spaced by 1 second.  This is useful
-if the partition table is updated by the kernel at the time this function is
-called, causing the underlying /dev to be absent."
-  (define max-retries 5)
-
-  (let loop ((retry max-retries))
-    (catch #t
-      (lambda ()
-        (read-partition-uuid file-name))
-      (lambda _
-        (if (> retry 0)
-            (begin
-              (sleep 1)
-              (loop (- retry 1)))
-            (error
-             (format #f (G_ "Could not open ~a after ~a retries~%.")
-                     file-name max-retries)))))))
-
 
 ;;
 ;; Devices
@@ -379,44 +359,12 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation."
 (define %min-device-size
   (* 2 GIBIBYTE-SIZE)) ;2GiB
 
-(define (mapped-device? device)
-  "Return #true if DEVICE is a mapped device, false otherwise."
-  (string-prefix? "/dev/dm-" device))
-
-;; TODO: Use DM_TABLE_DEPS ioctl instead of dmsetup.
-(define (mapped-device-parent-partition device)
-  "Return the parent partition path of the mapped DEVICE."
-  (let* ((command `("dmsetup" "deps" ,device "-o" "devname"))
-         (parent #f)
-         (handler
-          (lambda (input)
-            ;; We are parsing an output that should look like:
-            ;; 1 dependencies  : (sda2)
-            (let ((result
-                   (string-match "\\(([^\\)]+)\\)"
-                                 (get-string-all input))))
-              (and result
-                   (set! parent
-                         (format #f "/dev/~a"
-                                 (match:substring result 1))))))))
-    (run-external-command-with-handler handler command)
-    parent))
-
 (define (eligible-devices)
   "Return all the available devices except the install device and the devices
 which are smaller than %MIN-DEVICE-SIZE."
 
   (define the-installer-root-partition-path
-    (let ((root (installer-root-partition-path)))
-      (cond
-       ((mapped-device? root)
-        ;; If the partition is a mapped device (/dev/dm-X), locate the parent
-        ;; partition.  It is the case when Ventoy is used to host the
-        ;; installation image.
-        (let ((parent (mapped-device-parent-partition root)))
-          (installer-log-line "mapped device ~a -> ~a" parent root)
-          parent))
-       (else root))))
+    (installer-root-partition-path))
 
   (define (small-device? device)
     (let ((length (device-length device))
@@ -880,7 +828,6 @@ cause them to cross."
          (installer-log-line "~/type: ~a" partition-type)
          (installer-log-line "~/filesystem-type: ~a"
                              (filesystem-type-name filesystem-type))
-         (installer-log-line "~/flags: ~a" flags)
          (installer-log-line "~/start: ~a" start-sector*)
          (installer-log-line "~/end: ~a" end-sector)
          (installer-log-line "~/start-range: [~a, ~a]"
@@ -897,18 +844,15 @@ cause them to cross."
          (when (and partition-ok? has-name? name)
            (partition-set-name partition name))
 
-         ;; Both partition-set-system and partition-set-flag calls can affect
-         ;; the partition type.  Their order is important, see:
-         ;; https://issues.guix.gnu.org/55549.
-         (partition-set-system partition filesystem-type)
-
-         ;; Set flags if required.
+         ;; Set flags is required.
          (for-each (lambda (flag)
                      (and (partition-is-flag-available? partition flag)
                           (partition-set-flag partition flag 1)))
                    flags)
 
-         (and partition-ok? partition))))))
+         (and partition-ok?
+              (partition-set-system partition filesystem-type)
+              partition))))))
 
 
 ;;
@@ -1035,11 +979,6 @@ exists."
     (for-each
      (lambda (partition)
        (and (data-partition? partition)
-            ;; Do not remove logical partitions ourselves, since
-            ;; disk-remove-partition* will remove all the logical partitions
-            ;; residing on an extended partition, which would lead to a
-            ;; double-remove and ensuing SEGFAULT.
-            (not (logical-partition? partition))
             (disk-remove-partition* disk partition)))
      non-boot-partitions)
 
@@ -1159,7 +1098,7 @@ Return #t if all the statements are valid."
                (need-formatting?
                 (user-partition-need-formatting? user-partition)))
            (or need-formatting?
-               (read-partition-uuid/retry file-name)
+               (read-partition-uuid file-name)
                (raise
                 (condition
                  (&cannot-read-uuid
@@ -1234,7 +1173,7 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise."
   "Format and open the encrypted partition pointed by USER-PARTITION."
   (let* ((file-name (user-partition-file-name user-partition))
          (label (user-partition-crypt-label user-partition))
-         (password (secret-content (user-partition-crypt-password user-partition))))
+         (password (user-partition-crypt-password user-partition)))
     (call-with-luks-key-file
      password
      (lambda (key-file)
@@ -1245,20 +1184,6 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise."
        ((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
         "--key-file" key-file file-name label)))))
 
-(define (luks-ensure-open user-partition)
-  "Ensure partition pointed by USER-PARTITION is opened."
-  (unless (file-exists? (user-partition-upper-file-name user-partition))
-    (let* ((file-name (user-partition-file-name user-partition))
-           (label (user-partition-crypt-label user-partition))
-           (password (secret-content (user-partition-crypt-password user-partition))))
-      (call-with-luks-key-file
-       password
-       (lambda (key-file)
-         (installer-log-line "opening LUKS entry ~s at ~s"
-                             label file-name)
-         ((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
-          "--key-file" key-file file-name label))))))
-
 (define (luks-close user-partition)
   "Close the encrypted partition pointed by USER-PARTITION."
   (let ((label (user-partition-crypt-label user-partition)))
@@ -1343,8 +1268,6 @@ respective mount-points."
                         (user-fs-type->mount-type fs-type))
                        (file-name
                         (user-partition-upper-file-name user-partition)))
-                  (when crypt-label
-                    (luks-ensure-open user-partition))
                   (mkdir-p target)
                   (installer-log-line "mounting ~s on ~s" file-name target)
                   (mount file-name target mount-type)))
@@ -1516,13 +1439,6 @@ USER-PARTITIONS, or return nothing."
             `((mapped-devices
                (list ,@(map user-partition->mapped-device
                             encrypted-partitions)))))
-
-      ,(vertical-space 1)
-      ,(let-syntax ((G_ (syntax-rules () ((_ str) str))))
-         (comment (G_ "\
-;; The list of file systems that get \"mounted\".  The unique
-;; file system identifiers there (\"UUIDs\") can be obtained
-;; by running 'blkid' in a terminal.\n")))
       (file-systems (cons*
                      ,@(user-partitions->file-systems user-partitions)
                      %base-file-systems)))))

gnu/installer/record.scm

@@ -89,7 +89,7 @@
   (partition-page installer-partition-page)
   ;; procedure void -> void
   (services-page installer-services-page)
-  ;; procedure (logo #:pci-database) -> void
+  ;; procedure (logo) -> void
   (welcome-page installer-welcome-page)
   ;; procedure (menu-proc) -> void
   (parameters-menu installer-parameters-menu)

gnu/installer/services.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
@@ -22,7 +22,6 @@
 
 (define-module (gnu installer services)
   #:use-module (guix records)
-  #:use-module (guix read-print)
   #:use-module (srfi srfi-1)
   #:export (system-service?
             system-service-name
@@ -36,11 +35,6 @@
             %system-services
             system-services->configuration))
 
-(define-syntax-rule (G_ str)
-  ;; In this file, translatable strings are annotated with 'G_' so xgettext
-  ;; catches them, but translation happens later on at run time.
-  str)
-
 (define-record-type* <system-service>
   system-service make-system-service
   system-service?
@@ -58,7 +52,9 @@
                                       ((_ fields ...)
                                        (system-service
                                         (type 'desktop)
-                                        fields ...)))))
+                                        fields ...))))
+               (G_ (syntax-rules ()               ;for xgettext
+                     ((_ str) str))))
     (list
      ;; This is the list of desktop environments supported as services.
      (desktop-environment
@@ -98,12 +94,7 @@
      (system-service
       (name (G_ "OpenSSH secure shell daemon (sshd)"))
       (type 'networking)
-      (snippet `(,(vertical-space 1)
-                 ,(comment
-                   (G_ "\
-;; To configure OpenSSH, pass an 'openssh-configuration'
-;; record as a second argument to 'service' below.\n"))
-                 (service openssh-service-type))))
+      (snippet '((service openssh-service-type))))
      (system-service
       (name (G_ "Tor anonymous network router"))
       (type 'networking)
@@ -158,45 +149,24 @@
          (desktop? (find desktop-system-service? services))
          (base     (if desktop?
                        '%desktop-services
-                       '%base-services))
-         (service-heading (list (vertical-space 1)
-                                (comment (G_ "\
-;; Below is the list of system services.  To search for available
-;; services, run 'guix system search KEYWORD' in a terminal.\n"))))
-         (package-heading (list (vertical-space 1)
-                                (comment (G_ "\
-;; Packages installed system-wide.  Users can also install packages
-;; under their own account: use 'guix search KEYWORD' to search
-;; for packages and 'guix install PACKAGE' to install a package.\n")))))
-
+                       '%base-services)))
     (if (null? snippets)
         `(,@(if (null? packages)
                 '()
-                `(,@package-heading
-                  (packages (append (list ,@packages)
+                `((packages (append (list ,@packages)
                                     %base-packages))))
-
-          ,@service-heading
           (services ,base))
         `(,@(if (null? packages)
                 '()
-                `(,@package-heading
-                  (packages (append (list ,@packages)
+                `((packages (append (list ,@packages)
                                     %base-packages))))
-
-          ,@service-heading
           (services (append (list ,@snippets
 
                                   ,@(if desktop?
                                         ;; XXX: Assume 'keyboard-layout' is in
                                         ;; scope.
-                                        `((set-xorg-configuration
+                                        '((set-xorg-configuration
                                            (xorg-configuration
                                             (keyboard-layout keyboard-layout))))
                                         '()))
-
-                            ,(vertical-space 1)
-                            ,(comment (G_ "\
-;; This is the default list of services we
-;; are appending to.\n"))
-                            ,base))))))
+                           ,base))))))

gnu/installer/steps.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,17 +21,14 @@
   #:use-module (guix records)
   #:use-module (guix build utils)
   #:use-module (guix i18n)
-  #:use-module (guix read-print)
   #:use-module (gnu installer utils)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (rnrs io ports)
-  #:export (&user-abort-error
-            user-abort-error?
-
-            <installer-step>
+  #:export (<installer-step>
             installer-step
             make-installer-step
             installer-step?
@@ -53,9 +50,6 @@
 
             %current-result))
 
-(define-condition-type &user-abort-error &error
-  user-abort-error?)
-
 ;; Hash table storing the step results. Use it only for logging and debug
 ;; purposes.
 (define %current-result (make-hash-table))
@@ -230,14 +224,10 @@ found in RESULTS."
                   (conf-formatter result-step)
                   '())))
           steps))
-        (modules `(,(vertical-space 1)
-                   ,(comment (G_ "\
-;; Indicate which modules to import to access the variables
-;; used in this configuration.\n"))
-                   (use-modules (gnu))
+        (modules '((use-modules (gnu))
                    (use-service-modules cups desktop networking ssh xorg))))
     `(,@modules
-      ,(vertical-space 1)
+      ()
       (operating-system ,@configuration))))
 
 (define* (configuration->file configuration
@@ -251,22 +241,14 @@ found in RESULTS."
       ;; length below 60 characters.
       (display (G_ "\
 ;; This is an operating system configuration generated
-;; by the graphical installer.
-;;
-;; Once installation is complete, you can learn and modify
-;; this file to tweak the system configuration, and pass it
-;; to the 'guix system reconfigure' command to effect your
-;; changes.\n")
+;; by the graphical installer.\n")
                port)
       (newline port)
-      (pretty-print-with-comments/splice port configuration
-                                         #:max-width 75
-                                         #:format-comment
-                                         (lambda (c indent)
-                                           ;; Localize C.
-                                           (comment (G_ (comment->string c))
-                                                    (comment-margin? c))))
-
+      (for-each (lambda (part)
+                  (if (null? part)
+                      (newline port)
+                      (pretty-print part port)))
+                configuration)
       (flush-output-port port))))
 
 ;;; Local Variables:

gnu/installer/tests.scm

@@ -280,10 +280,6 @@ instrumented for further testing."
        exp)))
 
   (let ((content (call-with-input-file file read-expressions)))
-    ;; XXX: Remove the file before re-writing it, to be sure there are no
-    ;; leftovers.  We shouldn't have to do that as CALL-WITH-OUTPUT-FILE uses
-    ;; the O_TRUNC flag by default.
-    (delete-file file)
     (call-with-output-file file
       (lambda (port)
         (format port "\

gnu/installer/user.scm

@@ -17,13 +17,16 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu installer user)
-  #:use-module (gnu installer utils)
   #:use-module (guix records)
-  #:use-module (guix read-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
-  #:export (<user>
+  #:export (<secret>
+            secret?
+            make-secret
+            secret-content
+
+            <user>
             user
             make-user
             user-name
@@ -34,6 +37,16 @@
 
             users->configuration))
 
+(define-record-type <secret>
+  (make-secret content)
+  secret?
+  (content secret-content))
+
+(set-record-type-printer!
+ <secret>
+ (lambda (secret port)
+   (format port "<secret>")))
+
 (define-record-type* <user>
   user make-user
   user?
@@ -56,11 +69,7 @@
       (supplementary-groups '("wheel" "netdev"
                               "audio" "video"))))
 
-  (define-syntax-rule (G_ str) str)
-
-  `(,(vertical-space 1)
-    ,(comment (G_ ";; The list of user accounts ('root' is implicit).\n"))
-    (users (cons*
+  `((users (cons*
             ,@(filter-map (lambda (user)
                             ;; Do not emit a 'user-account' form for "root".
                             (and (not (string=? (user-name user) "root"))

gnu/installer/utils.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,12 +20,9 @@
 (define-module (gnu installer utils)
   #:use-module (gnu services herd)
   #:use-module (guix utils)
-  #:use-module ((guix build syscalls) #:select (openpty login-tty))
   #:use-module (guix build utils)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -36,17 +33,11 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (ice-9 textual-ports)
-  #:export (<secret>
-            secret?
-            make-secret
-            secret-content
-
-            read-lines
+  #:export (read-lines
             read-all
             nearest-exact-integer
             read-percentage
             run-external-command-with-handler
-            run-external-command-with-handler/tty
             run-external-command-with-line-hooks
             run-command
             run-command-in-installer
@@ -67,16 +58,6 @@
 
             with-silent-shepherd))
 
-(define-record-type <secret>
-  (make-secret content)
-  secret?
-  (content secret-content))
-
-(set-record-type-printer!
- <secret>
- (lambda (secret port)
-   (format port "<secret>")))
-
 (define* (read-lines #:optional (port (current-input-port)))
   "Read lines from PORT and return them as a list."
   (let loop ((line (read-line port))
@@ -126,58 +107,26 @@ the child process as returned by waitpid."
     (close-port input)
     (close-pipe dummy-pipe)))
 
-(define (run-external-command-with-handler/tty handler command)
-  "Run command specified by the list COMMAND in a child operating in a
-pseudoterminal with output handler HANDLER.  HANDLER is a procedure taking an
-input port, to which the command will write its standard output and error.
-Returns the integer status value of the child process as returned by waitpid."
-  (define-values (controller inferior)
-    (openpty))
-
-  (match (primitive-fork)
-    (0
-     (catch #t
-       (lambda ()
-         (close-fdes controller)
-         (login-tty inferior)
-         (apply execlp (car command) command))
-       (lambda _
-         (primitive-exit 127))))
-    (pid
-     (close-fdes inferior)
-     (let* ((port (fdopen controller "r0"))
-            (result (false-if-exception
-                     (handler port))))
-       (close-port port)
-       (cdr (waitpid pid))))))
-
-(define* (run-external-command-with-line-hooks line-hooks command
-                                               #:key (tty? #false))
+(define (run-external-command-with-line-hooks line-hooks command)
   "Run command specified by the list COMMAND in a child, processing each
-output line with the procedures in LINE-HOOKS.  If TTY is set to #true, the
-COMMAND will be run in a pseudoterminal.  Returns the integer status value of
-the child process as returned by waitpid."
+output line with the procedures in LINE-HOOKS.  Returns the integer status
+value of the child process as returned by waitpid."
   (define (handler input)
     (and
-     ;; Lines for progress bars etc. end in \r; treat is as a line ending so
-     ;; those lines are printed right away.
-     (and=> (read-delimited "\r\n" input 'concat)
+     (and=> (get-line input)
             (lambda (line)
               (if (eof-object? line)
                   #f
                   (begin (for-each (lambda (f) (f line))
                                    (append line-hooks
-                                           %default-installer-line-hooks))
+                                       %default-installer-line-hooks))
                          #t))))
      (handler input)))
-  (if tty?
-      (run-external-command-with-handler/tty handler command)
-      (run-external-command-with-handler handler command)))
+  (run-external-command-with-handler handler command))
 
-(define* (run-command command #:key (tty? #f))
+(define* (run-command command)
   "Run COMMAND, a list of strings.  Return true if COMMAND exited
-successfully, #f otherwise.  If TTY is set to #true, the COMMAND will be run
-in a pseudoterminal."
+successfully, #f otherwise."
   (define (pause)
     (format #t (G_ "Press Enter to continue.~%"))
     (send-to-clients '(pause))
@@ -188,8 +137,8 @@ in a pseudoterminal."
 
   (installer-log-line "running command ~s" command)
   (define result (run-external-command-with-line-hooks
-                  (list display) command
-                  #:tty? tty?))
+                  (list %display-line-hook)
+                  command))
   (define exit-val (status:exit-val result))
   (define term-sig (status:term-sig result))
   (define stop-sig (status:stop-sig result))
@@ -266,10 +215,7 @@ values."
       (or port (%make-void-port "w")))))
 
 (define (%syslog-line-hook line)
-  (let ((line (if (string-suffix? "\r" line)
-                  (string-append (string-drop-right line 1) "\n")
-                  line)))
-    (format (syslog-port) "installer[~d]: ~a" (getpid) line)))
+  (format (syslog-port) "installer[~d]: ~a~%" (getpid) line))
 
 (define-syntax syslog
   (lambda (s)
@@ -298,7 +244,11 @@ values."
       port)))
 
 (define (%installer-log-line-hook line)
-  (display line (installer-log-port)))
+  (format (installer-log-port) "~a~%" line))
+
+(define (%display-line-hook line)
+  (display line)
+  (newline))
 
 (define %default-installer-line-hooks
   (list %syslog-line-hook
@@ -310,10 +260,9 @@ values."
     (syntax-case s ()
       ((_ fmt args ...)
        (string? (syntax->datum #'fmt))
-       (with-syntax ((fmt (string-append (syntax->datum #'fmt) "\n")))
-         #'(let ((formatted (format #f fmt args ...)))
-             (for-each (lambda (f) (f formatted))
-                       %default-installer-line-hooks)))))))
+       #'(let ((formatted (format #f fmt args ...)))
+               (for-each (lambda (f) (f formatted))
+                         %default-installer-line-hooks))))))
 
 
 ;;;

gnu/machine/digital-ocean.scm

@@ -1,8 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
-;;; Copyright © 2022 Matthew James Kraai <kraai@ftbfs.org>
-;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,7 +21,6 @@
   #:use-module (gnu machine ssh)
   #:use-module (gnu machine)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services networking)
   #:use-module (gnu system)
   #:use-module (gnu system pam)
@@ -36,9 +33,7 @@
   #:use-module (guix records)
   #:use-module (guix ssh)
   #:use-module (guix store)
-  #:use-module (ice-9 format)
   #:use-module (ice-9 iconv)
-  #:use-module (ice-9 string-fun)
   #:use-module (json)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
@@ -192,66 +187,18 @@ an environment type of 'digital-ocean-environment-type'."
 ;;; System deployment.
 ;;;
 
-;; XXX Copied from (gnu services base)
-(define* (ip+netmask->cidr ip netmask #:optional (family AF_INET))
-  "Return the CIDR notation (a string) for @var{ip} and @var{netmask}, two
-@var{family} address strings, where @var{family} is @code{AF_INET} or
-@code{AF_INET6}."
-  (let* ((netmask (inet-pton family netmask))
-         (bits    (logcount netmask)))
-    (string-append ip "/" (number->string bits))))
-
 ;; The following script was adapted from the guide available at
 ;; <https://wiki.pantherx.org/Installation-digital-ocean/>.
 (define (guix-infect network)
   "Given NETWORK, an alist describing the Droplet's public IPv4 network
 interface, return a Bash script that will install the Guix system."
-  (define os
-    `(operating-system
-       (host-name "gnu-bootstrap")
-       (timezone "Etc/UTC")
-       (bootloader (bootloader-configuration
-                    (bootloader grub-bootloader)
-                    (targets '("/dev/vda"))
-                    (terminal-outputs '(console))))
-       (file-systems (cons (file-system
-                             (mount-point "/")
-                             (device "/dev/vda1")
-                             (type "ext4"))
-                           %base-file-systems))
-       (services
-        (append (list (service static-networking-service-type
-                               (list (static-networking
-                                      (addresses
-                                       (list (network-address
-                                              (device "eth0")
-                                              (value ,(ip+netmask->cidr
-                                                       (assoc-ref network "ip_address")
-                                                       (assoc-ref network "netmask"))))))
-                                      (routes
-                                       (list (network-route
-                                              (destination "default")
-                                              (gateway ,(assoc-ref network "gateway")))))
-                                      (name-servers '("84.200.69.80" "84.200.70.40")))))
-                      (simple-service 'guile-load-path-in-global-env
-                                      session-environment-service-type
-                                      `(("GUILE_LOAD_PATH"
-                                         . "/run/current-system/profile/share/guile/site/3.0")
-                                        ("GUILE_LOAD_COMPILED_PATH"
-                                         . ,(string-append "/run/current-system/profile/lib/guile/3.0/site-ccache:"
-                                                           "/run/current-system/profile/share/guile/site/3.0"))))
-                      (service openssh-service-type
-                               (openssh-configuration
-                                (log-level 'debug)
-                                (permit-root-login 'prohibit-password))))
-            %base-services))))
   (format #f "#!/bin/bash
 
 apt-get update
 apt-get install xz-utils -y
-wget -nv https://ci.guix.gnu.org/search/latest/archive?query=spec:tarball+status:success+system:x86_64-linux+guix-binary.tar.xz -O guix-binary-nightly.x86_64-linux.tar.xz
+wget https://ftp.gnu.org/gnu/guix/guix-binary-1.0.1.x86_64-linux.tar.xz
 cd /tmp
-tar --warning=no-timestamp -xf ~~/guix-binary-nightly.x86_64-linux.tar.xz
+tar --warning=no-timestamp -xf ~~/guix-binary-1.0.1.x86_64-linux.tar.xz
 mv var/guix /var/ && mv gnu /
 mkdir -p ~~root/.config/guix
 ln -sf /var/guix/profiles/per-user/root/current-guix ~~root/.config/guix/current
@@ -281,9 +228,37 @@ export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\"
 guix package -i openssl
 cat > /etc/bootstrap-config.scm << EOF
 (use-modules (gnu))
-(use-service-modules base networking ssh)
+(use-service-modules networking ssh)
 
-~a
+(operating-system
+  (host-name \"gnu-bootstrap\")
+  (timezone \"Etc/UTC\")
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (targets '(\"/dev/vda\"))
+               (terminal-outputs '(console))))
+  (file-systems (cons (file-system
+                        (mount-point \"/\")
+                        (device \"/dev/vda1\")
+                        (type \"ext4\"))
+                      %base-file-systems))
+  (services
+   (append (list (static-networking-service \"eth0\" \"~a\"
+                    #:netmask \"~a\"
+                    #:gateway \"~a\"
+                    #:name-servers '(\"84.200.69.80\" \"84.200.70.40\"))
+                 (simple-service 'guile-load-path-in-global-env
+                  session-environment-service-type
+                  \\`((\"GUILE_LOAD_PATH\"
+                     . \"/run/current-system/profile/share/guile/site/2.2\")
+                    (\"GUILE_LOAD_COMPILED_PATH\"
+                     . ,(string-append \"/run/current-system/profile/lib/guile/2.2/site-ccache:\"
+                                       \"/run/current-system/profile/share/guile/site/2.2\"))))
+                 (service openssh-service-type
+                          (openssh-configuration
+                           (log-level 'debug)
+                           (permit-root-login 'prohibit-password))))
+           %base-services)))
 EOF
 # guix pull
 guix system build /etc/bootstrap-config.scm
@@ -292,9 +267,9 @@ mv /etc /old-etc
 mkdir /etc
 cp -r /old-etc/{passwd,group,shadow,gshadow,mtab,guix,bootstrap-config.scm} /etc/
 guix system reconfigure /etc/bootstrap-config.scm"
-          ;; Escape the bare backtick to avoid having it interpreted by Bash.
-          (string-replace-substring
-           (format #f "~y" os) "`" "\\`")))
+          (assoc-ref network "ip_address")
+          (assoc-ref network "netmask")
+          (assoc-ref network "gateway")))
 
 (define (machine-wait-until-available machine)
   "Block until the initial Debian image has been installed on the droplet
@@ -325,26 +300,18 @@ named DROPLET-NAME."
 configuration for the public IPv4 network described by the alist NETWORK."
   (operating-system
     (inherit (machine-operating-system target))
-    (services (cons* (service static-networking-service-type
-                              (list (static-networking
-                                     (addresses
-                                      (list (network-address
-                                             (device "eth0")
-                                             (value (ip+netmask->cidr
-                                                     (assoc-ref network "ip_address")
-                                                     (assoc-ref network "netmask"))))))
-                                     (routes
-                                      (list (network-route
-                                             (destination "default")
-                                             (gateway (assoc-ref network "gateway")))))
-                                     (name-servers '("84.200.69.80" "84.200.70.40")))))
+    (services (cons* (static-networking-service "eth0"
+                        (assoc-ref network "ip_address")
+                        #:netmask (assoc-ref network "netmask")
+                        #:gateway (assoc-ref network "gateway")
+                        #:name-servers '("84.200.69.80" "84.200.70.40"))
                     (simple-service 'guile-load-path-in-global-env
                                     session-environment-service-type
                                     `(("GUILE_LOAD_PATH"
-                                       . "/run/current-system/profile/share/guile/site/3.0")
+                                       . "/run/current-system/profile/share/guile/site/2.2")
                                       ("GUILE_LOAD_COMPILED_PATH"
-                                       . ,(string-append "/run/current-system/profile/lib/guile/3.0/site-ccache:"
-                                                         "/run/current-system/profile/share/guile/site/3.0"))))
+                                       . ,(string-append "/run/current-system/profile/lib/guile/2.2/site-ccache:"
+                                                         "/run/current-system/profile/share/guile/site/2.2"))))
                     (operating-system-user-services
                      (machine-operating-system target))))))
 
@@ -440,7 +407,7 @@ environment type of 'digital-ocean-environment-type'."
     (raise (condition
             (&message
              (message (G_ "No Digital Ocean access token was provided. This \
-may be fixed by setting the environment variable GUIX_DIGITAL_OCEAN_TOKEN to \
+may be fixed by setting the environment variable GUIX_DIGITAL_OCAEN_TOKEN to \
 one procured from https://cloud.digitalocean.com/account/api/tokens.")))))))
 
 (define (maybe-raise-unsupported-configuration-error machine)

gnu/machine/ssh.scm

@@ -42,7 +42,6 @@
   #:use-module ((guix inferior)
                 #:select (inferior-exception?
                           inferior-exception-arguments))
-  #:use-module ((guix platform) #:select (systems))
   #:use-module (gcrypt pk-crypto)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -87,8 +86,7 @@
   machine-ssh-configuration?
   this-machine-ssh-configuration
   (host-name      machine-ssh-configuration-host-name)     ; string
-  (system         machine-ssh-configuration-system         ; string
-                  (sanitize validate-system-type))
+  (system         machine-ssh-configuration-system)        ; string
   (build-locally? machine-ssh-configuration-build-locally? ; boolean
                   (default #t))
   (authorize?     machine-ssh-configuration-authorize?     ; boolean
@@ -111,32 +109,6 @@
   (host-key       machine-ssh-configuration-host-key       ; #f | string
                   (default #f)))
 
-(define-with-syntax-properties (validate-system-type (value properties))
-  ;; Raise an error if VALUE is not a valid system type.
-  (unless (string? value)
-    (raise (make-compound-condition
-            (condition
-             (&error-location
-              (location (source-properties->location properties))))
-            (formatted-message
-             (G_ "~a: invalid system type; must be a string")
-             value))))
-  (unless (member value (systems))
-    (raise (apply make-compound-condition
-                  (condition
-                   (&error-location
-                    (location (source-properties->location properties))))
-                  (formatted-message (G_ "~a: unknown system type") value)
-                  (let ((closest (string-closest value (systems)
-                                                 #:threshold 5)))
-                    (if closest
-                        (list (condition
-                               (&fix-hint
-                                (hint (format #f (G_ "Did you mean @code{~a}?")
-                                              closest)))))
-                        '())))))
-  value)
-
 (define (open-machine-ssh-session config)
   "Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
   (let ((host-name (machine-ssh-configuration-host-name config))
@@ -367,13 +339,9 @@ by MACHINE."
   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 'system' declaration would fail."
   (define assertions
-    (parameterize ((%current-system
-                    (machine-ssh-configuration-system
-                     (machine-configuration machine)))
-                   (%current-target-system #f))
-      (append (machine-check-file-system-availability machine)
-              (machine-check-initrd-modules machine)
-              (list (machine-check-forward-update machine)))))
+    (append (machine-check-file-system-availability machine)
+            (machine-check-initrd-modules machine)
+            (list (machine-check-forward-update machine))))
 
   (define aggregate-exp
     ;; Gather all the expressions so that a single round-trip is enough to
@@ -485,16 +453,12 @@ the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
-  (define config (machine-configuration machine))
-  (define host   (machine-ssh-configuration-host-name config))
-  (define system (machine-ssh-configuration-system config))
-
   (maybe-raise-unsupported-configuration-error machine)
   (when (machine-ssh-configuration-authorize?
          (machine-configuration machine))
     (unless (file-exists? %public-key-file)
       (raise (formatted-message (G_ "no signing key '~a'. \
-Have you run 'guix archive --generate-key'?")
+have you run 'guix archive --generate-key?'")
                                 %public-key-file)))
     (remote-authorize-signing-key (call-with-input-file %public-key-file
                                     (lambda (port)
@@ -502,54 +466,50 @@ Have you run 'guix archive --generate-key'?")
                                        (get-string-all port))))
                                   (machine-ssh-session machine)
                                   (machine-become-command machine)))
-
   (mlet %store-monad ((_ (check-deployment-sanity machine))
                       (boot-parameters (machine-boot-parameters machine)))
-    ;; Make sure code that check %CURRENT-SYSTEM, such as
-    ;; %BASE-INITRD-MODULES, gets to see the right value.
-    (parameterize ((%current-system system)
-                   (%current-target-system #f))
-      (let* ((os (machine-operating-system machine))
-             (eval (cut machine-remote-eval machine <>))
-             (menu-entries (map boot-parameters->menu-entry boot-parameters))
-             (bootloader-configuration (operating-system-bootloader os))
-             (bootcfg (operating-system-bootcfg os menu-entries)))
-        (define-syntax-rule (eval/error-handling condition handler ...)
-          ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
-          ;; exception is raised.
-          (lambda (exp)
-            (lambda (store)
-              (guard (condition ((inferior-exception? condition)
-                                 (values (begin handler ...) store)))
-                (values (run-with-store store (eval exp)
-                                        #:system system)
-                        store)))))
+    (let* ((os (machine-operating-system machine))
+           (host (machine-ssh-configuration-host-name
+                  (machine-configuration machine)))
+           (eval (cut machine-remote-eval machine <>))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootloader-configuration (operating-system-bootloader os))
+           (bootcfg (operating-system-bootcfg os menu-entries)))
+      (define-syntax-rule (eval/error-handling condition handler ...)
+        ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
+        ;; exception is raised.
+        (lambda (exp)
+          (lambda (store)
+            (guard (condition ((inferior-exception? condition)
+                               (values (begin handler ...) store)))
+              (values (run-with-store store (eval exp))
+                      store)))))
 
-        (mbegin %store-monad
-          (with-roll-back #f
-            (switch-to-system (eval/error-handling c
-                                (raise (formatted-message
-                                        (G_ "\
+      (mbegin %store-monad
+        (with-roll-back #f
+          (switch-to-system (eval/error-handling c
+                              (raise (formatted-message
+                                      (G_ "\
 failed to switch systems while deploying '~a':~%~{~s ~}")
-                                        host
-                                        (inferior-exception-arguments c))))
-                              os))
-          (with-roll-back #t
-            (mbegin %store-monad
-              (upgrade-shepherd-services (eval/error-handling c
-                                           (warning (G_ "\
+                                      host
+                                      (inferior-exception-arguments c))))
+                            os))
+        (with-roll-back #t
+          (mbegin %store-monad
+            (upgrade-shepherd-services (eval/error-handling c
+                                         (warning (G_ "\
 an error occurred while upgrading services on '~a':~%~{~s ~}~%")
-                                                    host
-                                                    (inferior-exception-arguments
-                                                     c)))
-                                         os)
-              (install-bootloader (eval/error-handling c
-                                    (raise (formatted-message
-                                            (G_ "\
+                                                  host
+                                                  (inferior-exception-arguments
+                                                   c)))
+                                       os)
+            (install-bootloader (eval/error-handling c
+                                  (raise (formatted-message
+                                          (G_ "\
 failed to install bootloader on '~a':~%~{~s ~}~%")
-                                            host
-                                            (inferior-exception-arguments c))))
-                                  bootloader-configuration bootcfg))))))))
+                                          host
+                                          (inferior-exception-arguments c))))
+                                bootloader-configuration bootcfg)))))))
 
 
 ;;;

gnu/packages.scm

@@ -4,7 +4,6 @@
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,11 +39,11 @@
   #:use-module (ice-9 binary-ports)
   #:autoload   (system base compile) (compile)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-39)
-  #:use-module (srfi srfi-71)
   #:export (search-patch
             search-patches
             search-auxiliary-file
@@ -66,9 +65,6 @@
             specification->package+output
             specification->location
             specifications->manifest
-            specifications->packages
-
-            package-unique-version-prefix
 
             generate-package-cache))
 
@@ -143,10 +139,13 @@ flags."
   ;; Search path for package modules.  Each item must be either a directory
   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
   ;; to narrow the search.
-  (let* ((not-colon   (char-set-complement (char-set #\:)))
-         (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
-                                       not-colon))
-         (channels-scm channels-go (package-path-entries)))
+  (let*-values (((not-colon)
+                 (char-set-complement (char-set #\:)))
+                ((environment)
+                 (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
+                                  not-colon))
+                ((channels-scm channels-go)
+                 (package-path-entries)))
     ;; Automatically add channels and items from $GUIX_PACKAGE_PATH to Guile's
     ;; search path.  For historical reasons, $GUIX_PACKAGE_PATH goes to the
     ;; front; channels go to the back so that they don't override Guix' own
@@ -499,13 +498,13 @@ return its return value."
   "Return a package matching SPEC.  SPEC may be a package name, or a package
 name followed by an at-sign and a version number.  If the version number is not
 present, return the preferred newest version."
-  (let ((name version (package-name->name+version spec)))
+  (let-values (((name version) (package-name->name+version spec)))
     (%find-package spec name version)))
 
 (define (specification->location spec)
   "Return the location of the highest-numbered package matching SPEC, a
 specification such as \"guile@2\" or \"emacs\"."
-  (let ((name version (package-name->name+version spec)))
+  (let-values (((name version) (package-name->name+version spec)))
     (match (find-package-locations name version)
       (()
        (if version
@@ -540,8 +539,8 @@ version; if SPEC does not specify an output, return OUTPUT.
 
 When OUTPUT is false and SPEC does not specify any output, return #f as the
 output."
-  (let ((name version sub-drv
-              (package-specification->name+version+output spec output)))
+  (let-values (((name version sub-drv)
+                (package-specification->name+version+output spec output)))
     (match (%find-package spec name version)
       (#f
        (values #f #f))
@@ -553,36 +552,10 @@ output."
                   (package-full-name package)
                   sub-drv))))))
 
-(define (specifications->packages specs)
-  "Given SPECS, a list of specifications such as \"emacs@25.2\" or
-\"guile:debug\", return a list of package/output tuples."
-  ;; This procedure exists so users of 'guix home' don't have to write out the
-  ;; (map (compose list specification->package+output)... boilerplate.
-  (map (compose list specification->package+output) specs))
-
 (define (specifications->manifest specs)
   "Given SPECS, a list of specifications such as \"emacs@25.2\" or
 \"guile:debug\", return a profile manifest."
   ;; This procedure exists mostly so users of 'guix package -m' don't have to
   ;; fiddle with multiple-value returns.
   (packages->manifest
-   (specifications->packages specs)))
-
-(define (package-unique-version-prefix name version)
-  "Search among all the versions of package NAME that are available, and
-return the shortest unambiguous version prefix to designate VERSION.  If only
-one version of the package is available, return the empty string."
-  (match (map package-version (find-packages-by-name name))
-    ((_)
-     ;; A single version of NAME is available, so do not specify the version
-     ;; number, even if the available version doesn't match VERSION.
-     "")
-    (versions
-     ;; If VERSION is the latest version, don't specify any version.
-     ;; Otherwise return the shortest unique version prefix.  Note that this
-     ;; is based on the currently available packages so the result may vary
-     ;; over time.
-     (if (every (cut version>? version <>)
-                (delete version versions))
-         ""
-         (version-unique-prefix version versions)))))
+   (map (compose list specification->package+output) specs)))

gnu/packages/accessibility.scm

@@ -1,10 +1,9 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Nikita <nikita@n0.is>
 ;;; Copyright © 2017 Stefan Reichör <stefan@xsteve.at>
-;;; Copyright © 2018, 2021, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2018, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 Andrew Miloradovsky <andrew@interpretmath.pw>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2022 Hunter Jozwiak <hunter.t.joz@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,7 +28,6 @@
   #:use-module (guix git-download)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system glib-or-gtk)
-  #:use-module (guix build-system meson)
   #:use-module (gnu packages)
   #:use-module (gnu packages lisp)
   #:use-module (gnu packages ocaml)
@@ -91,14 +89,14 @@ terminals.")
 (define-public brltty
   (package
     (name "brltty")
-    (version "6.5")
+    (version "6.4")
     (source
      (origin
        (method url-fetch)
        (uri
         (string-append "https://brltty.app/archive/brltty-" version ".tar.gz"))
        (sha256
-        (base32 "1h62xzd5k0aaq2k4v3w93rizxnb8psvkxrlx62wr08ybwpspgp7z"))))
+        (base32 "0zybi9i9izv25g0wphl0snddrhb6xl5879y4pkpjpnxq61wm9gry"))))
     (build-system glib-or-gtk-build-system)
     (arguments
      `(#:tests? #f                      ; No target
@@ -318,34 +316,3 @@ works with every X Window System based GUI (depends only on libX11); or as an
 assistant for graphic designers, who need to select individual pixels.")
     ;; Licensed either under Expat or GPLv2+.
     (license (list license:expat license:gpl2+))))
-
-(define-public espeakup
-  (package
-    (name "espeakup")
-    (version "0.90")
-    (source (origin
-              (method git-fetch)
-              (uri (git-reference
-                    (url "https://github.com/linux-speakup/espeakup")
-                    (commit (string-append "v" version))))
-              (file-name (git-file-name name version))
-              (sha256
-               (base32
-                "0lmjwafvfxy07zn18v3dzjwwpnid2xffgvy2dzlwkbns8gb60ds2"))))
-    (build-system meson-build-system)
-    (native-inputs (list pkg-config))
-    (inputs (list espeak-ng alsa-lib))
-    (license license:gpl3+)
-    (synopsis "Bridge for espeak and speakup")
-    (description
-     "Espeakup is a bridge between the speakup driver implemented in
-the Linux kernel and the espeak-ng text to speech synthesizer.
-In order for this package to work, you need to have the following
-kernel modules built:
-@itemize @bullet
-@item
-CONFIG_SPEAKUP=m
-@item
-CONFIG_SPEAKUP_SOFT=m
-@end itemize")
-    (home-page "ttps://github.com/linux-speakup/espeakup")))

gnu/packages/ada.scm

@@ -149,3 +149,32 @@ Ada system.  Being an interpreter, it does not implement most representation
 clauses, and thus does not support systems programming close to the machine
 level.")
     (license license:gpl2+)))
+
+(define-public python2-langkit
+  (let ((commit "fe0bc8bf60dbd2937759810df76ac420d99fc15f")
+        (revision "0"))
+    (package
+      (name "python2-langkit")
+      (version (git-version "0.0.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://github.com/AdaCore/langkit")
+                      (commit commit)))
+                (sha256
+                 (base32
+                  "1abqgw2p8pb1pm54my5kkbbixfhc6l0bwajdv1xlzyrh31xki3wx"))
+                (file-name (string-append name "-" version "-checkout"))))
+      (build-system python-build-system)
+      (propagated-inputs
+       (list python2-docutils python2-enum34 python2-funcy python2-mako))
+      (arguments
+       `(#:python ,python-2
+         #:tests? #f))           ; Tests would requite gprbuild (Ada).
+      (synopsis "Semantic analysis tool generator in Python")
+      (description "@code{Langkit} is a tool whose purpose is to make it easy
+to create syntactic and semantic analysis engines.  Write a language
+specification in our Python DSL and Langkit will generate for you an
+Ada library with bindings for the C and Python programming languages.")
+      (home-page "https://github.com/AdaCore/langkit/")
+      (license license:gpl3+))))   ; and gcc runtime library exception