ci: Update to the last version.

* gnu/ci.scm: Update to the master version.

.dir-locals.el

@@ -52,16 +52,11 @@
    (eval . (put 'test-equal 'scheme-indent-function 1))
    (eval . (put 'test-eq 'scheme-indent-function 1))
    (eval . (put 'call-with-input-string 'scheme-indent-function 1))
-   (eval . (put 'call-with-port 'scheme-indent-function 1))
    (eval . (put 'guard 'scheme-indent-function 1))
    (eval . (put 'lambda* 'scheme-indent-function 1))
    (eval . (put 'substitute* 'scheme-indent-function 1))
    (eval . (put 'match-record 'scheme-indent-function 2))
 
-   ;; 'modify-inputs' and its keywords.
-   (eval . (put 'modify-inputs 'scheme-indent-function 1))
-   (eval . (put 'replace 'scheme-indent-function 1))
-
    ;; 'modify-phases' and its keywords.
    (eval . (put 'modify-phases 'scheme-indent-function 1))
    (eval . (put 'replace 'scheme-indent-function 1))
@@ -80,7 +75,6 @@
    (eval . (put 'origin 'scheme-indent-function 0))
    (eval . (put 'build-system 'scheme-indent-function 0))
    (eval . (put 'bag 'scheme-indent-function 0))
-   (eval . (put 'gexp->derivation 'scheme-indent-function 1))
    (eval . (put 'graft 'scheme-indent-function 0))
    (eval . (put 'operating-system 'scheme-indent-function 0))
    (eval . (put 'file-system 'scheme-indent-function 0))
@@ -125,7 +119,6 @@
    (eval . (put 'with-extensions 'scheme-indent-function 1))
    (eval . (put 'with-parameters 'scheme-indent-function 1))
    (eval . (put 'let-system 'scheme-indent-function 1))
-   (eval . (put 'with-build-variables 'scheme-indent-function 2))
 
    (eval . (put 'with-database 'scheme-indent-function 2))
    (eval . (put 'call-with-database 'scheme-indent-function 1))
@@ -147,10 +140,6 @@
 
    (eval . (put 'with-paginated-output-port 'scheme-indent-function 1))
 
-   (eval . (put 'with-shepherd-action 'scheme-indent-function 3))
-
-   (eval . (put 'with-http-server 'scheme-indent-function 1))
-
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.
    (eval . (modify-syntax-entry ?~ "'"))

.gitattributes

@@ -1,3 +0,0 @@
-*.scm       diff=scheme
-*.scm.in    diff=scheme
-*.texi      diff=texinfo

.gitignore

@@ -74,7 +74,6 @@
 /etc/guix-daemon.service
 /etc/guix-publish.conf
 /etc/guix-publish.service
-/etc/guix-gc.service
 /etc/init.d/guix-daemon
 /etc/openrc/guix-daemon
 /guix-*
@@ -133,7 +132,6 @@
 /pre-inst-env
 /release-*
 /scripts/guix
-/t-*/
 /test-env
 /test-tmp
 /tests/*.trs
@@ -145,7 +143,6 @@ Makefile
 Makefile.in
 config.cache
 stamp-h[0-9]
-.am[0-9]*/
 .dirstamp
 .deps
 tmp

.guix-authorizations

@@ -6,6 +6,8 @@
 
  (("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
    (name "andreas"))
+  ("2A39 3FFF 68F4 EF7A 3D29  12AF 6F51 20A0 22FB B2D5"
+   (name "ajgrf"))
   ("4FB9 9F49 2B12 A365 7997  E664 8246 0C08 2A0E E98F"
    (name "alezost"))
   ("50F3 3E2E 5B0C 3D90 0424  ABE8 9BDC F497 A4BB CC7F"
@@ -14,9 +16,21 @@
    (name "apteryx"))
   ("7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3"
    (name "arunisaac"))
+  (;; primary: "3B12 9196 AE30 0C3C 0E90  A26F A715 5567 3271 9948"
+   "9A2B 401E D001 0650 1584  BAAC 8BC4 F447 6E8A 8E00"
+   (name "atheia"))
+  (;; primary: "BE62 7373 8E61 6D6D 1B3A  08E8 A21A 0202 4881 6103"
+   "39B3 3C8D 9448 0D2D DCC2  A498 8B44 A0CD C7B9 56F2"
+   (name "bandali"))
   (;; primary: "34FF 38BC D151 25A6 E340  A0B5 3453 2F9F AFCA 8B8E"
-   "A3A4 B419 0074 087C A7DE  5698 BC45 CA67 E2F8 D007"
+   "A0C5 E352 2EF8 EF5C 64CD  B7F0 FD73 CAC7 19D3 2566"
    (name "bavier"))
+  ("45CC 63B8 5258 C9D5 5F34  B239 D37D 0EA7 CECC 3912"
+   (name "biscuolo"))
+  ("7988 3B9F 7D6A 4DBF 3719  0367 2506 A96C CF63 0B21"
+   (name "boskovits"))
+  ("E82A C026 95D6 FF02 43CA  1E5C F6C5 2DD1 BA27 CB87"
+   (name "brettgilio"))
   (;; primary: "8929 BBC5 73CD 9206 3DDD 979D 3D36 CAA0 116F 0F99"
    "1C9B F005 1A1A 6A44 5257 599A A949 03A1 66A1 8FAE"
    (name "bricewge"))
@@ -36,6 +50,8 @@
    (name "davexunit"))
   ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807" ;FIXME: to be confirmed!
    (name "davexunit (2nd)"))
+  ("53C4 1E6E 41AA FE55 335A  CA5E 446A 2ED4 D940 BF14"
+   (name "daviwil"))
   ("A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351"
    (name "efraim"))
   (;; primary: "2453 02B1 BAB1 F867 FDCA  96BC 8F3F 861F 82EB 7A9A"
@@ -45,6 +61,8 @@
    (name "hoebjo"))
   ("B943 509D 633E 80DD 27FC  4EED 634A 8DFF D3F6 31DF"
    (name "htgoebel"))
+  ("7440 26BA 7CA3 C668 E940  1D53 0B43 1E98 3705 6942"
+   (name "ipetkov"))
   (;; primary: "66A5 6D9C 9A98 BE7F 719A  B401 2652 5665 AE72 7D37"
    "0325 78A6 8298 94E7 2AA2  66F5 D415 BF25 3B51 5976"
    (name "iyzsong"))
@@ -55,23 +73,29 @@
    (name "jlicht"))
   ("8141 6036 E81A 5CF7 8F80  1071 ECFC 8398 8B4E 4B9F"
    (name "jonsger"))
+  ("83B6 703A DCCA 3B69 4BCE  2DA6 E6A5 EE3C 1946 7A0D"
+   (name "kkebreau"))
   ("017D 74E2 7F58 5696 3801  781D F663 943E 08D8 092A"
    (name "lbraun"))
   ("CA4F 8CF4 37D7 478F DA05  5FD4 4213 7701 1A37 8446"
    (name "lbraun (professional)"))
   ("ACC2 3BA0 59F7 CCF4 08F0  43AD 442A 84B8 C70E 2F87"
-   (name "lilyp"))
+   (name "leoprikler"))
+  ("45E5 75FA 53EA 8BD6 1BCE  0B4E 3ADC 75F0 13D6 78F9"
+   (name "leungbk"))
   (;; primary: "4F71 6F9A 8FA2 C80E F1B5  E1BA 5E35 F231 DE1A C5E0"
    "B051 5948 F1E7 D3C1 B980  38A0 2646 FA30 BACA 7F08"
    (name "lfam"))
+  ("148B CB8B D80B FB16 B1DE  0E91 45A8 B1E8 6BCD 10A6"
+   (name "lle_bout"))
+  ("8887 84C4 1459 ACCB 83E7  E84C 634C 6E89 79FA BEC2"
+   (name "m1gu3l"))
   ("CBF5 9755 CBE7 E7EF EF18  3FB1 DD40 9A15 D822 469D"
    (name "marusich"))
   ("BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA"
    (name "mbakke"))
   ("D919 0965 CE03 199E AF28  B3BE 7CEF 2984 7562 C516"
    (name "mhw"))
-  ("B845 5B7F FAD5 E8E9 5DEF  4296 637B 0B13 8065 B68A"
-   (name "monego"))
   ("4008 6A7E 0252 9B60 31FB  8607 8354 7635 3176 9CA6"
    (name "mothacehe"))
   (;; primary: "F5BC 5534 C36F 0087 B39D  36EF 1C9D C4FE B9DB 7C4B"
@@ -89,8 +113,12 @@
   (;; primary: "B68B DF22 73F9 DA0E 63C1  8A32 515B F416 9242 D600"
    "C699 ED09 E51B CE89 FD1D  A078 AAC7 E891 896B 568A"
    (name "pgarlick"))
+  ("3A86 380E 58A8 B942 8D39  60E1 327C 1EF3 8DF5 4C32"
+   (name "phant0mas"))
   ("CD2D 5EAA A98C CB37 DA91  D6B0 5F58 1664 7F8B E551"
    (name "raghavgururajan"))
+  ("74D6 A930 F44B 9B84 9EA5  5606 C166 AA49 5F7F 189C"
+   (name "reepca"))
   ("BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC"
    (name "rekado"))
   (;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).

.mailmap

@@ -15,7 +15,6 @@ Ben Woodcroft <donttrustben@gmail.com>
 Ben Woodcroft <donttrustben@gmail.com> <b.woodcroft@uq.edu.au>
 Ben Woodcroft <donttrustben@gmail.com> <donttrustben near gmail.com>
 Brett Gilio <brettg@gnu.org> <brettg@posteo.net>
-Christine Lemmer-Webber <cwebber@dustycloud.org>
 Claes Wallin (韋嘉誠) <claes.wallin@greatsinodevelopment.com>
 Cyprien Nicolas <cyprien@nicolas.tf> <c.nicolas+gitorious@gmail.com>
 Daniel Pimentel <d4n1@d4n1.org> <d4n1@member.fsf.org>
@@ -25,8 +24,8 @@ David Thompson <davet@gnu.org> <dthompson2@worcester.edu>
 David Thompson <davet@gnu.org> <dthompson@member.fsf.org>
 David Thompson <davet@gnu.org> <dthompson@vistahigherlearning.com>
 Deck Pickard <deck.r.pickard@gmail.com> <nebu@kipple>
-Eric Bavier <bavier@posteo.net> <ericbavier@gmail.com>
-Eric Bavier <bavier@posteo.net> <bavier@member.fsf.org>
+Eric Bavier <bavier@member.fsf.org> <ericbavier@gmail.com>
+Eric Bavier <bavier@member.fsf.org> <bavier@posteo.net>
 Eric Dvorsak <eric@dvorsak.fr> <yenda1@gmail.com>
 George Clemmer <myglc2@gmail.com>
 ison <ison@airmail.cc> <ison111@protonmail.com>
@@ -39,22 +38,16 @@ Joshua Grant <tadni@riseup.net> <gzg@riseup.net>
 Joshua Grant <tadni@riseup.net> <jgrant@parenthetical.io>
 Joshua Grant <tadni@riseup.net> <tadnimi@gmail.com>
 Joshua Grant <tadni@riseup.net> <youlysses@riseup.net>
-Kei Kebreau <kkebreau@posteo.net>
+Kei Kebreau <kei@openmailbox.org> <kkebreau@posteo.net>
 Leo Famulari <leo@famulari.name> <lfamular@gmail.com>
-Liliana Marie Prikler <liliana.prikler@gmail.com>
-Liliana Marie Prikler <liliana.prikler@gmail.com> Leo Prikler <leo.prikler@student.tugraz.at>
 Ludovic Courtès <ludo@gnu.org> <ludovic.courtes@inria.fr>
 Marek Benc <dusxmt@gmx.com> <merkur32@gmail.com>
-Marius Bakke <marius@gnu.org> <mbakke@fastmail.com>
-Marius Bakke <marius@gnu.org> <m.bakke@warwick.ac.uk>
-Marius Bakke <marius@gnu.org> <marius.bakke@usit.uio.no>
-Marius Bakke <marius@gnu.org> <mbakke@berlin.guixsd.org>
+Marius Bakke <mbakke@fastmail.com> <m.bakke@warwick.ac.uk>
 Mathieu Lirzin <mthl@gnu.org> <mthl@openmailbox.org>
 Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org>
 Mathieu Othacehe <m.othacehe@gmail.com>
 Mathieu Othacehe <mathieu.othacehe@parrot.com>
 Mathieu Othacehe <othacehe@gnu.org>
-Matthew James Kraai <kraai@ftbfs.org>
 Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com>
 nikita <nikita@n0.is>
 nikita <nikita@n0.is> ng0 <ng0@n0.is>
@@ -91,4 +84,3 @@ Thomas Danckaert <thomas.danckaert@gmail.com> <post@thomasdanckaert.be>
 Tobias Geerinckx-Rice <me@tobias.gr> <tobias.geerinckx.rice@gmail.com>
 Tomáš Čech <sleep_walker@gnu.org> <sleep_walker@suse.cz>
 Vincent Legoll <vincent.legoll@gmail.com> <vincent.legoll@idgrilles.fr>
-Zheng Junjie <873216071@qq.com> Z572 <873216071@qq.com>

CODE-OF-CONDUCT

@@ -1,103 +1,78 @@
-Important: to avoid polarizing/hurtful discussions in our public spaces, any
-matter pertaining to our use of this Code of Conduct should be brought
-privately to the Guix maintainers at guix-maintainers@gnu.org.  Failure to do
-so will be considered as a violation of this Code of Conduct.
-
 Contributor Covenant Code of Conduct
 
+  Note: In the sequel, "project" refers to GNU Guix, and "project
+  maintainer(s)" refers to maintainer(s) of GNU Guix.
+
 Our Pledge
-We as members, contributors, and leaders pledge to make participation in our
-community a harassment-free experience for everyone, regardless of age, body
-size, visible or invisible disability, ethnicity, sex characteristics, gender
-identity and expression, level of experience, education, socio-economic status,
-nationality, personal appearance, race, caste, color, religion, or sexual
-identity and orientation.
-We pledge to act and interact in ways that contribute to an open, welcoming,
-diverse, inclusive, and healthy community.
+
+In the interest of fostering an open and welcoming environment, we as
+contributors and maintainers pledge to making participation in our project and
+our community a harassment-free experience for everyone, regardless of age, body
+size, disability, ethnicity, gender identity and expression, level of experience,
+education, socio-economic status, nationality, personal appearance, race,
+religion, or sexual identity and orientation.
+
 Our Standards
-Examples of behavior that contributes to a positive environment for our
-community include:
 
-* Demonstrating empathy and kindness toward other people
-* Being respectful of differing opinions, viewpoints, and experiences
-* Giving and gracefully accepting constructive feedback
-* Accepting responsibility and apologizing to those affected by our mistakes,
-and learning from the experience
-* Focusing on what is best not just for us as individuals, but for the overall
-community
+Examples of behavior that contributes to creating a positive environment
+include:
 
-Examples of unacceptable behavior include:
 
-* The use of sexualized language or imagery, and sexual attention or advances of
-any kind
-* Trolling, insulting or derogatory comments, and personal or political attacks
+* Using welcoming and inclusive language
+* Being respectful of differing viewpoints and experiences
+* Gracefully accepting constructive criticism
+* Focusing on what is best for the community
+* Showing empathy towards other community members
+
+
+Examples of unacceptable behavior by participants include:
+
+
+* The use of sexualized language or imagery and unwelcome sexual attention or
+advances
+* Trolling, insulting/derogatory comments, and personal or political attacks
 * Public or private harassment
-* Publishing others’ private information, such as a physical or email address,
-without their explicit permission
+* Publishing others’ private information, such as a physical or electronic
+address, without explicit permission
 * Other conduct which could reasonably be considered inappropriate in a
 professional setting
 
-Enforcement Responsibilities
-Community leaders are responsible for clarifying and enforcing our standards of
-acceptable behavior and will take appropriate and fair corrective action in
-response to any behavior that they deem inappropriate, threatening, offensive,
-or harmful.
-Community leaders have the right and responsibility to remove, edit, or reject
-comments, commits, code, wiki edits, issues, and other contributions that are
-not aligned to this Code of Conduct, and will communicate reasons for moderation
-decisions when appropriate.
-Scope
-This Code of Conduct applies within all community spaces, and also applies when
-an individual is officially representing the community in public spaces.
-Examples of representing our community include using an official e-mail address,
-posting via an official social media account, or acting as an appointed
-representative at an online or offline event.
-Enforcement
-Instances of abusive, harassing, or otherwise unacceptable behavior may be
-reported to the community leaders responsible for enforcement at
-guix-maintainers@gnu.org.
-All complaints will be reviewed and investigated promptly and fairly.
-All community leaders are obligated to respect the privacy and security of the
-reporter of any incident.
-Enforcement Guidelines
-Community leaders will follow these Community Impact Guidelines in determining
-the consequences for any action they deem in violation of this Code of Conduct:
-1. Correction
-Community Impact: Use of inappropriate language or other behavior deemed
-unprofessional or unwelcome in the community.
-Consequence: A private, written warning from community leaders, providing
-clarity around the nature of the violation and an explanation of why the
-behavior was inappropriate. A public apology may be requested.
-2. Warning
-Community Impact: A violation through a single incident or series of
-actions.
-Consequence: A warning with consequences for continued behavior. No
-interaction with the people involved, including unsolicited interaction with
-those enforcing the Code of Conduct, for a specified period of time. This
-includes avoiding interactions in community spaces as well as external channels
-like social media. Violating these terms may lead to a temporary or permanent
-ban.
-3. Temporary Ban
-Community Impact: A serious violation of community standards, including
-sustained inappropriate behavior.
-Consequence: A temporary ban from any sort of interaction or public
-communication with the community for a specified period of time. No public or
-private interaction with the people involved, including unsolicited interaction
-with those enforcing the Code of Conduct, is allowed during this period.
-Violating these terms may lead to a permanent ban.
-4. Permanent Ban
-Community Impact: Demonstrating a pattern of violation of community
-standards, including sustained inappropriate behavior, harassment of an
-individual, or aggression toward or disparagement of classes of individuals.
-Consequence: A permanent ban from any sort of public interaction within the
-community.
-Attribution
-This Code of Conduct is adapted from the Contributor Covenant,
-version 2.1, available at
-https://www.contributor-covenant.org/version/2/1/code_of_conduct.html.
-Community Impact Guidelines were inspired by
-Mozilla’s code of conduct enforcement ladder.
-For answers to common questions about this code of conduct, see the FAQ at
-https://www.contributor-covenant.org/faq. Translations are available at
-https://www.contributor-covenant.org/translations.
 
+Our Responsibilities
+
+Project maintainers are responsible for clarifying the standards of acceptable
+behavior and are expected to take appropriate and fair corrective action in
+response to any instances of unacceptable behavior.
+
+Project maintainers have the right and responsibility to remove, edit, or
+reject comments, commits, code, wiki edits, issues, and other contributions
+that are not aligned to this Code of Conduct, or to ban temporarily or
+permanently any contributor for other behaviors that they deem inappropriate,
+threatening, offensive, or harmful.
+
+Scope
+
+This Code of Conduct applies both within project spaces and in public spaces
+when an individual is representing the project or its community. Examples of
+representing a project or community include using an official project e-mail
+address, posting via an official social media account, or acting as an appointed
+representative at an online or offline event. Representation of a project may be
+further defined and clarified by project maintainers.
+
+Enforcement
+
+Instances of abusive, harassing, or otherwise unacceptable behavior may be
+reported by contacting the project team at guix-maintainers@gnu.org. All
+complaints will be reviewed and investigated and will result in a response that
+is deemed necessary and appropriate to the circumstances. The project team is
+obligated to maintain confidentiality with regard to the reporter of an incident.
+Further details of specific enforcement policies may be posted separately.
+
+Project maintainers who do not follow or enforce the Code of Conduct in good
+faith may face temporary or permanent repercussions as determined by other
+members of the project’s leadership.
+
+Attribution
+
+This Code of Conduct is adapted from the Contributor Covenant, version 1.4,
+available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html

Makefile.am

@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2013 Andreas Enge <andreas@enge.fr>
 # Copyright © 2015, 2017 Alex Kost <alezost@gmail.com>
 # Copyright © 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
@@ -15,7 +15,6 @@
 # Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 # Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
-# Copyright © 2021 Andrew Tropin <andrew@trop.in>
 #
 # This file is part of GNU Guix.
 #
@@ -81,7 +80,6 @@ MODULES =					\
   guix/base64.scm				\
   guix/ci.scm					\
   guix/cpio.scm					\
-  guix/cpu.scm					\
   guix/deprecation.scm				\
   guix/docker.scm	   			\
   guix/records.scm				\
@@ -97,10 +95,8 @@ 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					\
   guix/swh.scm					\
   guix/monads.scm				\
   guix/monad-repl.scm				\
@@ -144,9 +140,7 @@ MODULES =					\
   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			\
   guix/build-system/copy.scm			\
   guix/build-system/glib-or-gtk.scm		\
@@ -209,7 +203,6 @@ MODULES =					\
   guix/build/gnu-dist.scm			\
   guix/build/guile-build-system.scm		\
   guix/build/maven-build-system.scm		\
-  guix/build/minetest-build-system.scm		\
   guix/build/node-build-system.scm		\
   guix/build/perl-build-system.scm		\
   guix/build/python-build-system.scm		\
@@ -227,11 +220,11 @@ MODULES =					\
   guix/build/linux-module-build-system.scm	\
   guix/build/store-copy.scm			\
   guix/build/json.scm				\
-  guix/build/pack.scm				\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/profiles.scm			\
   guix/build/compile.scm			\
+  guix/build/rpath.scm				\
   guix/build/cvs.scm				\
   guix/build/svn.scm				\
   guix/build/syscalls.scm                       \
@@ -242,7 +235,6 @@ MODULES =					\
   guix/build/emacs-utils.scm			\
   guix/build/java-utils.scm			\
   guix/build/lisp-utils.scm			\
-  guix/build/meson-configuration.scm		\
   guix/build/maven/java.scm			\
   guix/build/maven/plugin.scm			\
   guix/build/maven/pom.scm			\
@@ -256,10 +248,8 @@ MODULES =					\
   guix/import/cpan.scm				\
   guix/import/cran.scm				\
   guix/import/crate.scm				\
-  guix/import/egg.scm   			\
   guix/import/elpa.scm   			\
   guix/import/gem.scm				\
-  guix/import/git.scm                           \
   guix/import/github.scm   			\
   guix/import/gnome.scm				\
   guix/import/gnu.scm				\
@@ -268,7 +258,6 @@ MODULES =					\
   guix/import/json.scm				\
   guix/import/kde.scm				\
   guix/import/launchpad.scm   			\
-  guix/import/minetest.scm   			\
   guix/import/opam.scm				\
   guix/import/print.scm				\
   guix/import/pypi.scm				\
@@ -297,30 +286,24 @@ MODULES =					\
   guix/scripts/refresh.scm			\
   guix/scripts/repl.scm				\
   guix/scripts/describe.scm			\
-  guix/scripts/style.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
   guix/scripts/system/reconfigure.scm		\
-  guix/scripts/home.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/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/json.scm  		\
-  guix/scripts/import/minetest.scm  		\
   guix/scripts/import/opam.scm			\
   guix/scripts/import/pypi.scm			\
   guix/scripts/import/stackage.scm		\
   guix/scripts/import/texlive.scm  		\
   guix/scripts/environment.scm			\
-  guix/scripts/shell.scm			\
   guix/scripts/publish.scm			\
   guix/scripts/edit.scm				\
   guix/scripts/size.scm				\
@@ -380,14 +363,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/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	\
-  gnu/packages/aux-files/linux-libre/5.15-x86_64.conf	\
+  gnu/packages/aux-files/linux-libre/5.11-arm.conf	\
+  gnu/packages/aux-files/linux-libre/5.11-arm64.conf	\
+  gnu/packages/aux-files/linux-libre/5.11-i686.conf	\
+  gnu/packages/aux-files/linux-libre/5.11-x86_64.conf	\
   gnu/packages/aux-files/linux-libre/5.10-arm.conf	\
   gnu/packages/aux-files/linux-libre/5.10-arm64.conf	\
   gnu/packages/aux-files/linux-libre/5.10-i686.conf	\
@@ -408,9 +387,6 @@ AUX_FILES =						\
   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/sitecustomize.py	\
-  gnu/packages/aux-files/renpy/renpy.in	\
   gnu/packages/aux-files/run-in-namespace.c
 
 # Templates, examples.
@@ -473,7 +449,6 @@ SCM_TESTS =					\
   tests/debug-link.scm				\
   tests/derivations.scm			\
   tests/discovery.scm				\
-  tests/egg.scm				\
   tests/elpa.scm				\
   tests/file-systems.scm			\
   tests/gem.scm				\
@@ -482,18 +457,14 @@ SCM_TESTS =					\
   tests/git-authenticate.scm			\
   tests/glob.scm				\
   tests/gnu-maintenance.scm			\
+  tests/go.scm					\
   tests/grafts.scm				\
   tests/graph.scm				\
   tests/gremlin.scm				\
   tests/hackage.scm				\
-  tests/home-import.scm				\
-  tests/http-client.scm				\
-  tests/import-git.scm				\
-  tests/import-github.scm			\
   tests/import-utils.scm			\
   tests/inferior.scm				\
   tests/lint.scm				\
-  tests/minetest.scm				\
   tests/modules.scm				\
   tests/monads.scm				\
   tests/nar.scm				\
@@ -513,9 +484,7 @@ SCM_TESTS =					\
   tests/search-paths.scm			\
   tests/services.scm				\
   tests/services/file-sharing.scm		\
-  tests/services/configuration.scm		\
   tests/services/linux.scm			\
-  tests/services/telephony.scm			\
   tests/sets.scm				\
   tests/size.scm				\
   tests/status.scm				\
@@ -527,7 +496,6 @@ SCM_TESTS =					\
   tests/swh.scm				\
   tests/syscalls.scm				\
   tests/system.scm				\
-  tests/style.scm				\
   tests/texlive.scm				\
   tests/transformations.scm			\
   tests/ui.scm					\
@@ -537,12 +505,6 @@ SCM_TESTS =					\
   tests/uuid.scm				\
   tests/workers.scm
 
-if HAVE_GUILE_LIB
-SCM_TESTS += tests/go.scm
-else
-EXTRA_DIST += tests/go.scm
-endif
-
 if BUILD_DAEMON_OFFLOAD
 SCM_TESTS  += tests/offload.scm
 else
@@ -563,12 +525,10 @@ SH_TESTS =					\
   tests/guix-package-aliases.sh			\
   tests/guix-package-net.sh			\
   tests/guix-system.sh				\
-  tests/guix-home.sh				\
   tests/guix-archive.sh				\
   tests/guix-authenticate.sh			\
   tests/guix-environment.sh			\
   tests/guix-environment-container.sh		\
-  tests/guix-shell.sh				\
   tests/guix-graph.sh				\
   tests/guix-describe.sh			\
   tests/guix-repl.sh     			\
@@ -619,8 +579,7 @@ check-system: $(GOBJECTS)
 dist_pkgdata_DATA =				\
   etc/substitutes/berlin.guix.gnu.org.pub	\
   etc/substitutes/ci.guix.gnu.org.pub		\
-  etc/substitutes/ci.guix.info.pub		\
-  etc/substitutes/bordeaux.guix.gnu.org.pub
+  etc/substitutes/ci.guix.info.pub
 
 # Bash completion file.
 dist_bashcompletion_DATA = etc/completion/bash/guix	\
@@ -644,11 +603,9 @@ EXTRA_DIST +=						\
   .guix-authorizations					\
   .guix-channel						\
   scripts/guix.in					\
-  etc/disarchive-manifest.scm				\
   etc/guix-install.sh					\
   etc/news.scm						\
   etc/release-manifest.scm				\
-  etc/source-manifest.scm				\
   etc/system-tests.scm					\
   etc/historical-authorizations				\
   build-aux/build-self.scm				\
@@ -657,24 +614,21 @@ EXTRA_DIST +=						\
   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/signing-key.pub					\
+  tests/signing-key.sec					\
   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/civodul.key					\
+  tests/rsa.key						\
+  tests/dsa.key						\
+  tests/ed25519.key					\
+  tests/ed25519.sec					\
+  tests/ed25519bis.key					\
+  tests/ed25519bis.sec					\
   build-aux/config.rpath				\
   bootstrap						\
   doc/build.scm						\
@@ -701,60 +655,15 @@ CLEANFILES =					\
 # the whole thing.  Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly
 # stale files from ~/.cache/guile/ccache.
 %.go: make-go ; @:
-make-go: make-core-go make-packages-go make-system-go make-cli-go
-
-# Define a rule to build a subset of the .go files.
-define guile-compilation-rule
-
-$(1): $(2)
-	$(AM_V_at)echo "Compiling Scheme modules..." ;		\
-	unset GUILE_LOAD_COMPILED_PATH ;			\
-	XDG_CACHE_HOME=/nowhere					\
-	host=$(host) srcdir="$(top_srcdir)"			\
-	$(top_builddir)/pre-inst-env				\
-	$(GUILE) -L "$(top_builddir)" -L "$(top_srcdir)"	\
-	  --no-auto-compile					\
-	  -s "$(top_srcdir)"/build-aux/compile-all.scm		\
-	  --total $(words $(MODULES))				\
-	  --completed $(3)					\
-	  $$(filter %.scm,$$^)
-
-endef
-
-# Split compilation in several steps, each of which building a subset of
-# $(MODULES).  The main goal is to reduce peak memory consumption, as reported
-# in <https://issues.guix.gnu.org/48963>.  Each 'eval' call below creates a
-# 'make-*-go' phony target that builds the corresponding subset.
-
-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-packages-go,	\
-  $(MODULES_PACKAGES) make-core-go,			\
-  $(words $(MODULES_CORE))))
-.PHONY: make-packages-go
-
-$(eval $(call guile-compilation-rule,make-system-go,	\
-  $(MODULES_SYSTEM) make-packages-go make-core-go,	\
-  $(words $(MODULES_CORE) $(MODULES_PACKAGES))))
-.PHONY: make-system-go
-
-$(eval $(call guile-compilation-rule,make-cli-go,			\
-  $(MODULES_CLI) make-system-go make-packages-go make-core-go,		\
-  $(words $(MODULES_CORE) $(MODULES_PACKAGES) $(MODULES_SYSTEM))))
-.PHONY: make-cli-go
-
-$(eval $(call guile-compilation-rule,guix/build/po.go,			\
-  $(MODULES_PO),							\
-  0))
+make-go: $(MODULES) guix/config.scm $(dist_noinst_DATA)
+	$(AM_V_at)echo "Compiling Scheme modules..." ;			\
+	unset GUILE_LOAD_COMPILED_PATH ;				\
+	XDG_CACHE_HOME=/nowhere						\
+	host=$(host) srcdir="$(top_srcdir)"				\
+	$(top_builddir)/pre-inst-env					\
+	$(GUILE) -L "$(top_builddir)" -L "$(top_srcdir)"		\
+	  --no-auto-compile 						\
+	  -s "$(top_srcdir)"/build-aux/compile-all.scm $^
 
 SUFFIXES = .go
 
@@ -973,7 +882,7 @@ release: dist-with-updated-version all
             --system=$$system --fallback						\
 	    gnu/system/install.scm` ;							\
 	  if [ ! -f "$$image" ] ; then							\
-	    echo "failed to produce Guix installation image for $$system" >&2 ;	\
+	    echo "failed to produced Guix installation image for $$system" >&2 ;	\
 	    exit 1 ;									\
 	  fi ;										\
 	  cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" ;	\
@@ -988,7 +897,7 @@ release: dist-with-updated-version all
 	    --system=$$system --fallback						\
 	    gnu/system/examples/vm-image.tmpl` ;					\
 	  if [ ! -f "$$image" ] ; then							\
-	    echo "failed to produce Guix VM image for $$system" >&2 ;			\
+	    echo "failed to produced Guix VM image for $$system" >&2 ;			\
 	    exit 1 ;									\
 	  fi ;										\
 	  cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_VM_IMAGE_BASE).$$system.qcow2";	\
@@ -1028,12 +937,10 @@ assert-no-store-file-names:
 	  exit 1 ;								\
 	fi
 
-# Make sure important substitutes are available.  Check only the primary
-# server so that '--display-missing' doesn't print two lists.
+# Make sure important substitutes are available.
 assert-binaries-available: $(GOBJECTS)
 	$(AM_V_at)$(top_builddir)/pre-inst-env				\
 	  guix weather -m "$(top_srcdir)/etc/release-manifest.scm"	\
-	                --substitute-urls="https://ci.guix.gnu.org"	\
 	                --display-missing
 
 # Make sure the final inputs don't refer to bootstrap tools.

NEWS

@@ -4,7 +4,6 @@
 
 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 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
@@ -12,40 +11,10 @@ Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 
 Please send Guix bug reports to bug-guix@gnu.org.
 
-* Changes in 1.4.0 (since 1.3.0)
-** Package management
-*** New ‘guix home’ command, for home environment management
-*** New ‘guix shell’ command, the successor to ‘guix environment’
-*** New ‘deb’ format for the ‘guix pack’ command
-*** New ‘guix import minetest’ command, to import Minetest extensions
-*** ‘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
-*** ‘--with-commit’ option now accepts strings returned by ‘git describe’
-** Distribution
-*** The installation script can now enable local substitute servers discovery
-*** 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
-** Programming interfaces
-*** (guix records) now supports “field sanitizers”
-** Noteworthy bug fixes
-*** Fall back to Software Heritage when cloning a channel
-    (<https://issues.guix.gnu.org/44187>)
-*** ‘--with-patch’ can be used on packages with non-origin sources
-    (<https://issues.guix.gnu.org/49697>)
-*** Fix pathological profile building performance in the presence of grafts
-    (<https://issues.guix.gnu.org/49439>)
-*** Deduplication phase of the garbage collector is now faster
-    (<https://issues.guix.gnu.org/24937>)
-*** File system flags are validated before system instantiation
-    (<https://issues.guix.gnu.org/51425>)
-
 * Changes in 1.3.0 (since 1.2.0)
+
 ** Package management
+
 *** POWER9 (powerpc64le-linux) is now supported as a technology preview
 *** New ‘--export-manifest’ and ‘--export-channels’ options of ‘guix package’
 *** New ‘--profile’ option for ‘guix environment’

THANKS

@@ -43,7 +43,7 @@ infrastructure help:
 	     Alen Skondro <askondro@gmail.com>
               Jan Synáček <jan.synacek@gmail.com>
 	 Matthias Wachs <wachs@net.in.tum.de>
-        Christine Lemmer-Webber <cwebber@dustycloud.org>
+Christopher Allan Webber <cwebber@dustycloud.org>
            Philip Woods <elzairthesorcerer@gmail.com>
 
 GNU Guix also includes non-software works.  Thanks to the following

bootstrap

@@ -5,7 +5,8 @@ set -e -x
 
 # Generate stubs for translations.
 langs=`find po/doc -type f -name 'guix-manual*.po' \
-        | sed -e 's,.*/guix-manual\.,,;s,\.po$,,'`
+        | sed -e 's,guix-manual\.,,' \
+        | xargs -n 1 -I{} basename {} .po`
 for lang in ${langs}; do
     if [ ! -e "doc/guix.${lang}.texi" ]; then
 	echo "@setfilename guix.${lang}.info" > "doc/guix.${lang}.texi"
@@ -15,7 +16,8 @@ for lang in ${langs}; do
     fi
 done
 langs=`find po/doc -type f -name 'guix-cookbook*.po' \
-        | sed -e 's,.*/guix-cookbook\.,,;s,\.po$,,'`
+        | sed -e 's,guix-cookbook\.,,' \
+        | xargs -n 1 -I{} basename {} .po`
 for lang in ${langs}; do
     if [ ! -e "doc/guix-cookbook.${lang}.texi" ]; then
 	echo "@setfilename guix-cookbook.${lang}.info" > "doc/guix-cookbook.${lang}.texi"

build-aux/build-self.scm

@@ -250,7 +250,6 @@ interface (FFI) of Guile.")
     (match-lambda
       (('guix 'config) #f)
       (('guix 'channels) #f)
-      (('guix 'build 'download) #f)             ;autoloaded by (guix download)
       (('guix _ ...)   #t)
       (('gnu _ ...)    #t)
       (_               #f)))
@@ -494,7 +493,7 @@ files."
                       (message (format #f "You found a bug: the program '~a'
 failed to compute the derivation for Guix (version: ~s; system: ~s;
 host version: ~s; pull-version: ~s).
-Please report the COMPLETE output above by email to <~a>.~%"
+Please report it by email to <~a>.~%"
                                        (derivation->output-path build)
                                        version system %guix-version pull-version
                                        %guix-bug-report-address))))))))))))

build-aux/compile-all.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -98,36 +98,26 @@ to 'make'."
     (exit 1)))
 
 (match (command-line)
-  ((_ "--total" (= string->number grand-total)
-      "--completed" (= string->number processed)
-      . files)
-   ;; GRAND-TOTAL is the total number of .scm files in the project; PROCESSED
-   ;; is the total number of .scm files already compiled in previous
-   ;; invocations of this script.
+  ((_ . files)
    (catch #t
      (lambda ()
-       (let* ((to-build  (filter file-needs-compilation? files))
-              (processed (+ processed
-                            (- (length files) (length to-build)))))
-         (compile-files srcdir (getcwd) to-build
-                        #:workers (parallel-job-count*)
-                        #:host host
-                        #:report-load (lambda (file total completed)
-                                        (when file
-                                          (format #t "[~3d%] LOAD     ~a~%"
-                                                  (% (+ 1 completed
-                                                          (* 2 processed))
-                                                     (* 2 grand-total))
-                                                  file)
-                                          (force-output)))
-                        #:report-compilation (lambda (file total completed)
-                                               (when file
-                                                 (format #t "[~3d%] GUILEC   ~a~%"
-                                                         (% (+ total completed 1
-                                                                     (* 2 processed))
-                                                            (* 2 grand-total))
-                                                         (scm->go file))
-                                                 (force-output))))))
+       (compile-files srcdir (getcwd)
+                      (filter file-needs-compilation? files)
+                      #:workers (parallel-job-count*)
+                      #:host host
+                      #:report-load (lambda (file total completed)
+                                      (when file
+                                        (format #t "[~3d%] LOAD     ~a~%"
+                                                (% (+ 1 completed) (* 2 total))
+                                                file)
+                                        (force-output)))
+                      #:report-compilation (lambda (file total completed)
+                                             (when file
+                                               (format #t "[~3d%] GUILEC   ~a~%"
+                                                       (% (+ total completed 1)
+                                                          (* 2 total))
+                                                       (scm->go file))
+                                               (force-output)))))
      (lambda _
        (primitive-exit 1))
      (lambda args
@@ -142,8 +132,11 @@ to 'make'."
                             (false-if-exception
                              (module-ref ui 'report-load-error)))))
          (if report
-             (report (or (and=> (current-load-port) port-filename) "?.scm")
-                     args frame)
+             ;; In Guile <= 2.2.5, 'current-load-port' was not exported.
+             (let ((load-port ((module-ref (resolve-module '(ice-9 ports))
+                                           'current-load-port))))
+               (report (or (and=> load-port port-filename) "?.scm")
+                       args frame))
              (begin
                (print-exception (current-error-port) frame
                                 (car args) (cdr args))

build-aux/convert-xref.scm

@@ -1,26 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Julien Lepiller <julien@lepiller.eu>
-;;;
-;;; 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/>.
-
-;; Translate cross-references in a translated .texi manual.
-
-(use-modules (guix build po)
-             (ice-9 match))
-
-(match (command-line)
-  ((program texi pofile)
-   (translate-cross-references texi pofile)))

build-aux/test-env.in

@@ -73,9 +73,9 @@ then
 	# Copy the keys so that the secret key has the right permissions (the
 	# daemon errors out when this is not the case.)
 	mkdir -p "$GUIX_CONFIGURATION_DIRECTORY"
-	cp "@abs_top_srcdir@/tests/keys/signing-key.sec"	\
-	   "@abs_top_srcdir@/tests/keys/signing-key.pub"	\
-	   "$GUIX_CONFIGURATION_DIRECTORY"
+	cp "@abs_top_srcdir@/tests/signing-key.sec"	\
+	    "@abs_top_srcdir@/tests/signing-key.pub"	\
+	    "$GUIX_CONFIGURATION_DIRECTORY"
 	chmod 400 "$GUIX_CONFIGURATION_DIRECTORY/signing-key.sec"
     fi
 

config-daemon.ac

@@ -94,6 +94,17 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_CHECK_FUNCS([lutimes lchown posix_fallocate sched_setaffinity \
      statvfs nanosleep strsignal statx])
 
+  dnl Check whether the store optimiser can optimise symlinks.
+  AC_MSG_CHECKING([whether it is possible to create a link to a symlink])
+  ln -s bla tmp_link
+  if ln tmp_link tmp_link2 2> /dev/null; then
+      AC_MSG_RESULT(yes)
+      AC_DEFINE(CAN_LINK_SYMLINK, 1, [Whether link() works on symlinks.])
+  else
+      AC_MSG_RESULT(no)
+  fi
+  rm -f tmp_link tmp_link2
+
   dnl Check for <locale>.
   AC_LANG_PUSH(C++)
   AC_CHECK_HEADERS([locale])
@@ -106,7 +117,7 @@ if test "x$guix_build_daemon" = "xyes"; then
 
   dnl Determine the appropriate default list of substitute URLs (GnuTLS
   dnl is required so we can default to 'https'.)
-  guix_substitute_urls="https://ci.guix.gnu.org https://bordeaux.guix.gnu.org"
+  guix_substitute_urls="https://ci.guix.gnu.org"
 
   AC_MSG_CHECKING([for default substitute URLs])
   AC_MSG_RESULT([$guix_substitute_urls])

configure.ac

@@ -8,7 +8,7 @@ AC_INIT([GNU Guix],
   [https://www.gnu.org/software/guix/])
 AC_CONFIG_AUX_DIR([build-aux])
 
-AM_INIT_AUTOMAKE([1.14 gnu tar-ustar silent-rules subdir-objects \
+AM_INIT_AUTOMAKE([1.14 gnu silent-rules subdir-objects \
  color-tests parallel-tests -Woverride -Wno-portability])
 
 # Enable silent rules by default.
@@ -96,14 +96,15 @@ m4_pattern_forbid([^GUIX_])
 
 dnl Search for 'guile' and 'guild'.  This macro defines
 dnl 'GUILE_EFFECTIVE_VERSION'.
-GUILE_PKG([3.0])
+GUILE_PKG([3.0 2.2])
 GUILE_PROGS
 if test "x$GUILD" = "x"; then
    AC_MSG_ERROR(['guild' binary not found; please check your Guile installation.])
 fi
 
-dnl (guix ui), notably, requires 'default-optimization-level' added in 3.0.3.
-PKG_CHECK_MODULES([GUILE], [guile-3.0 >= 3.0.3])
+if test "x$GUILE_EFFECTIVE_VERSION" = "x2.2"; then
+  PKG_CHECK_MODULES([GUILE], [guile-2.2 >= 2.2.6])
+fi
 
 dnl Get CFLAGS and LDFLAGS for libguile.
 GUILE_FLAGS

doc/build.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -65,7 +65,7 @@
 (define %languages
   ;; The cookbook is not translated in the same languages as the manual
   (if (string=? %manual "guix-cookbook")
-      '("de" "en" "fr" "sk")
+      '("de" "en" "fr")
       '("de" "en" "es" "fr" "ru" "zh_CN")))
 
 (define (texinfo-manual-images source)
@@ -439,7 +439,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                 ("rarr"   "→")
                 ("hellip" "…")
                 ("rsquo"  "’")
-                ("nbsp"   " ")
                 (e (pk 'unknown-entity e) (primitive-exit 2))))
 
             (define (concatenate-snippets pieces)
@@ -600,175 +599,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 
   (computed-file name build))
 
-(define* (stylized-html source input
-                        #:key
-                        (languages %languages)
-                        (manual %manual)
-                        (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."
-  (define build
-    (with-extensions (list guile-lib)
-      (with-imported-modules `((guix build utils)
-                               ((localization)
-                                => ,(localization-helper-module
-                                     source languages)))
-        #~(begin
-            (use-modules (htmlprag)
-                         (localization)
-                         (guix build utils)
-                         (srfi srfi-1)
-                         (ice-9 match)
-                         (ice-9 threads))
-
-            (define* (menu-dropdown #:key (label "Item") (url "#") (items '()))
-              ;; Return an SHTML <li> element representing a dropdown for the
-              ;; navbar.  LABEL is the text of the dropdown menu, and ITEMS is
-              ;; the list of items in this menu.
-              (define id "visible-dropdown")
-
-              `(li
-                (@ (class "navbar-menu-item dropdown dropdown-btn"))
-                (input (@ (class "navbar-menu-hidden-input")
-                          (type "radio")
-                          (name "dropdown")
-                          (id ,id)))
-                (label (@ (for ,id)) ,label)
-                (label (@ (for "all-dropdowns-hidden")) ,label)
-                (div
-                 (@ (class "navbar-submenu")
-                    (id "navbar-submenu"))
-                 (div (@ (class "navbar-submenu-triangle"))
-                      " ")
-                 (ul ,@items))))
-
-            (define (menu-item label url)
-              ;; Return an SHTML <li> element for a menu item with the given
-              ;; LABEL and URL.
-              `(li (a (@ (class "navbar-menu-item")
-	                 (href ,url))
-                      ,label)))
-
-            (define* (navigation-bar menus #:key split-node?)
-              ;; Return the navigation bar showing all of MENUS.
-              `(header (@ (class "navbar"))
-                       (h1 (a (@ (class "branding")
-                                 (href ,(if split-node? ".." "#")))))
-                       (nav (@ (class "navbar-menu"))
-                            (input (@ (class "navbar-menu-hidden-input")
-                                      (type "radio")
-                                      (name "dropdown")
-                                      (id "all-dropdowns-hidden")))
-                            (ul ,@menus))
-
-                       ;; This is the button that shows up on small screen in
-                       ;; lieu of the drop-down button.
-                       (a (@ (class "navbar-menu-btn")
-                             (href ,(if split-node? "../.." ".."))))))
-
-            (define* (base-language-url code manual
-                                        #:key split-node?)
-              ;; Return the base URL of MANUAL for language CODE.
-              (if split-node?
-                  (string-append "../../" (normalize code) "/html_node")
-                  (string-append "../" (normalize code) "/" manual
-                                 (if (string=? code "en")
-                                     ""
-                                     (string-append "." code))
-                                 ".html")))
-
-            (define (language-menu-items file)
-              ;; Return the language menu items to be inserted in FILE.
-              (define split-node?
-                (string-contains file "/html_node/"))
-
-              (append
-                  (map (lambda (code)
-                         (menu-item (language-code->native-name code)
-                                    (base-language-url code #$manual
-                                                       #:split-node?
-                                                       split-node?)))
-                       '#$%languages)
-                  (list
-                   (menu-item "⊕"
-                              (if (string=? #$manual "guix-cookbook")
-                                  "https://translate.fedoraproject.org/projects/guix/documentation-cookbook/"
-                                  "https://translate.fedoraproject.org/projects/guix/documentation-manual/")))))
-
-            (define (stylized-html sxml file)
-              ;; Return SXML, which was read from FILE, with additional
-              ;; styling.
-              (define split-node?
-                (string-contains file "/html_node/"))
-
-              (let loop ((sxml sxml))
-                (match sxml
-                  (('*TOP* decl body ...)
-                   `(*TOP* ,decl ,@(map loop body)))
-                  (('head elements ...)
-                   ;; Add reference to our own manual CSS, which provides
-                   ;; support for the language menu.
-                   `(head ,@elements
-                          (link (@ (rel "stylesheet")
-                                   (type "text/css")
-                                   (href #$manual-css-url)))))
-                  (('body ('@ attributes ...) elements ...)
-                   `(body (@ ,@attributes)
-                          ,(navigation-bar
-                            ;; TODO: Add "Contribute" menu, to report
-                            ;; errors, etc.
-                            (list (menu-dropdown
-                                   #:label
-                                   `(img (@ (alt "Language")
-                                            (src "/static/base/img/language-picker.svg")))
-                                   #:items
-                                   (language-menu-items file)))
-                            #:split-node? split-node?)
-                          ,@elements))
-                  ((tag ('@ attributes ...) body ...)
-                   `(,tag (@ ,@attributes) ,@(map loop body)))
-                  ((tag body ...)
-                   `(,tag ,@(map loop body)))
-                  ((? string? str)
-                   str))))
-
-            (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))
-                     (base         (string-drop file (string-length #$input)))
-                     (target       (string-append #$output base)))
-                (mkdir-p (dirname target))
-                (call-with-output-file target
-                  (lambda (port)
-                    (write-shtml-as-html processed port)))))
-
-            ;; Install a UTF-8 locale so we can process UTF-8 files.
-            (setenv "GUIX_LOCPATH"
-                    #+(file-append glibc-utf8-locales "/lib/locale"))
-            (setlocale LC_ALL "en_US.utf8")
-            (setenv "LC_ALL" "en_US.utf8")
-            (setvbuf (current-error-port) 'line)
-
-            (n-par-for-each (parallel-job-count)
-                            (lambda (file)
-                              (if (string-suffix? ".html" file)
-                                  (process-html file)
-                                  ;; Copy FILE as is to #$output.
-                                  (let* ((base   (string-drop file (string-length #$input)))
-                                         (target (string-append #$output base)))
-                                    (mkdir-p (dirname target))
-                                    (if (eq? 'symlink (stat:type (lstat file)))
-                                        (symlink (readlink file) target)
-                                        (copy-file file target)))))
-                            (find-files #$input))))))
-
-  (computed-file "stylized-html-manual" build))
-
 (define* (html-manual source #:key (languages %languages)
                       (version "0.0")
                       (manual %manual)
@@ -859,11 +689,9 @@ makeinfo OPTIONS."
                     (filter (compose file-exists? language->texi-file-name)
                             '#$languages)))))
 
-  (let* ((name    (string-append manual "-html-manual"))
-         (manual* (computed-file name build #:local-build? #f)))
-    (syntax-highlighted-html (stylized-html source manual*
-                                            #:languages languages
-                                            #:manual manual)
+  (let* ((name   (string-append manual "-html-manual"))
+         (manual (computed-file name build)))
+    (syntax-highlighted-html manual
                              #:mono-node-indexes mono-node-indexes
                              #:split-node-indexes split-node-indexes
                              #:name (string-append name "-highlighted"))))
@@ -886,7 +714,7 @@ makeinfo OPTIONS."
   ;; accented letters.
   ;;
   ;; (define texlive
-  ;;   (texlive-updmap.cfg (list texlive-tex-texinfo
+  ;;   (texlive-union (list texlive-tex-texinfo
   ;;                        texlive-generic-epsf
   ;;                        texlive-fonts-ec)))
 
@@ -966,8 +794,7 @@ PDF for language '~a'!~%~%"
                                 opts))))
                     '#$languages))))
 
-  (computed-file (string-append manual "-pdf-manual") build
-                 #:local-build? #f))
+  (computed-file (string-append manual "-pdf-manual") build))
 
 (define (guix-manual-text-domain source languages)
   "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
@@ -996,104 +823,6 @@ from SOURCE."
 
   (computed-file "guix-manual-po" build))
 
-(define* (localization-helper-module source
-                                     #:optional (languages %languages))
-  "Return a file-like object for use as the (localization) module.  SOURCE
-must be the Guix top-level source directory, from which PO files are taken."
-  (define content
-    (with-extensions (list guile-json-3)
-      #~(begin
-          (define-module (localization)
-            #:use-module (json)
-            #:use-module (srfi srfi-1)
-            #:use-module (srfi srfi-19)
-            #:use-module (ice-9 match)
-            #:use-module (ice-9 popen)
-            #:export (normalize
-                      with-language
-                      translate
-                      language-code->name
-                      language-code->native-name
-                      seconds->string))
-
-          (define (normalize language)            ;XXX: deduplicate
-            ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
-            (string-map (match-lambda
-                          (#\_ #\-)
-                          (chr chr))
-                        (string-downcase language)))
-
-          (define-syntax-rule (with-language language exp ...)
-            (let ((lang (getenv "LANGUAGE")))
-              (dynamic-wind
-                (lambda ()
-                  (setenv "LANGUAGE" language)
-                  (setlocale LC_MESSAGES))
-                (lambda () exp ...)
-                (lambda ()
-                  (if lang
-                      (setenv "LANGUAGE" lang)
-                      (unsetenv "LANGUAGE"))
-                  (setlocale LC_MESSAGES)))))
-
-          ;; (put 'with-language 'scheme-indent-function 1)
-          (define* (translate str language
-                              #:key (domain "guix-manual"))
-            (define exp
-              `(begin
-                 (bindtextdomain "guix-manual"
-                                 #+(guix-manual-text-domain
-                                    source
-                                    languages))
-                 (bindtextdomain "iso_639-3"      ;language names
-                                 #+(file-append iso-codes
-                                                "/share/locale"))
-                 (setenv "LANGUAGE" ,language)
-                 (write (gettext ,str ,domain))))
-
-            ;; Since the 'gettext' function caches msgid translations,
-            ;; regardless of $LANGUAGE, we have to spawn a new process each
-            ;; time we want to translate to a different language.  Bah!
-            (let* ((pipe (open-pipe* OPEN_READ
-                                     #+(file-append guile-3.0
-                                                    "/bin/guile")
-                                     "-c" (object->string exp)))
-                   (str  (read pipe)))
-              (close-pipe pipe)
-              str))
-
-          (define %iso639-languages
-            (vector->list
-             (assoc-ref (call-with-input-file
-                            #+(file-append iso-codes
-                                           "/share/iso-codes/json/iso_639-3.json")
-                          json->scm)
-                        "639-3")))
-
-          (define (language-code->name code)
-            "Return the full name of a language from its ISO-639-3 code."
-            (let ((code (match (string-index code #\_)
-                          (#f    code)
-                          (index (string-take code index)))))
-              (any (lambda (language)
-                     (and (string=? (or (assoc-ref language "alpha_2")
-                                        (assoc-ref language "alpha_3"))
-                                    code)
-                          (assoc-ref language "name")))
-                   %iso639-languages)))
-
-          (define (language-code->native-name code)
-            "Return the name of language CODE in that language."
-            (translate (language-code->name code) code
-                       #:domain "iso_639-3"))
-
-          (define (seconds->string seconds language)
-            (let* ((time (make-time time-utc 0 seconds))
-                   (date (time-utc->date time)))
-              (with-language language (date->string date "~e ~B ~Y")))))))
-
-  (scheme-file "localization.scm" content))
-
 (define* (html-manual-indexes source
                               #:key (languages %languages)
                               (version "0.0")
@@ -1103,132 +832,207 @@ must be the Guix top-level source directory, from which PO files are taken."
                                          "GNU Guix Cookbook"))
                               (date 1))
   (define build
-    (with-imported-modules `((guix build utils)
-                             ((localization)
-                              => ,(localization-helper-module
-                                   source languages)))
-      #~(begin
-          (use-modules (guix build utils)
-                       (localization)
-                       (sxml simple)
-                       (srfi srfi-1))
+    (with-extensions (list guile-json-3)
+      (with-imported-modules '((guix build utils))
+        #~(begin
+            (use-modules (guix build utils)
+                         (json)
+                         (ice-9 match)
+                         (ice-9 popen)
+                         (sxml simple)
+                         (srfi srfi-1)
+                         (srfi srfi-19))
 
-          (define (guix-url path)
-            (string-append #$%web-site-url path))
+            (define (normalize language)          ;XXX: deduplicate
+              ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
+              (string-map (match-lambda
+                            (#\_ #\-)
+                            (chr chr))
+                          (string-downcase language)))
 
-          (define (sxml-index language title body)
-            ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
-            `(html (@ (lang ,language))
-                   (head
-                    (title ,(string-append title " — GNU Guix"))
-                    (meta (@ (charset "UTF-8")))
-                    (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
-                    ;; Menu prefetch.
-                    (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
-                    ;; Base CSS.
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
+            (define-syntax-rule (with-language language exp ...)
+              (let ((lang (getenv "LANGUAGE")))
+                (dynamic-wind
+                  (lambda ()
+                    (setenv "LANGUAGE" language)
+                    (setlocale LC_MESSAGES))
+                  (lambda () exp ...)
+                  (lambda ()
+                    (if lang
+                        (setenv "LANGUAGE" lang)
+                        (unsetenv "LANGUAGE"))
+                    (setlocale LC_MESSAGES)))))
 
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
-                    (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
-                   (body
-                    (header (@ (class "navbar"))
-                            (h1 (a (@ (class "branding")
-                                      (href #$%web-site-url)))
-                                (span (@ (class "a11y-offset"))
-                                      "Guix"))
-                            (nav (@ (class "menu"))))
-                    (nav (@ (class "breadcrumbs"))
-                         (a (@ (class "crumb")
-                               (href #$%web-site-url))
-                            "Home"))
-                    ,body
-                    (footer))))
+            ;; (put 'with-language 'scheme-indent-function 1)
+            (define* (translate str language
+                                #:key (domain "guix-manual"))
+              (define exp
+                `(begin
+                   (bindtextdomain "guix-manual"
+                                   #+(guix-manual-text-domain
+                                      source
+                                      languages))
+                   (bindtextdomain "iso_639-3"    ;language names
+                                   #+(file-append iso-codes
+                                                  "/share/locale"))
+                   (write (gettext ,str ,domain))))
 
-          (define (language-index language)
-            (define title
-              (translate #$title language))
+              (with-language language
+                ;; Since the 'gettext' function caches msgid translations,
+                ;; regardless of $LANGUAGE, we have to spawn a new process each
+                ;; time we want to translate to a different language.  Bah!
+                (let* ((pipe (open-pipe* OPEN_READ
+                                         #+(file-append guile-2.2
+                                                        "/bin/guile")
+                                         "-c" (object->string exp)))
+                       (str  (read pipe)))
+                  (close-pipe pipe)
+                  str)))
 
-            (sxml-index
-             language title
-             `(main
-               (article
-                (@ (class "page centered-block limit-width"))
-                (h2 ,title)
-                (p (@ (class "post-metadata centered-text"))
-                   #$version " — "
-                   ,(seconds->string #$date language))
+            (define (seconds->string seconds language)
+              (let* ((time (make-time time-utc 0 seconds))
+                     (date (time-utc->date time)))
+                (with-language language (date->string date "~e ~B ~Y"))))
 
-                (div
-                 (ul
-                  (li (a (@ (href "html_node"))
-                         "HTML, with a separate page per node"))
-                  (li (a (@ (href
-                             ,(string-append
-                               #$manual
-                               (if (string=? language
-                                             "en")
-                                   ""
-                                   (string-append "."
-                                                  language))
-                               ".html")))
-                         "HTML, entirely on one page"))
-                  ,@(if (member language '("ru" "zh_CN"))
-                        '()
-                        `((li (a (@ (href ,(string-append
-                                            #$manual
-                                            (if (string=? language "en")
-                                                ""
-                                                (string-append "."
-                                                               language))
-                                            ".pdf"))))
-                              "PDF")))))))))
+            (define (guix-url path)
+              (string-append #$%web-site-url path))
 
-          (define (top-level-index languages)
-            (define title #$title)
-            (sxml-index
-             "en" title
-             `(main
-               (article
-                (@ (class "page centered-block limit-width"))
-                (h2 ,title)
-                (div
-                 "This document is available in the following
+            (define (sxml-index language title body)
+              ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
+              `(html (@ (lang ,language))
+                     (head
+                      (title ,(string-append title " — GNU Guix"))
+                      (meta (@ (charset "UTF-8")))
+                      (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
+                      ;; Menu prefetch.
+                      (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
+                      ;; Base CSS.
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
+
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
+                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
+                     (body
+                      (header (@ (class "navbar"))
+                              (h1 (a (@ (class "branding")
+                                        (href #$%web-site-url)))
+                                  (span (@ (class "a11y-offset"))
+                                        "Guix"))
+                              (nav (@ (class "menu"))))
+                      (nav (@ (class "breadcrumbs"))
+                           (a (@ (class "crumb")
+                                 (href #$%web-site-url))
+                              "Home"))
+                      ,body
+                      (footer))))
+
+            (define (language-index language)
+              (define title
+                (translate #$title language))
+
+              (sxml-index
+               language title
+               `(main
+                 (article
+                  (@ (class "page centered-block limit-width"))
+                  (h2 ,title)
+                  (p (@ (class "post-metadata centered-text"))
+                     #$version " — "
+                     ,(seconds->string #$date language))
+
+                  (div
+                   (ul
+                    (li (a (@ (href "html_node"))
+                           "HTML, with a separate page per node"))
+                    (li (a (@ (href
+                               ,(string-append
+                                 #$manual
+                                 (if (string=? language
+                                               "en")
+                                     ""
+                                     (string-append "."
+                                                    language))
+                                 ".html")))
+                           "HTML, entirely on one page"))
+                    ,@(if (member language '("ru" "zh_CN"))
+                          '()
+                          `((li (a (@ (href ,(string-append
+                                              #$manual
+                                              (if (string=? language "en")
+                                                  ""
+                                                  (string-append "."
+                                                                 language))
+                                              ".pdf"))))
+                                "PDF")))))))))
+
+            (define %iso639-languages
+              (vector->list
+               (assoc-ref (call-with-input-file
+                              #+(file-append iso-codes
+                                             "/share/iso-codes/json/iso_639-3.json")
+                            json->scm)
+                          "639-3")))
+
+            (define (language-code->name code)
+              "Return the full name of a language from its ISO-639-3 code."
+              (let ((code (match (string-index code #\_)
+                            (#f    code)
+                            (index (string-take code index)))))
+               (any (lambda (language)
+                      (and (string=? (or (assoc-ref language "alpha_2")
+                                         (assoc-ref language "alpha_3"))
+                                     code)
+                           (assoc-ref language "name")))
+                    %iso639-languages)))
+
+            (define (top-level-index languages)
+              (define title #$title)
+              (sxml-index
+               "en" title
+               `(main
+                 (article
+                  (@ (class "page centered-block limit-width"))
+                  (h2 ,title)
+                  (div
+                   "This document is available in the following
 languages:\n"
-                 (ul
-                  ,@(map (lambda (language)
-                           `(li (a (@ (href ,(normalize language)))
-                                   ,(language-code->native-name language))))
-                         languages)))))))
+                   (ul
+                    ,@(map (lambda (language)
+                             `(li (a (@ (href ,(normalize language)))
+                                     ,(translate
+                                       (language-code->name language)
+                                       language
+                                       #:domain "iso_639-3"))))
+                           languages)))))))
 
-          (define (write-html file sxml)
-            (call-with-output-file file
-              (lambda (port)
-                (display "<!DOCTYPE html>\n" port)
-                (sxml->xml sxml port))))
+            (define (write-html file sxml)
+              (call-with-output-file file
+                (lambda (port)
+                  (display "<!DOCTYPE html>\n" port)
+                  (sxml->xml sxml port))))
 
-          (setenv "GUIX_LOCPATH"
-                  #+(file-append glibc-utf8-locales "/lib/locale"))
-          (setenv "LC_ALL" "en_US.utf8")
-          (setlocale LC_ALL "en_US.utf8")
+            (setenv "GUIX_LOCPATH"
+                    #+(file-append glibc-utf8-locales "/lib/locale"))
+            (setenv "LC_ALL" "en_US.utf8")
+            (setlocale LC_ALL "en_US.utf8")
 
-          (for-each (lambda (language)
-                      (define directory
-                        (string-append #$output "/"
-                                       (normalize language)))
+            (for-each (lambda (language)
+                        (define directory
+                          (string-append #$output "/"
+                                         (normalize language)))
 
-                      (mkdir-p directory)
-                      (write-html (string-append directory "/index.html")
-                                  (language-index language)))
-                    '#$languages)
+                        (mkdir-p directory)
+                        (write-html (string-append directory "/index.html")
+                                    (language-index language)))
+                      '#$languages)
 
-          (write-html (string-append #$output "/index.html")
-                      (top-level-index '#$languages)))))
+            (write-html (string-append #$output "/index.html")
+                        (top-level-index '#$languages))))))
 
   (computed-file "html-indexes" build))
 

doc/contributing.texi

@@ -26,10 +26,9 @@ choice.
 * Packaging Guidelines::        Growing the distribution.
 * Coding Style::                Hygiene of the contributor.
 * Submitting Patches::          Share your work.
-* Tracking Bugs and Patches::   Keeping it all organized.
+* Tracking Bugs and Patches::   Using Debbugs.
 * Commit Access::               Pushing to the official repository.
 * Updating the Guix Package::   Updating the Guix package definition.
-* Translating Guix::            Make Guix speak your native language.
 @end menu
 
 @node Building from Git
@@ -73,10 +72,10 @@ all the dependencies and appropriate environment variables are set up to
 hack on Guix:
 
 @example
-guix shell -D guix --pure
+guix environment guix --pure
 @end example
 
-@xref{Invoking guix shell}, for more information on that command.
+@xref{Invoking guix environment}, for more information on that command.
 
 If you are unable to use Guix when building Guix from a checkout, the
 following are the required packages in addition to those mentioned in the
@@ -92,20 +91,14 @@ installation instructions (@pxref{Requirements}).
 @end itemize
 
 On Guix, extra dependencies can be added by instead running @command{guix
-shell}:
+environment} with @option{--ad-hoc}:
 
 @example
-guix shell -D guix help2man git strace --pure
+guix environment guix --pure --ad-hoc help2man git strace
 @end example
 
-From there you can generate the build system infrastructure
-using Autoconf and Automake:
-
-@example
-./bootstrap
-@end example
-
-If you get an error like this one:
+Run @command{./bootstrap} to generate the build system infrastructure
+using Autoconf and Automake.  If you get an error like this one:
 
 @example
 configure.ac:46: error: possibly undefined macro: PKG_CHECK_MODULES
@@ -126,30 +119,17 @@ export ACLOCAL_PATH=/usr/share/aclocal
 @xref{Macro Search Path,,, automake, The GNU Automake Manual}, for
 more information.
 
-Then, run:
+Then, run @command{./configure} as usual.  Make sure to pass
+@code{--localstatedir=@var{directory}} where @var{directory} is the
+@code{localstatedir} value used by your current installation (@pxref{The
+Store}, for information about this), usually @file{/var}.  Note that you
+will probably not run @command{make install} at the end (you don't have
+to) but it's still important to pass the right @code{localstatedir}.
 
-@example
-./configure --localstatedir=/var
-@end example
-
-@noindent
-... where @file{/var} is the normal @code{localstatedir} value
-(@pxref{The Store}, for information about this).  Note that you will
-probably not run @command{make install} at the end (you don't have to)
-but it's still important to pass the right @code{localstatedir}.
-
-Finally, you can build Guix and, if you feel so inclined, run the tests
-(@pxref{Running the Test Suite}):
-
-@example
-make
-make check
-@end example
-
-@noindent
-If anything fails, take a look at installation instructions
-(@pxref{Installation}) or send a message to the
-@email{guix-devel@@gnu.org, mailing list}.
+Finally, you have to invoke @code{make && make check} to build Guix and
+run the tests (@pxref{Running the Test Suite}).  If anything fails, take
+a look at installation instructions (@pxref{Installation}) or send a
+message to the @email{guix-devel@@gnu.org, mailing list}.
 
 From there on, you can authenticate all the commits included in your
 checkout by running:
@@ -176,18 +156,6 @@ You are advised to run @command{make authenticate} after every
 changes to the repository.
 @end quotation
 
-After updating the repository, @command{make} might fail with an error
-similar to the following example:
-
-@example
-error: failed to load 'gnu/packages/dunst.scm':
-ice-9/eval.scm:293:34: In procedure abi-check: #<record-type <origin>>: record ABI mismatch; recompilation needed
-@end example
-
-This means that one of the record types that Guix defines (in this
-example, the @code{origin} record) has changed, and all of guix needs
-to be recompiled to take that change into account.  To do so, run
-@command{make clean-go} followed by @command{make}.
 
 @node Running Guix Before It Is Installed
 @section Running Guix Before It Is Installed
@@ -262,24 +230,6 @@ local source tree; it simply updates the @file{~/.config/guix/current}
 symlink (@pxref{Invoking guix pull}).  Run @command{git pull} instead if
 you want to upgrade your local source tree.
 
-Sometimes, especially if you have recently updated your repository,
-running @command{./pre-inst-env} will print a message similar to the
-following example:
-
-@example
-;;; note: source file /home/user/projects/guix/guix/progress.scm
-;;;       newer than compiled /home/user/projects/guix/guix/progress.go
-@end example
-
-This is only a note and you can safely ignore it.  You can get rid of
-the message by running @command{make -j4}.  Until you do, Guile will run
-slightly slower because it will interpret the code instead of using
-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, you can run
-@samp{watchexec -w gnu/packages make -j4}.
 
 @node The Perfect Setup
 @section The Perfect Setup
@@ -291,7 +241,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 package -i emacs guile emacs-geiser emacs-geiser-guile
+guix package -i emacs guile emacs-geiser
 @end example
 
 Geiser allows for interactive and incremental development from within
@@ -425,12 +375,12 @@ Once your package builds correctly, please send us a patch
 (@pxref{Submitting Patches}).  Well, if you need help, we will be happy to
 help you too.  Once the patch is committed in the Guix repository, the
 new package automatically gets built on the supported platforms by
-@url{https://@value{SUBSTITUTE-SERVER-1}, our continuous integration system}.
+@url{@value{SUBSTITUTE-URL}, our continuous integration system}.
 
 @cindex substituter
 Users can obtain the new package definition simply by running
 @command{guix pull} (@pxref{Invoking guix pull}).  When
-@code{@value{SUBSTITUTE-SERVER-1}} is done building the package, installing the
+@code{@value{SUBSTITUTE-SERVER}} is done building the package, installing the
 package automatically downloads binaries from there
 (@pxref{Substitutes}).  The only place where human intervention is
 needed is to review and apply the patch.
@@ -581,11 +531,9 @@ It is a good idea to strip commit identifiers in the @code{version}
 field to, say, 7 digits.  It avoids an aesthetic annoyance (assuming
 aesthetics have a role to play here) as well as problems related to OS
 limits such as the maximum shebang length (127 bytes for the Linux
-kernel).  There are helper functions for doing this for packages using
-@code{git-fetch} or @code{hg-fetch} (see below).  It is best to use the
-full commit identifiers in @code{origin}s, though, to avoid ambiguities.
-A typical package definition may look like this:
-
+kernel).  It is best to use the full commit identifiers in
+@code{origin}s, though, to avoid ambiguities.  A typical package
+definition may look like this:
 
 @lisp
 (define my-package
@@ -604,20 +552,6 @@ A typical package definition may look like this:
       )))
 @end lisp
 
-@deffn {Scheme Procedure} git-version @var{VERSION} @var{REVISION} @var{COMMIT}
-Return the version string for packages using @code{git-fetch}.
-
-@lisp
-(git-version "0.2.3" "0" "93818c936ee7e2f1ba1b315578bde363a7d43d05")
-@result{} "0.2.3-0.93818c9"
-@end lisp
-@end deffn
-
-@deffn {Scheme Procedure} hg-version @var{VERSION} @var{REVISION} @var{CHANGESET}
-Return the version string for packages using @code{hg-fetch}.  It works
-in the same way as @code{git-version}.
-@end deffn
-
 @node Synopses and Descriptions
 @subsection Synopses and Descriptions
 
@@ -744,7 +678,7 @@ package typically include a @file{snippets} directory, which could be
 copied to the installation directory using:
 
 @lisp
-#:include (cons "^snippets/" %default-include)
+#:include (cons "^snippets/" %default-include))
 @end lisp
 
 When encountering problems, it is wise to check for the presence of the
@@ -1008,11 +942,17 @@ If you do not use Emacs, please make sure to let your editor knows these
 rules.  To automatically indent a package definition, you can also run:
 
 @example
-./pre-inst-env guix style @var{package}
+./etc/indent-code.el gnu/packages/@var{file}.scm @var{package}
 @end example
 
 @noindent
-@xref{Invoking guix style}, for more information.
+This automatically indents the definition of @var{package} in
+@file{gnu/packages/@var{file}.scm} by running Emacs in batch mode.  To
+indent a whole file, omit the second argument:
+
+@example
+./etc/indent-code.el gnu/services/@var{file}.scm
+@end example
 
 @cindex Vim, Scheme code editing
 If you are editing code with Vim, we recommend that you run @code{:set
@@ -1035,12 +975,9 @@ keyword parameters for procedures that take more than four parameters.
 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,, 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}).
+format-patch} sent to the @email{guix-patches@@gnu.org} mailing list.
+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
@@ -1057,15 +994,6 @@ 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
@@ -1081,10 +1009,6 @@ Run @code{guix lint @var{package}}, where @var{package} is the
 name of the new or modified package, and fix any errors it reports
 (@pxref{Invoking guix lint}).
 
-@item
-Run @code{guix style @var{package}} to format the new package definition
-according to the project's conventions (@pxref{Invoking guix style}).
-
 @item
 Make sure the package builds on your platform, using @code{guix build
 @var{package}}.
@@ -1093,21 +1017,20 @@ Make sure the package builds on your platform, using @code{guix build
 We recommend you also try building the package on other supported
 platforms.  As you may not have access to actual hardware platforms, we
 recommend using the @code{qemu-binfmt-service-type} to emulate them.  In
-order to enable it, add the @code{virtualization} service module and the
-following service to the list of services in your @code{operating-system}
-configuration:
+order to enable it, add the following service to the list of services in
+your @code{operating-system} configuration:
 
 @lisp
 (service qemu-binfmt-service-type
  (qemu-binfmt-configuration
-   (platforms (lookup-qemu-platforms "arm" "aarch64"))))
+   (platforms (lookup-qemu-platforms "arm" "aarch64"))
 @end lisp
 
 Then reconfigure your system.
 
 You can then build packages for different platforms by specifying the
 @code{--system} option.  For example, to build the "hello" package for
-the armhf or aarch64 architectures, you would run the following
+the armhf, aarch64, or mips64 architectures, you would run the following
 commands, respectively:
 @example
 guix build --system=armhf-linux --rounds=2 hello
@@ -1138,7 +1061,7 @@ and which optional dependencies should be used.  In particular, avoid adding
 the @code{texlive-tiny} package or @code{texlive-union} procedure instead.
 
 @item
-For important changes, check that dependent packages (if applicable) are
+For important changes, check that dependent package (if applicable) are
 not affected by the change; @code{guix refresh --list-dependent
 @var{package}} will help you do that (@pxref{Invoking guix refresh}).
 
@@ -1156,17 +1079,15 @@ rebuilding induced, commits go to different branches, along these lines:
 @code{staging} branch (non-disruptive changes).  This branch is intended
 to be merged in @code{master} every 6 weeks or so.  Topical changes
 (e.g., an update of the GNOME stack) can instead go to a specific branch
-(say, @code{gnome-updates}).  This branch is not expected to be
-buildable or usable until late in its development process.
+(say, @code{gnome-updates}).
 
 @item more than 1,800 dependent packages
 @code{core-updates} branch (may include major and potentially disruptive
 changes).  This branch is intended to be merged in @code{master} every
-6 months or so.  This branch is not expected to be buildable or usable
-until late in its development process.
+6 months or so.
 @end table
 
-All these branches are @uref{https://@value{SUBSTITUTE-SERVER-1},
+All these branches are @uref{@value{SUBSTITUTE-URL},
 tracked by our build farm} and merged into @code{master} once
 everything has been successfully built.  This allows us to fix issues
 before they hit users, and to reduce the window during which pre-built
@@ -1200,7 +1121,7 @@ as timestamps or randomly-generated output in the build result.
 
 Another option is to use @command{guix challenge} (@pxref{Invoking guix
 challenge}).  You may run it once the package has been committed and
-built by @code{@value{SUBSTITUTE-SERVER-1}} to check whether it obtains the same
+built by @code{@value{SUBSTITUTE-SERVER}} to check whether it obtains the same
 result as you did.  Better yet: Find another machine that can build it
 and run @command{guix publish}.  Since the remote build machine is
 likely different from yours, this can catch non-determinism issues
@@ -1222,8 +1143,8 @@ Examples of unrelated changes include the addition of several packages,
 or a package update along with fixes to that package.
 
 @item
-Please follow our code formatting rules, possibly running
-@command{guix style} script to do that automatically for you
+Please follow our code formatting rules, possibly running the
+@command{etc/indent-code.el} script to do that automatically for you
 (@pxref{Formatting Code}).
 
 @item
@@ -1256,54 +1177,14 @@ 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
-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{NNN}-done@@debbugs.gnu.org}.
 
-@node Configuring Git
-@subsection Configuring Git
-@cindex git configuration
-@cindex @code{git format-patch}
-@cindex @code{git send-email}
-
-If you have not done so already, you may wish to set a name and email
-that will be associated with your commits (@pxref{telling git your name,
-, Telling Git your name, git, Git User Manual}).  If you wish to use a
-different name or email just for commits in this repository, you can
-use @command{git config --local}, or edit @file{.git/config} in the
-repository instead of @file{~/.gitconfig}.
-
-We provide some default settings in @file{etc/git/gitconfig} which
-modify how patches are generated, making them easier to read and apply.
-These settings can be applied by manually copying them to
-@file{.git/config} in your checkout, or by telling Git to include the
-whole file:
-
-@example
-git config --local include.path ../etc/git/gitconfig
-@end example
-
-From then on, any changes to @file{etc/git/gitconfig} would
-automatically take effect.
-
-Since the first patch in a series must be sent separately
-(@pxref{Sending a Patch Series}), it can also be helpful to tell
-@command{git format-patch} to handle the e-mail threading instead of
-@command{git send-email}:
-
-@example
-git config --local format.thread shallow
-git config --local sendemail.thread no
-@end example
-
 @unnumberedsubsec Sending a Patch Series
 @anchor{Sending a Patch Series}
 @cindex patch series
 @cindex @code{git send-email}
+@cindex @code{git-send-email}
 
 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
@@ -1317,18 +1198,6 @@ for more information.  You can install @command{git send-email} with
 @node Tracking Bugs and Patches
 @section Tracking Bugs and Patches
 
-This section describes how the Guix project tracks its bug reports and
-patch submissions.
-
-@menu
-* The Issue Tracker::           The official bug and patch tracker.
-* Debbugs User Interfaces::     Ways to interact with Debbugs.
-* Debbugs Usertags::            Tag reports with custom labels.
-@end menu
-
-@node The Issue Tracker
-@subsection The Issue Tracker
-
 @cindex bug reports, tracking
 @cindex patch submissions, tracking
 @cindex issue tracking
@@ -1340,9 +1209,6 @@ email to @email{bug-guix@@gnu.org}, while patch submissions are filed
 against the @code{guix-patches} package by sending email to
 @email{guix-patches@@gnu.org} (@pxref{Submitting Patches}).
 
-@node Debbugs User Interfaces
-@subsection Debbugs User Interfaces
-
 A web interface (actually @emph{two} web interfaces!) are available to
 browse issues:
 
@@ -1380,77 +1246,12 @@ For example, to list all open issues on @code{guix-patches}, hit:
 @xref{Top,,, debbugs-ug, Debbugs User Guide}, for more information on
 this nifty tool!
 
-@node Debbugs Usertags
-@subsection Debbugs Usertags
-
-@cindex usertags, for debbugs
-@cindex Debbugs usertags
-Debbugs provides a feature called @dfn{usertags} that allows any user to
-tag any bug with an arbitrary label.  Bugs can be searched by usertag,
-so this is a handy way to organize bugs@footnote{The list of usertags is
-public information, and anyone can modify any user's list of usertags,
-so keep that in mind if you choose to use this feature.}.
-
-For example, to view all the bug reports (or patches, in the case of
-@code{guix-patches}) tagged with the usertag @code{powerpc64le-linux}
-for the user @code{guix}, open a URL like the following in a web
-browser:
-@url{https://debbugs.gnu.org/cgi-bin/pkgreport.cgi?tag=powerpc64le-linux;users=guix}.
-
-For more information on how to use usertags, please refer to the
-documentation for Debbugs or the documentation for whatever tool you use
-to interact with Debbugs.
-
-In Guix, we are experimenting with usertags to keep track of
-architecture-specific issues.  To facilitate collaboration, all our
-usertags are associated with the single user @code{guix}.  The following
-usertags currently exist for that user:
-
-@table @code
-
-@item powerpc64le-linux
-The purpose of this usertag is to make it easy to find the issues that
-matter most for the @code{powerpc64le-linux} system type.  Please assign
-this usertag to bugs or patches that affect @code{powerpc64le-linux} but
-not other system types.  In addition, you may use it to identify issues
-that for some reason are particularly important for the
-@code{powerpc64le-linux} system type, even if the issue affects other
-system types, too.
-
-@item reproducibility
-For issues related to reproducibility.  For example, it would be
-appropriate to assign this usertag to a bug report for a package that
-fails to build reproducibly.
-
-@end table
-
-If you're a committer and you want to add a usertag, just start using it
-with the @code{guix} user.  If the usertag proves useful to you,
-consider updating this section of the manual so that others will know
-what your usertag means.
-
 @node Commit Access
 @section Commit Access
 
 @cindex commit access, for developers
-Everyone can contribute to Guix without having commit access
-(@pxref{Submitting Patches}).  However, for frequent contributors,
-having write access to the repository can be convenient.  As a rule of
-thumb, a contributor should have accumulated fifty (50) reviewed commits
-to be considered as a committer and have sustained their activity in the
-project for at least 6 months.  This ensures enough interactions with
-the contributor, which is essential for mentoring and assessing whether
-they are ready to become a committer.  Commit access should not be
-thought of as a ``badge of honor'' but rather as a responsibility a
-contributor is willing to take to help the project.
-
-The following sections explain how to get commit access, how to be ready
-to push commits, and the policies and community expectations for commits
-pushed upstream.
-
-@subsection Applying for Commit Access
-
-When you deem it necessary, consider applying for commit
+For frequent contributors, having write access to the repository is
+convenient.  When you deem it necessary, consider applying for commit
 access by following these steps:
 
 @enumerate
@@ -1522,29 +1323,6 @@ review and merging system, which, as a consequence, may lead us to have
 fewer people with commit access to the main repository.  Stay tuned!
 @end quotation
 
-All commits that are pushed to the central repository on Savannah must
-be signed with an OpenPGP key, and the public key should be uploaded to
-your user account on Savannah and to public key servers, such as
-@code{keys.openpgp.org}.  To configure Git to automatically sign
-commits, run:
-
-@example
-git config commit.gpgsign true
-
-# Substitute the fingerprint of your public PGP key.
-git config user.signingkey CABBA6EA1DC0FF33
-@end example
-
-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
-
-@subsection Commit Policy
-
 If you get commit access, please make sure to follow
 the policy below (discussions of the policy can take place on
 @email{guix-devel@@gnu.org}).
@@ -1563,6 +1341,25 @@ mailing list for commit notifications (@email{guix-commits@@gnu.org}),
 so people can notice.  Before pushing your changes, make sure to run
 @code{git pull --rebase}.
 
+All commits that are pushed to the central repository on Savannah must
+be signed with an OpenPGP key, and the public key should be uploaded to
+your user account on Savannah and to public key servers, such as
+@code{keys.openpgp.org}.  To configure Git to automatically sign
+commits, run:
+
+@example
+git config commit.gpgsign true
+git config user.signingkey CABBA6EA1DC0FF33
+@end example
+
+You can prevent yourself from accidentally pushing unsigned commits to
+Savannah by using the pre-push Git hook called located at
+@file{etc/git/pre-push}:
+
+@example
+cp etc/git/pre-push .git/hooks/pre-push
+@end example
+
 When pushing a commit on behalf of somebody else, please add a
 @code{Signed-off-by} line at the end of the commit log message---e.g.,
 with @command{git am --signoff}.  This improves tracking of who did
@@ -1584,76 +1381,12 @@ you're confident, it's OK to commit.
 That last part is subject to being adjusted, allowing individuals to commit
 directly on non-controversial changes on parts they’re familiar with.
 
-@subsection Addressing Issues
-
-Peer review (@pxref{Submitting Patches}) and tools such as
-@command{guix lint} (@pxref{Invoking guix lint}) and the test suite
-(@pxref{Running the Test Suite}) should catch issues before they are
-pushed.  Yet, commits that ``break'' functionality might occasionally
-go through.  When that happens, there are two priorities: mitigating
-the impact, and understanding what happened to reduce the chance of
-similar incidents in the future.  The responsibility for both these
-things primarily lies with those involved, but like everything this is
-a group effort.
-
-Some issues can directly affect all users---for instance because they
-make @command{guix pull} fail or break core functionality, because they
-break major packages (at build time or run time), or because they
-introduce known security vulnerabilities.
-
-@cindex reverting commits
-The people involved in authoring, reviewing, and pushing such
-commit(s) should be at the forefront to mitigate their impact in a
-timely fashion: by pushing a followup commit to fix it (if possible),
-or by reverting it to leave time to come up with a proper fix, and by
-communicating with other developers about the problem.
-
-If these persons are unavailable to address the issue in time, other
-committers are entitled to revert the commit(s), explaining in the
-commit log and on the mailing list what the problem was, with the goal
-of leaving time to the original committer, reviewer(s), and author(s)
-to propose a way forward.
-
-Once the problem has been dealt with, it is the responsibility of
-those involved to make sure the situation is understood.  If you are
-working to understand what happened, focus on gathering information
-and avoid assigning any blame.  Do ask those involved to describe what
-happened, do not ask them to explain the situation---this would
-implicitly blame them, which is unhelpful.  Accountability comes from
-a consensus about the problem, learning from it and improving
-processes so that it's less likely to reoccur.
-
-@subsection Commit Revocation
-
 In order to reduce the possibility of mistakes, committers will have
 their Savannah account removed from the Guix Savannah project and their
 key removed from @file{.guix-authorizations} after 12 months of
 inactivity; they can ask to regain commit access by emailing the
 maintainers, without going through the vouching process.
 
-Maintainers@footnote{See @uref{https://guix.gnu.org/en/about} for the
-current list of maintainers.  You can email them privately at
-@email{guix-maintainers@@gnu.org}.} may also revoke an individual's
-commit rights, as a last resort, if cooperation with the rest of the
-community has caused too much friction---even within the bounds of the
-project's code of conduct (@pxref{Contributing}).  They would only do so
-after public or private discussion with the individual and a clear
-notice.  Examples of behavior that hinders cooperation and could lead to
-such a decision include:
-
-@itemize
-@item repeated violation of the commit policy stated above;
-@item repeated failure to take peer criticism into account;
-@item breaching trust through a series of grave incidents.
-@end itemize
-
-When maintainers resort to such a decision, they notify developers on
-@email{guix-devel@@gnu.org}; inquiries may be sent to
-@email{guix-maintainers@@gnu.org}.  Depending on the situation, the
-individual may still be welcome to contribute.
-
-@subsection Helping Out
-
 One last thing: the project keeps moving forward because committers not
 only push their own awesome changes, but also offer some of their time
 @emph{reviewing} and pushing other people's changes.  As a committer,
@@ -1696,266 +1429,3 @@ This check can be disabled, @emph{at your own peril}, by setting the
 @code{GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT} environment variable.  When
 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 translation
-@cindex l10n
-@cindex i18n
-@cindex native language support
-@node Translating Guix
-@section Translating Guix
-
-Writing code and packages is not the only way to provide a meaningful
-contribution to Guix.  Translating to a language you speak is another
-example of a valuable contribution you can make.  This section is designed
-to describe the translation process.  It gives you advice on how you can
-get involved, what can be translated, what mistakes you should avoid and
-what we can do to help you!
-
-Guix is a big project that has multiple components that can be translated.
-We coordinate the translation effort on a
-@uref{https://translate.fedoraproject.org/projects/guix/,Weblate instance}
-hosted by our friends at Fedora.  You will need an account to submit
-translations.
-
-Some of the software packaged in Guix also contain translations.  We do not
-host a translation platform for them.  If you want to translate a package
-provided by Guix, you should contact their developers or find the information
-on their website.  As an example, you can find the homepage of the
-@code{hello} package by typing @code{guix show hello}.  On the ``homepage''
-line, you will see @url{https://www.gnu.org/software/hello/} as the homepage.
-
-Many GNU and non-GNU packages can be translated on the
-@uref{https://translationproject.org,Translation Project}.  Some projects
-with multiple components have their own platform.  For instance, GNOME has
-its own platform, @uref{https://l10n.gnome.org/,Damned Lies}.
-
-Guix has five components hosted on Weblate.
-
-@itemize
-@item @code{guix} contains all the strings from the Guix software (the
-      guided system installer, the package manager, etc), excluding packages.
-@item @code{packages} contains the synopsis (single-sentence description
-      of a package) and description (longer description) of packages in Guix.
-@item @code{website} contains the official Guix website, except for
-      blog posts and multimedia content.
-@item @code{documentation-manual} corresponds to this manual.
-@item @code{documentation-cookbook} is the component for the cookbook.
-@end itemize
-
-@subsubheading General Directions
-
-Once you get an account, you should be able to select a component from
-@uref{https://translate.fedoraproject.org/projects/guix/,the guix project},
-and select a language.  If your language does not appear in the list, go
-to the bottom and click on the ``Start new translation'' button.  Select
-the language you want to translate to from the list, to start your new
-translation.
-
-Like lots of other free software packages, Guix uses
-@uref{https://www.gnu.org/software/gettext,GNU Gettext} for its translations,
-with which translatable strings are extracted from the source code to so-called
-PO files.
-
-Even though PO files are text files, changes should not be made with a text
-editor but with PO editing software.  Weblate integrates PO editing
-functionality.  Alternatively, translators can use any of various
-free-software tools for filling in translations, of which
-@uref{https://poedit.net/,Poedit} is one example, and (after logging in)
-@uref{https://docs.weblate.org/en/latest/user/files.html,upload} the changed
-file.  There is also a special
-@uref{https://www.emacswiki.org/emacs/PoMode,PO editing mode} for users of GNU
-Emacs.  Over time translators find out what software they are happy with and
-what features they need.
-
-On Weblate, you will find various links to the editor, that will show various
-subsets (or all) of the strings.  Have a look around and at the
-@uref{https://docs.weblate.org/en/latest/,documentation} to familiarize
-yourself with the platform.
-
-@subsubheading Translation Components
-
-In this section, we provide more detailed guidance on the translation
-process, as well as details on what you should or should not do.  When in
-doubt, please contact us, we will be happy to help!
-
-@table @asis
-@item guix
-Guix is written in the Guile programming language, and some strings contain
-special formatting that is interpreted by Guile.  These special formatting
-should be highlighted by Weblate.  They start with @code{~} followed by one
-or more characters.
-
-When printing the string, Guile replaces the special formatting symbols with
-actual values.  For instance, the string @samp{ambiguous package specification
-`~a'} would be substituted to contain said package specification instead of
-@code{~a}.  To properly translate this string, you must keep the formatting
-code in your translation, although you can place it where it makes sense in
-your language.  For instance, the French translation says @samp{spécification
-du paquet « ~a » ambiguë} because the adjective needs to be placed in the
-end of the sentence.
-
-If there are multiple formatting symbols, make sure to respect the order.
-Guile does not know in which order you intended the string to be read, so it
-will substitute the symbols in the same order as the English sentence.
-
-As an example, you cannot translate @samp{package '~a' has been superseded by
-'~a'} by @samp{'~a' superseeds package '~a'}, because the meaning would be
-reversed.  If @var{foo} is superseded by @var{bar}, the translation would read
-@samp{'foo' superseeds package 'bar'}.  To work around this problem, it
-is possible to use more advanced formatting to select a given piece of data,
-instead of following the default English order.  @xref{Formatted Output,,,
-guile, GNU Guile Reference Manual}, for more information on formatting in Guile.
-
-@item packages
-
-Package descriptions occasionally contain Texinfo markup (@pxref{Synopses
-and Descriptions}).   Texinfo markup looks like @samp{@@code@{rm -rf@}},
-@samp{@@emph@{important@}}, etc.  When translating, please leave markup as is.
-
-The characters after ``@@'' form the name of the markup, and the text between
-``@{'' and ``@}'' is its content.  In general, you should not translate the
-content of markup like @code{@@code}, as it contains literal code that do not
-change with language.  You can translate the content of formatting markup such
-as @code{@@emph}, @code{@@i}, @code{@@itemize}, @code{@@item}.  However, do
-not translate the name of the markup, or it will not be recognized.  Do
-not translate the word after @code{@@end}, it is the name of the markup that
-is closed at this position (e.g.@: @code{@@itemize ... @@end itemize}).
-
-@item documentation-manual and documentation-cookbook
-
-The first step to ensure a successful translation of the manual is to find
-and translate the following strings @emph{first}:
-
-@itemize
-@item @code{version.texi}: Translate this string as @code{version-xx.texi},
-      where @code{xx} is your language code (the one shown in the URL on
-      weblate).
-@item @code{contributing.texi}: Translate this string as
-      @code{contributing.xx.texi}, where @code{xx} is the same language code.
-@item @code{Top}: Do not translate this string, it is important for Texinfo.
-      If you translate it, the document will be empty (missing a Top node).
-      Please look for it, and register @code{Top} as its translation.
-@end itemize
-
-Translating these strings first ensure we can include your translation in
-the guix repository without breaking the make process or the
-@command{guix pull} machinery.
-
-The manual and the cookbook both use Texinfo.  As for @code{packages}, please
-keep Texinfo markup as is.  There are more possible markup types in the manual
-than in the package descriptions.  In general, do not translate the content
-of @code{@@code}, @code{@@file}, @code{@@var}, @code{@@value}, etc.  You
-should translate the content of formatting markup such as @code{@@emph},
-@code{@@i}, etc.
-
-The manual contains sections that can be referred to by name by @code{@@ref},
-@code{@@xref} and @code{@@pxref}.  We have a mechanism in place so you do
-not have to translate their content.  If you keep the English title, we will
-automatically replace it with your translation of that title.  This ensures
-that Texinfo will always be able to find the node. If you decide to change
-the translation of the title, the references will automatically be updated
-and you will not have to update them all yourself.
-
-When translating references from the cookbook to the manual, you need to
-replace the name of the manual and the name of the section.  For instance,
-to translate @code{@@pxref@{Defining Packages,,, guix, GNU Guix Reference
-Manual@}}, you would replace @code{Defining Packages} with the title of that
-section in the translated manual @emph{only} if that title is translated.
-If the title is not translated in your language yet, do not translate it here,
-or the link will be broken.  Replace @code{guix} with @code{guix.xx} where
-@code{xx} is your language code.  @code{GNU Guix Reference Manual} is the
-text of the link.  You can translate it however you wish.
-
-@item website
-
-The website pages are written using SXML, an s-expression version of HTML,
-the basic language of the web.  We have a process to extract translatable
-strings from the source, and replace complex s-expressions with a more familiar
-XML markup, where each markup is numbered.  Translators can arbitrarily change
-the ordering, as in the following example.
-
-@example
-#. TRANSLATORS: Defining Packages is a section name
-#. in the English (en) manual.
-#: apps/base/templates/about.scm:64
-msgid "Packages are <1>defined<1.1>en</1.1><1.2>Defining-Packages.html</1.2></1> as native <2>Guile</2> modules."
-msgstr "Pakete werden als reine <2>Guile</2>-Module <1>definiert<1.1>de</1.1><1.2>Pakete-definieren.html</1.2></1>."
-@end example
-
-Note that you need to include the same markups.  You cannot skip any.
-@end table
-
-In case you make a mistake, the component might fail to build properly with your
-language, or even make guix pull fail.  To prevent that, we have a process
-in place to check the content of the files before pushing to our repository.
-We will not be able to update the translation for your language in Guix, so
-we will notify you (through weblate and/or by email) so you get a chance to
-fix the issue.
-
-@subsubheading Outside of Weblate
-
-Currently, some parts of Guix cannot be translated on Weblate, help wanted!
-
-@itemize
-@item @command{guix pull} news can be translated in @file{news.scm}, but is not
-      available from Weblate.  If you want to provide a translation, you
-      can prepare a patch as described above, or simply send us your
-      translation with the name of the news entry you translated and your
-      language. @xref{Writing Channel News}, for more information about
-      channel news.
-@item Guix blog posts cannot currently be translated.
-@item The installer script (for foreign distributions) is entirely in English.
-@item Some of the libraries Guix uses cannot be translated or are translated
-      outside of the Guix project.  Guile itself is not internationalized.
-@item Other manuals linked from this manual or the cookbook might not be
-      translated.
-@end itemize
-
-@subsubheading Translation Infrastructure
-
-Weblate is backed by a git repository from which it discovers new strings to
-translate and pushes new and updated translations.  Normally, it would be
-enough to give it commit access to our repositories.  However, we decided
-to use a separate repository for two reasons.  First, we would have to give
-Weblate commit access and authorize its signing key, but we do not trust it
-in the same way we trust guix developers, especially since we do not manage
-the instance ourselves.  Second, if translators mess something up, it can
-break the generation of the website and/or guix pull for all our users,
-independently of their language.
-
-For these reasons, we use a dedicated repository to host translations, and we
-synchronize it with our guix and artworks repositories after checking no issue
-was introduced in the translation.
-
-Developers can download the latest PO files from weblate in the Guix
-repository by running the @command{make download-po} command.  It will
-automatically download the latest files from weblate, reformat them to a
-canonical form, and check they do not contain issues.  The manual needs to be
-built again to check for additional issues that might crash Texinfo.
-
-Before pushing new translation files, developers should add them to the
-make machinery so the translations are actually available.  The process
-differs for the various components.
-
-@itemize
-@item New po files for the @code{guix} and @code{packages} components must
-      be registered by adding the new language to @file{po/guix/LINGUAS} or
-      @file{po/packages/LINGUAS}.
-@item New po files for the @code{documentation-manual} component must be
-      registered by adding the file name to @code{DOC_PO_FILES} in
-      @file{po/doc/local.mk}, the generated @file{%D%/guix.xx.texi} manual to
-      @code{info_TEXINFOS} in @file{doc/local.mk} and the generated
-      @file{%D%/guix.xx.texi} and @file{%D%/contributing.xx.texi} to
-      @code{TRANSLATED_INFO} also in @file{doc/local.mk}.
-@item New po files for the @code{documentation-cookbook} component must be
-      registered by adding the file name to @code{DOC_COOKBOOK_PO_FILES} in
-      @file{po/doc/local.mk}, the generated @file{%D%/guix-cookbook.xx.texi}
-      manual to @code{info_TEXINFOS} in @file{doc/local.mk} and the generated
-      @file{%D%/guix-cookbook.xx.texi} to @code{TRANSLATED_INFO} also
-      in @file{doc/local.mk}.
-@item New po files for the @code{website} component must be added to the
-      @code{guix-artwork} repository, in @file{website/po/}.
-      @file{website/po/LINGUAS} and @file{website/po/ietf-tags.scm} must
-      be updated accordingly (see @file{website/i18n-howto.txt} for more
-      information on the process).
-@end itemize

doc/environment-gdb.scm

@@ -6,7 +6,8 @@
 ;; Augment the package definition of GDB with the build tools
 ;; needed when developing GDB (and which are not needed when
 ;; simply installing it.)
-(package
-  (inherit gdb)
-  (native-inputs (modify-inputs (package-native-inputs gdb)
-                   (prepend autoconf-2.64 automake texinfo))))
+(package (inherit gdb)
+  (native-inputs `(("autoconf" ,autoconf-2.64)
+                   ("automake" ,automake)
+                   ("texinfo" ,texinfo)
+                   ,@(package-native-inputs gdb))))

doc/guix-cookbook.texi

@@ -7,9 +7,6 @@
 @settitle GNU Guix Cookbook
 @c %**end of header
 
-@c Onion service for ci.guix.gnu.org.
-@set SUBSTITUTE-TOR-URL https://4zwzi66wwdaalbhgnix55ea3ab4pvvw66ll2ow53kjub6se4q2bclcyd.onion
-
 @copying
 Copyright @copyright{} 2019 Ricardo Wurmus@*
 Copyright @copyright{} 2019 Efraim Flashner@*
@@ -19,8 +16,7 @@ Copyright @copyright{} 2020 Matthew Brooks@*
 Copyright @copyright{} 2020 Marcin Karpezo@*
 Copyright @copyright{} 2020 Brice Waegeneire@*
 Copyright @copyright{} 2020 André Batista@*
-Copyright @copyright{} 2020 Christine Lemmer-Webber@*
-Copyright @copyright{} 2021 Joshua Branson@*
+Copyright @copyright{} 2020 Christopher Lemmer Webber
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -60,12 +56,10 @@ its API, and related concepts.
 @c TRANSLATORS: You can replace the following paragraph with information on
 @c how to join your own translation team and how to report issues with the
 @c translation.
-This manual is also available in French (@pxref{Top,,, guix-cookbook.fr,
-Livre de recettes de GNU Guix}) and German (@pxref{Top,,,
-guix-cookbook.de, GNU-Guix-Kochbuch}).  If you would like to translate
-this document in your native language, consider joining
+If you would like to translate this document in your native language, consider
+joining
 @uref{https://translate.fedoraproject.org/projects/guix/documentation-cookbook,
-Weblate} (@pxref{Translating Guix,,, guix, GNU Guix reference manual}).
+Weblate}.
 
 @menu
 * Scheme tutorials::            Meet your new favorite language!
@@ -91,8 +85,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.
+* Customizing the Kernel::      Creating and using a custom Linux kernel
+
 
 @end detailmenu
 @end menu
@@ -596,7 +590,7 @@ packages.
 Guix makes it possible to streamline the process by adding as many ``package
 declaration directories'' as you want.
 
-Create a directory, say @file{~/guix-packages} and add it to the @samp{GUIX_PACKAGE_PATH}
+Create a directory, say @file{~./guix-packages} and add it to the @samp{GUIX_PACKAGE_PATH}
 environment variable:
 
 @example
@@ -798,8 +792,10 @@ another, more sophisticated package (slightly modified from the source):
                   "17pjvprmdrx4h6bb1hhc98w9qi6ki7yl57f090n9kbhswxqfs7s3"))
                 (patches (search-patches "libgit2-mtime-0.patch"))
                 (modules '((guix build utils)))
-                ;; Remove bundled software.
-                (snippet '(delete-file-recursively "deps"))))
+                (snippet '(begin
+                            ;; Remove bundled software.
+                            (delete-file-recursively "deps")
+                            #true))))
       (build-system cmake-build-system)
       (outputs '("out" "debug"))
       (arguments
@@ -813,19 +809,23 @@ another, more sophisticated package (slightly modified from the source):
                  (("#!/bin/sh") (string-append "#!" (which "sh"))))
                (substitute* "tests/clar/fs.h"
                  (("/bin/cp") (which "cp"))
-                 (("/bin/rm") (which "rm")))))
+                 (("/bin/rm") (which "rm")))
+               #true))
            ;; Run checks more verbosely.
            (replace 'check
              (lambda _ (invoke "./libgit2_clar" "-v" "-Q")))
            (add-after 'unpack 'make-files-writable-for-tests
              (lambda _ (for-each make-file-writable (find-files "." ".*")))))))
       (inputs
-       (list libssh2 http-parser python-wrapper))
+       `(("libssh2" ,libssh2)
+         ("http-parser" ,http-parser)
+         ("python" ,python-wrapper)))
       (native-inputs
-       (list pkg-config))
+       `(("pkg-config" ,pkg-config)))
       (propagated-inputs
        ;; These two libraries are in 'Requires.private' in libgit2.pc.
-       (list openssl zlib))
+       `(("openssl" ,openssl)
+         ("zlib" ,zlib)))
       (home-page "https://libgit2.github.com/")
       (synopsis "Library providing Git core methods")
       (description
@@ -889,6 +889,22 @@ Snippets might need additional Guile modules which can be imported from the
 
 @subsubsection Inputs
 
+First, a syntactic comment: See the quasi-quote / comma syntax?
+
+@lisp
+    (native-inputs
+     `(("pkg-config" ,pkg-config)))
+@end lisp
+
+is equivalent to
+
+@lisp
+    (native-inputs
+     (list (list "pkg-config" pkg-config)))
+@end lisp
+
+You'll mostly see the former because it's shorter.
+
 There are 3 different input types.  In short:
 
 @table @asis
@@ -922,24 +938,6 @@ It also matters when a substitute is available, in which case only the @emph{inp
 and @emph{propagated inputs} will be fetched: the @emph{native inputs} are not required to
 install a package from a substitute.
 
-@quotation Note
-You may see here and there snippets where package inputs are written
-quite differently, like so:
-
-@lisp
-;; The "old style" for inputs.
-(inputs
- `(("libssh2" ,libssh2)
-   ("http-parser" ,http-parser)
-   ("python" ,python-wrapper)))
-@end lisp
-
-This is the ``old style'', where each input in the list is explicitly
-given a label (a string).  It is still supported but we recommend using
-the style above instead.  @xref{package Reference,,, guix, GNU Guix
-Reference Manual}, for more info.
-@end quotation
-
 @subsubsection Outputs
 
 Just like how a package can have multiple inputs, it can also produce multiple
@@ -1225,7 +1223,10 @@ $ guix import cran --recursive walrus
             "1nk2glcvy4hyksl5ipq2mz8jy4fss90hx6cq98m3w96kzjni6jjj"))))
     (build-system r-build-system)
     (propagated-inputs
-      (list r-ggplot2 r-jmvcore r-r6 r-wrs2))
+      `(("r-ggplot2" ,r-ggplot2)
+        ("r-jmvcore" ,r-jmvcore)
+        ("r-r6" ,r-r6)
+        ("r-wrs2" ,r-wrs2)))
     (home-page "https://github.com/jamovi/walrus")
     (synopsis "Robust Statistical Methods")
     (description
@@ -1284,7 +1285,8 @@ noticed that a significant number of them have a @code{inherit} field:
               (sha256
                (base32
                 "17fpahgh5dyckgz7rwqvzgnhx53cx9kr2xw0szprc6bnqy977fi8"))))
-    (native-inputs (list `(,gtk+ "bin")))))
+    (native-inputs
+     `(("gtk-encode-symbolic-svg" ,gtk+ "bin")))))
 @end lisp
 
 All unspecified fields are inherited from the parent package.  This is very
@@ -1351,7 +1353,6 @@ chapter is to demonstrate some advanced configuration concepts.
 reference.
 
 @menu
-* 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.
 * Connecting to Wireguard VPN::  Connecting to a Wireguard VPN.
@@ -1362,51 +1363,6 @@ reference.
 * Setting up NGINX with Lua:: Configuring NGINX web-server to load Lua modules.
 @end menu
 
-@node Auto-Login to a Specific TTY
-@section Auto-Login to a Specific TTY
-
-While the Guix manual explains auto-login one user to @emph{all} TTYs (
-@pxref{auto-login to TTY,,, guix, GNU Guix Reference Manual}), some
-might prefer a situation, in which one user is logged into one TTY with
-the other TTYs either configured to login different users or no one at
-all.  Note that one can auto-login one user to any TTY, but it is
-usually advisable to avoid @code{tty1}, which, by default, is used to
-log warnings and errors.
-
-Here is how one might set up auto login for one user to one tty:
-
-@lisp
-(define (auto-login-to-tty config tty user)
-  (if (string=? tty (mingetty-configuration-tty config))
-        (mingetty-configuration
-         (inherit config)
-         (auto-login user))
-        config))
-
-(define %my-services
-  (modify-services %base-services
-    ;; @dots{}
-    (mingetty-service-type config =>
-                           (auto-login-to-tty
-                            config "tty3" "alice"))))
-
-(operating-system
-  ;; @dots{}
-  (services %my-services))
-@end lisp
-
-One could also @code{compose} (@pxref{Higher-Order Functions,,, guile,
-The Guile Reference Manual}) @code{auto-login-to-tty} to login multiple
-users to multiple ttys.
-
-Finally, here is a note of caution.  Setting up auto login to a TTY,
-means that anyone can turn on your computer and run commands as your
-regular user.
-However, if you have an encrypted root partition, and thus already need
-to enter a passphrase when the system boots, auto-login might be a
-convenient option.
-
-
 @node Customizing the Kernel
 @section Customizing the Kernel
 
@@ -1433,34 +1389,37 @@ The @code{linux-libre} kernel package definition is actually a procedure which
 creates a package.
 
 @lisp
-(define* (make-linux-libre* version gnu-revision source supported-systems
-                            #:key
-                            (extra-version #f)
-                            ;; A function that takes an arch and a variant.
-                            ;; See kernel-config for an example.
-                            (configuration-file #f)
-                            (defconfig "defconfig")
-                            (extra-options %default-extra-linux-options))
+(define* (make-linux-libre version hash supported-systems
+                           #:key
+                           ;; A function that takes an arch and a variant.
+                           ;; See kernel-config for an example.
+                           (extra-version #false)
+                           (configuration-file #false)
+                           (defconfig "defconfig")
+                           (extra-options %default-extra-linux-options)
+                           (patches (list %boot-logo-patch)))
   ...)
 @end lisp
 
-The current @code{linux-libre} package is for the 5.15.x series, and is
+The current @code{linux-libre} package is for the 5.1.x series, and is
 declared like this:
 
 @lisp
-(define-public linux-libre-5.15
-  (make-linux-libre* linux-libre-5.15-version
-                     linux-libre-5.15-gnu-revision
-                     linux-libre-5.15-source
-                     '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "riscv64-linux")
-                     #:configuration-file kernel-config))
+(define-public linux-libre
+  (make-linux-libre %linux-libre-version
+                    %linux-libre-hash
+                    '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux")
+                    #:patches %linux-libre-5.1-patches
+                    #:configuration-file kernel-config))
 @end lisp
 
 Any keys which are not assigned values inherit their default value from the
 @code{make-linux-libre} definition.  When comparing the two snippets above,
-notice the code comment that refers to @code{#:configuration-file}.  Because of
-this, it is not actually easy to include a custom kernel configuration from the
-definition, but don't worry, there are other ways to work with what we do have.
+you may notice that the code comment in the first doesn't actually refer to
+the @code{#:extra-version} keyword; it is actually for
+@code{#:configuration-file}.  Because of this, it is not actually easy to
+include a custom kernel configuration from the definition, but don't worry,
+there are other ways to work with what we do have.
 
 There are two ways to create a kernel with a custom kernel configuration.  The
 first is to provide a standard @file{.config} file during the build process by
@@ -1560,15 +1519,14 @@ custom kernel:
           (@@@@ (gnu packages linux) %default-extra-linux-options)))
 
 (define-public linux-libre-macbook41
-  ;; XXX: Access the internal 'make-linux-libre*' procedure, which is
+  ;; XXX: Access the internal 'make-linux-libre' procedure, which is
   ;; private and unexported, and is liable to change in the future.
-  ((@@@@ (gnu packages linux) make-linux-libre*)
-   (@@@@ (gnu packages linux) linux-libre-version)
-   (@@@@ (gnu packages linux) linux-libre-gnu-revision)
-   (@@@@ (gnu packages linux) linux-libre-source)
-   '("x86_64-linux")
-   #:extra-version "macbook41"
-   #:extra-options %macbook41-config-options))
+  ((@@@@ (gnu packages linux) make-linux-libre) (@@@@ (gnu packages linux) %linux-libre-version)
+                      (@@@@ (gnu packages linux) %linux-libre-hash)
+                      '("x86_64-linux")
+                      #:extra-version "macbook41"
+                      #:patches (@@@@ (gnu packages linux) %linux-libre-5.1-patches)
+                      #:extra-options %macbook41-config-options))
 @end lisp
 
 In the above example @code{%file-systems} is a collection of flags enabling
@@ -1713,7 +1671,7 @@ operating-system dedicated to the @b{Pine A64 LTS} board.
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader u-boot-pine64-lts-bootloader)
-                (targets '("/dev/vda"))))
+                (target "/dev/vda")))
    (initrd-modules '())
    (kernel linux-libre-arm64-generic)
    (file-systems (cons (file-system
@@ -2045,12 +2003,10 @@ Copy into it the output of:
 cat ~/.ssh/<username>_rsa.pub
 @end example
 
-Power the Linode down.
-
-In the Linode's Storage tab, resize the Debian disk to be smaller.
-30 GB free space is recommended.  Then click "Add a disk", and fill
-out the form with the following:
+Power the Linode down. In the Linode's Disks/Configurations tab, resize
+the Debian disk to be smaller. 30 GB is recommended.
 
+In the Linode settings, "Add a disk", with the following:
 @itemize @bullet
 @item
 Label: "Guix"
@@ -2062,9 +2018,9 @@ Filesystem: ext4
 Set it to the remaining size
 @end itemize
 
-In the Configurations tab, press "Edit" on the default Debian profile.
-Under "Block Device Assignment" click "Add a Device". It should be
-@file{/dev/sdc} and you can select the "Guix" disk. Save Changes.
+On the "configuration" field that comes with the default image, press
+"..." and select "Edit", then on that menu add to @file{/dev/sdc} the "Guix"
+label.
 
 Now "Add a Configuration", with the following:
 @itemize @bullet
@@ -2090,8 +2046,8 @@ Root device: @file{/dev/sda}
 Turn off all the filesystem/boot helpers
 @end itemize
 
-Now power it back up, booting with the Debian configuration.  Once it's
-running, ssh to your server via @code{ssh
+Now power it back up, picking the Debian configuration.  Once it's
+booted up, ssh in your server via @code{ssh
 root@@@var{<your-server-IP-here>}}. (You can find your server IP address in
 your Linode Summary section.) Now you can run the "install guix from
 @pxref{Binary Installation,,, guix, GNU Guix}" steps:
@@ -2180,20 +2136,19 @@ Replace the following fields in the above configuration:
 @end lisp
 
 The last line in the above example lets you log into the server as root
-and set the initial root password (see the note at the end of this
-recipe about root login).  After you have done this, you may
+and set the initial root password.  After you have done this, you may
 delete that line from your configuration and reconfigure to prevent root
 login.
 
-Copy your ssh public key (eg: @file{~/.ssh/id_rsa.pub}) as
-@file{@var{<your-username-here>}_rsa.pub} and put
+Save your ssh public key (eg: @file{~/.ssh/id_rsa.pub}) as
+@file{@var{<your-username-here>}_rsa.pub} and your
 @file{guix-config.scm} in the same directory.  In a new terminal run
 these commands.
 
 @example
 sftp root@@<remote server ip address>
-put /path/to/files/<username>_rsa.pub .
-put /path/to/files/guix-config.scm .
+put /home/<username>/ssh/id_rsa.pub .
+put /path/to/linode/guix-config.scm .
 @end example
 
 In your first terminal, mount the guix drive:
@@ -2203,9 +2158,9 @@ mkdir /mnt/guix
 mount /dev/sdc /mnt/guix
 @end example
 
-Due to the way we set up the bootloader section of the guix-config.scm,
-only the grub configuration file will be installed.  So, we need to copy
-over some of the other GRUB stuff already installed on the Debian system:
+Due to the way we set things up above, we do not install GRUB
+completely.  Instead we install only our grub configuration file.  So we
+need to copy over some of the other GRUB stuff that is already there:
 
 @example
 mkdir -p /mnt/guix/boot/grub
@@ -2258,7 +2213,7 @@ still need to set your root and user password initially by clicking on
 the ``Launch Console'' option in your linode.  Choose the ``Glish''
 instead of ``Weblish''.  Now you should be able to ssh into the machine.
 
-Hooray!  At this point you can shut down the server, delete the
+Horray!  At this point you can shut down the server, delete the
 Debian disk, and resize the Guix to the rest of the size.
 Congratulations!
 
@@ -2357,8 +2312,7 @@ follow:
           config => (guix-configuration
                       (inherit config)
                       ;; ci.guix.gnu.org's Onion service
-                      (substitute-urls
-                       "@value{SUBSTITUTE-TOR-URL}")
+                      (substitute-urls "https://bp7o7ckwlewr4slm.onion")
                       (http-proxy "http://localhost:9250")))))))
 @end lisp
 
@@ -2376,8 +2330,7 @@ want to get a substitute from the Tor tunnel run:
 
 @example
 sudo herd set-http-proxy guix-daemon http://localhost:9250
-guix build \
-  --substitute-urls=@value{SUBSTITUTE-TOR-URL} @dots{}
+guix build --substitute-urls=https://bp7o7ckwlewr4slm.onion …
 @end example
 
 @node Setting up NGINX with Lua

doc/he-config-bare-bones.scm

@@ -1,24 +0,0 @@
-(use-modules (gnu home)
-             (gnu home services)
-             (gnu home services shells)
-             (gnu services)
-             (gnu packages admin)
-             (guix gexp))
-
-
-(home-environment
- (packages (list htop))
- (services
-  (list
-   (service home-bash-service-type
-            (home-bash-configuration
-             (guix-defaults? #t)
-             (bash-profile '("\
-export HISTFILE=$XDG_CACHE_HOME/.bash_history"))))
-
-   (simple-service 'test-config
-                   home-files-service-type
-                   (list `("config/test.conf"
-                           ,(plain-file "tmp-file.txt"
-                                        "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=2021-09-24.23; # UTC
+htmlxrefversion=2020-01-11.22; # UTC
 
-# Copyright 2010-2020 Free Software Foundation, Inc.
+# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2019, 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
@@ -110,10 +110,6 @@ cpio		node	${GS}/cpio/manual/html_node/
 
 cssc		node	${GS}/cssc/manual/
 
-CUIRASS = ${GS}/guix/cuirass/manual
- cuirass	mono	${CUIRASS}/cuirass.html
- cuirass	node	${CUIRASS}/html_node/
-
 CVS = ${GS}/trans-coord/manual
 cvs            mono    ${CVS}/cvs/cvs.html
 cvs            node    ${CVS}/cvs/html_node/
@@ -122,8 +118,6 @@ ddd		mono	${GS}/ddd/manual/html_mono/ddd.html
 
 ddrescue	mono	${GS}/ddrescue/manual/ddrescue_manual.html
 
-dejagnu         node    ${GS}/dejagnu/manual/
-
 DICO = https://puszcza.gnu.org.ua/software/dico/manual
 dico		mono	${DICO}/dico.html
 dico		chapter	${DICO}/html_chapter/
@@ -133,9 +127,6 @@ dico		node	${DICO}/html_node/
 diffutils	mono	${GS}/diffutils/manual/diffutils
 diffutils	node	${GS}/diffutils/manual/html_node/
 
-dmd		mono	${GS}/dmd/manual/dmd
-dmd		node	${GS}/dmd/manual/html_node/
-
 ed		mono	${GS}/ed/manual/ed_manual.html
 
 EMACS = ${GS}/emacs/manual
@@ -190,9 +181,6 @@ emacs		node	${EMACS}/html_node/emacs/
  idlwave	mono	${EMACS}/html_mono/idlwave.html
  idlwave	node	${EMACS}/html_node/idlwave/
  #
- info   	mono	${EMACS}/html_mono/info.html
- info   	node	${EMACS}/html_node/info/
- #
  message	mono	${EMACS}/html_mono/message.html
  message	node	${EMACS}/html_node/message/
  #
@@ -271,7 +259,7 @@ gcc		node	${GCC}/gcc/
  gcj		node	${GCC}/gcj/
  gfortran	node	${GCC}/gfortran/
  gnat_rm	node	${GCC}/gnat_rm/
- gnat_ugn	node	${GCC}/gnat_ugn/
+ gnat_ugn_unw	node	${GCC}/gnat_ugn_unw/
  libgomp	node	${GCC}/libgomp/
  libstdc++	node	${GCC}/libstdc++/
  #
@@ -300,11 +288,6 @@ gettext		node	${GS}/gettext/manual/html_node/
 
 gforth		node	https://www.complang.tuwien.ac.at/forth/gforth/Docs-html/
 
-# Also found at:
-# https://mirrors.edge.kernel.org/pub/software/scm/git/docs/user-manual.html
-# https://git.github.io/htmldocs/user-manual.html
-git		mono	https://git-scm.com/docs/user-manual
-
 global		mono	${GS}/global/manual/global.html
 
 gmediaserver	node	${GS}/gmediaserver/manual/
@@ -352,8 +335,8 @@ GNUSTANDARDS = ${G}/prep
  standards	mono	${GNUSTANDARDS}/standards/standards.html
  standards	node	${GNUSTANDARDS}/standards/html_node/
 
-gnutls		mono	${GS}/gnutls/manual/gnutls.html
-gnutls		node	${GS}/gnutls/manual/html_node/
+gnutls		mono	http://gnutls.org/manual/gnutls.html
+gnutls		node	http://gnutls.org/manual/html_node/
 
 gnutls-guile	mono	http://gnutls.org/manual/gnutls-guile.html
 gnutls-guile	node	http://gnutls.org/manual/gnutls-guile/
@@ -414,27 +397,18 @@ guile-gtk	node	${GS}/guile-gtk/docs/guile-gtk/
 guile-rpc	mono	${GS}/guile-rpc/manual/guile-rpc.html
 guile-rpc	node	${GS}/guile-rpc/manual/html_node/
 
-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.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
- guix.zh_CN	node	${GUIX}/zh-cn/html_node/
- guix		mono	${GUIX}/en/guix.html
- guix		node	${GUIX}/en/html_node/
-
-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.html
- guix-cookbook.fr	node    ${GUIX_COOKBOOK}/fr/html_node/
- guix-cookbook		mono    ${GUIX_COOKBOOK}/en/guix-cookbook.html
- guix-cookbook		node	${GUIX_COOKBOOK}/en/html_node/
+guix.de		mono	${GS}/guix/manual/de/guix.de.html
+guix.de		node	${GS}/guix/manual/de/html_node/
+guix.es		mono	${GS}/guix/manual/es/guix.es.html
+guix.es		node	${GS}/guix/manual/es/html_node/
+guix.fr		mono	${GS}/guix/manual/fr/guix.fr.html
+guix.fr		node	${GS}/guix/manual/fr/html_node/
+guix.ru		mono	${GS}/guix/manual/ru/guix.ru.html
+guix.ru		node	${GS}/guix/manual/ru/html_node/
+guix.zh_CN	mono	${GS}/guix/manual/zh-cn/guix.zh_CN.html
+guix.zh_CN	node	${GS}/guix/manual/zh-cn/html_node/
+guix		mono	${GS}/guix/manual/en/guix.html
+guix		node	${GS}/guix/manual/en/html_node/
 
 gv		mono	${GS}/gv/manual/gv.html
 gv		node	${GS}/gv/manual/html_node/
@@ -529,21 +503,18 @@ mcron		node	${GS}/mcron/manual/html_node/
 mdk		mono	${GS}/mdk/manual/mdk.html
 mdk		node	${GS}/mdk/manual/html_node/
 
-METAEXCHANGE = https://ftp.gwdg.de/pub/gnu2/iwfmdh/doc/texinfo
+METAEXCHANGE = http://ftp.gwdg.de/pub/gnu2/iwfmdh/doc/texinfo
  iwf_mh		node	${METAEXCHANGE}/iwf_mh.html
  scantest	node	${METAEXCHANGE}/scantest.html
 
 mes		mono	${GS}/mes/manual/mes.html
 mes		node	${GS}/mes/manual/html_node/
 
-MIT_SCHEME = ${GS}/mit-scheme/documentation/stable
- mit-scheme-ref	  mono	${MIT_SCHEME}/mit-scheme-ref.html
+MIT_SCHEME = ${GS}/mit-scheme/documentation
  mit-scheme-ref	  node	${MIT_SCHEME}/mit-scheme-ref/
- mit-scheme-user  mono	${MIT_SCHEME}/mit-scheme-user.html
  mit-scheme-user  node	${MIT_SCHEME}/mit-scheme-user/
- sos		  mono	${MIT_SCHEME}/mit-scheme-sos.html
  sos		  node	${MIT_SCHEME}/mit-scheme-sos/
- mit-scheme-imail mono	${MIT_SCHEME}/mit-scheme-imail.html
+ mit-scheme-imail node	${MIT_SCHEME}/mit-scheme-imail/
 
 moe		mono	${GS}/moe/manual/moe_manual.html
 
@@ -601,7 +572,7 @@ R = https://cran.r-project.org/doc/manuals
 rcs		mono	${GS}/rcs/manual/rcs.html
 rcs		node	${GS}/rcs/manual/html_node/
 
-READLINE = https://tiswww.cwru.edu/php/chet/readline
+READLINE = http://cnswww.cns.cwru.edu/php/chet/readline
 readline        mono    ${READLINE}/readline.html
  rluserman      mono    ${READLINE}/rluserman.html
  history        mono    ${READLINE}/history.html
@@ -658,7 +629,7 @@ swbis		mono	${GS}/swbis/manual.html
 tar		mono	${GS}/tar/manual/tar.html
 tar		chapter	${GS}/tar/manual/html_chapter/
 tar		section	${GS}/tar/manual/html_section/
-tar		node	${GS}/tar/manual/html_node/
+tar		node	${GS}/autoconf/manual/html_node/
 
 teseq		mono	${GS}/teseq/teseq.html
 teseq		node	${GS}/teseq/html_node/
@@ -666,6 +637,9 @@ teseq		node	${GS}/teseq/html_node/
 TEXINFO = ${GS}/texinfo/manual
 texinfo		mono	${TEXINFO}/texinfo/texinfo.html
 texinfo		node	${TEXINFO}/texinfo/html_node/
+ #
+ info		mono	${TEXINFO}/info/info.html
+ info		node	${TEXINFO}/info/html_node/
  #
  info-stnd	mono	${TEXINFO}/info-stnd/info-stnd.html
  info-stnd	node	${TEXINFO}/info-stnd/html_node/

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 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
+MANUAL_LANGUAGES = de es fa fr it ko pt_BR ru sk zh_CN
+COOKBOOK_LANGUAGES = de fa fr ko zh_Hans
 
 # Arg1: A list of languages codes.
 # Arg2: The file name stem.
@@ -35,7 +35,6 @@ 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				\
@@ -45,15 +44,9 @@ info_TEXINFOS = %D%/guix.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.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 = \
@@ -85,8 +78,7 @@ EXTRA_DIST +=					\
 OS_CONFIG_EXAMPLES_TEXI =			\
   %D%/os-config-bare-bones.texi			\
   %D%/os-config-desktop.texi			\
-  %D%/os-config-lightweight-desktop.texi	\
-  %D%/he-config-bare-bones.scm
+  %D%/os-config-lightweight-desktop.texi
 
 TRANSLATED_INFO = 						\
   $(call lang_to_texinfo,$(MANUAL_LANGUAGES),guix)		\
@@ -103,31 +95,46 @@ PO4A_PARAMS += -k 0 # produce an output even if the translation is not complete
 PO4A_PARAMS += -f texinfo # texinfo format
 
 # When a change to guix.texi occurs, it is not translated immediately.
-# Because @pxref and @xref commands are references to sections by name, they
+# Because @pxref and @xref commands are reference to a section by name, they
 # should be translated. If a modification adds a reference to a section, this
 # reference is not translated, which means it references a section that does not
 # exist.
+# This command loops through the translated files looking for references. For
+# each of these references, it tries to find the translation and replaces the
+# reference name, even in untranslated strings.
+# The last sed is a multiline sed because some references span multiple lines.
 define xref_command
-$(top_srcdir)/pre-inst-env $(GUILE) --no-auto-compile	\
-  "$(top_srcdir)/build-aux/convert-xref.scm"		\
-  $@.tmp $<
+cat "$@.tmp" | egrep '@p?x?ref' -A1 | sed 'N;s|--\n||g;P;D' | sed 's|^| |g' | \
+        tr -d '\012' | sed 's|\(@p\?x\?ref\)|\n\1|g' | egrep '@p?x?ref' | \
+        sed 's|^.*@p\?x\?ref{\([^,}]*\).*$$|\1|g' | sort | uniq | while read e; do \
+    if [ -n "$$e" ]; then \
+      line=$$(grep -n "^msgid \"$$e\"" "$<" | cut -f1 --delimiter=":") ;\
+      ((line++)) ;\
+      if [ "$$line" != "1" ]; then \
+	translation=$$(head -n "$$line" "$<" | tail -1 | grep msgstr | sed 's|msgstr "\([^"]*\)"|\1|') ;\
+	if [ "$$translation" != "" ]; then \
+	      sed "N;s@\(p\?x\?ref\){$$(echo $$e | sed 's| |[\\n ]|g')\(,\|}\)@\1{$$translation\2@g;P;D" -i "$@.tmp" ;\
+	fi ;\
+      fi ;\
+   fi ;\
+done
 endef
 
-$(srcdir)/%D%/guix.%.texi: po/doc/guix-manual.%.po $(srcdir)/%D%/contributing.%.texi guix/build/po.go
+$(srcdir)/%D%/guix.%.texi: po/doc/guix-manual.%.po $(srcdir)/%D%/contributing.%.texi
 	-$(AM_V_PO4A)$(PO4A_TRANSLATE) $(PO4A_PARAMS) -m "%D%/guix.texi" -p "$<" -l "$@.tmp"
 	-sed -i "s|guix\.info|$$(basename "$@" | sed 's|texi$$|info|')|" "$@.tmp"
-	-$(AM_V_POXREF)LC_ALL=en_US.UTF-8 $(xref_command)
+	-$(AM_V_POXREF)$(xref_command)
 	-mv "$@.tmp" "$@"
 
-$(srcdir)/%D%/guix-cookbook.%.texi: po/doc/guix-cookbook.%.po guix/build/po.go
+$(srcdir)/%D%/guix-cookbook.%.texi: po/doc/guix-cookbook.%.po
 	-$(AM_V_PO4A)$(PO4A_TRANSLATE) $(PO4A_PARAMS) -m "%D%/guix-cookbook.texi" -p "$<" -l "$@.tmp"
 	-sed -i "s|guix-cookbook\.info|$$(basename "$@" | sed 's|texi$$|info|')|" "$@.tmp"
-	-$(AM_V_POXREF)LC_ALL=en_US.UTF-8 $(xref_command)
+	-$(AM_V_POXREF)$(xref_command)
 	-mv "$@.tmp" "$@"
 
-$(srcdir)/%D%/contributing.%.texi: po/doc/guix-manual.%.po guix/build/po.go
+$(srcdir)/%D%/contributing.%.texi: po/doc/guix-manual.%.po
 	-$(AM_V_PO4A)$(PO4A_TRANSLATE) $(PO4A_PARAMS) -m "%D%/contributing.texi" -p "$<" -l "$@.tmp"
-	-$(AM_V_POXREF)LC_ALL=en_US.UTF-8 $(xref_command)
+	-$(AM_V_POXREF)$(xref_command)
 	-mv "$@.tmp" "$@"
 
 %D%/os-config-%.texi: gnu/system/examples/%.tmpl

etc/committer.scm.in

@@ -4,8 +4,6 @@
 
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,43 +36,7 @@
         (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.
-Return a single string."
-  (define (restore-line words)
-    (string-join (reverse words) " "))
-  (if (<= (string-length str) max-line-length)
-      str
-      (let ((words+lengths (map (lambda (word)
-                                  (cons word (string-length word)))
-                                (string-tokenize str))))
-        (match (fold (match-lambda*
-                       (((word . length)
-                         (count current lines))
-                        (let ((new-count (+ count length 1)))
-                          (if (< new-count max-line-length)
-                              (list new-count
-                                    (cons word current)
-                                    lines)
-                              (list length
-                                    (list word)
-                                    (cons (restore-line current) lines))))))
-                     '(0 () ())
-                     words+lengths)
-          ((_ last-words lines)
-           (string-join (reverse (cons (restore-line last-words) lines))
-                        "\n"))))))
-
-(define* (break-string-with-newlines str #:optional (max-line-length 70))
-  "Break the lines of string STR into lines that are no longer than
-MAX-LINE-LENGTH. Return a single string."
-  (string-join (map (cut break-string <> max-line-length)
-                    (string-split str #\newline))
-               "\n"))
+        (ice-9 textual-ports))
 
 (define (read-excursion port)
   "Read an expression from PORT and reset the port position before returning
@@ -215,12 +177,7 @@ corresponding to the top-level definition containing the staged changes."
   "Print ChangeLog commit message for changes between OLD and NEW."
   (define (get-values expr field)
     (match ((sxpath `(// ,field quasiquote *)) expr)
-      (()
-       ;; New-style plain lists
-       (match ((sxpath `(// ,field list *)) expr)
-         ((inner) inner)
-         (_ '())))
-      ;; Old-style labelled inputs
+      (() '())
       ((first . rest)
        (map cadadr first))))
   (define (listify items)
@@ -247,19 +204,18 @@ corresponding to the top-level definition containing the staged changes."
                           (added (lset-difference equal? new-values old-values)))
                       (format port
                               "[~a]: ~a~%" field
-                              (break-string
-                               (match (list (map symbol->string removed)
-                                            (map symbol->string added))
-                                 ((() added)
-                                  (format #f "Add ~a."
-                                          (listify added)))
-                                 ((removed ())
-                                  (format #f "Remove ~a."
-                                          (listify removed)))
-                                 ((removed added)
-                                  (format #f "Remove ~a; add ~a."
-                                          (listify removed)
-                                          (listify added))))))))))
+                              (match (list (map symbol->string removed)
+                                           (map symbol->string added))
+                                ((() added)
+                                 (format #f "Add ~a."
+                                         (listify added)))
+                                ((removed ())
+                                 (format #f "Remove ~a."
+                                         (listify removed)))
+                                ((removed added)
+                                 (format #f "Remove ~a; add ~a."
+                                         (listify removed)
+                                         (listify added)))))))))
             '(inputs propagated-inputs native-inputs)))
 
 (define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
@@ -268,41 +224,6 @@ corresponding to the top-level definition containing the staged changes."
           "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
           variable-name file-name variable-name))
 
-(define* (custom-commit-message file-name variable-name message changelog
-                                #:optional (port (current-output-port)))
-  "Print custom commit message for a change to VARIABLE-NAME in FILE-NAME, using
-MESSAGE as the commit message and CHANGELOG as the body of the ChangeLog
-entry. If CHANGELOG is #f, the commit message is reused. If CHANGELOG already
-contains ': ', no colon is inserted between the location and body of the
-ChangeLog entry."
-  (define (trim msg)
-    (string-trim-right (string-trim-both msg) (char-set #\.)))
-
-  (define (changelog-has-location? changelog)
-    (->bool (string-match "^[[:graph:]]+:[[:blank:]]" changelog)))
-
-  (let* ((message (trim message))
-         (changelog (if changelog (trim changelog) message))
-         (message/f (format #f "gnu: ~a: ~a." variable-name message))
-         (changelog/f (if (changelog-has-location? changelog)
-                          (format #f "* ~a (~a)~a."
-                                  file-name variable-name changelog)
-                          (format #f "* ~a (~a): ~a."
-                                  file-name variable-name changelog))))
-    (format port
-            "~a~%~%~a~%"
-            (break-string-with-newlines message/f 72)
-            (break-string-with-newlines changelog/f 72))))
-
-(define (add-copyright-line line)
-  "Add the copyright line on LINE to the previous commit."
-  (let ((author (match:substring
-                 (string-match "^\\+;;; Copyright ©[^[:alpha:]]+(.*)$" line)
-                 1)))
-    (format
-     (current-output-port) "Amend and add copyright line for ~a~%" author)
-    (system* "git" "commit" "--amend" "--no-edit")))
-
 (define (group-hunks-by-sexp hunks)
   "Return a list of pairs associating all hunks with the S-expression they are
 modifying."
@@ -331,15 +252,6 @@ modifying."
 (define %delay 1000)
 
 (define (main . args)
-  (define* (change-commit-message* file-name old new #:rest rest)
-    (let ((changelog #f))
-      (match args
-        ((or (message changelog) (message))
-         (apply custom-commit-message
-                file-name (second old) message changelog rest))
-        (_
-         (apply change-commit-message file-name old new rest)))))
-
   (match (diff-info)
     (()
      (display "Nothing to be done.\n" (current-error-port)))
@@ -385,25 +297,18 @@ modifying."
                                     (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)
+                    (change-commit-message (hunk-file-name (first hunks))
+                                           old new
+                                           (current-output-port))
+                    (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
+                      (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")))))))
+                        (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)))
+(main)

etc/completion/bash/guix

@@ -1,6 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org>
-# Copyright © 2021 Tobias Geerinck-Rice <me@tobias.gr>
+# Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -28,12 +27,11 @@ _guix_complete_command ()
     if [ -z "$_guix_commands" ]
     then
 	# Cache the list of commands to speed things up.
-	_guix_commands="$(${COMP_WORDS[0]} --help 2> /dev/null  \
+	_guix_commands="$(guix --help 2> /dev/null  \
                                      | grep '^    ' \
 				     | sed '-es/^ *\([a-z-]\+\).*$/\1/g')"
     fi
-
-    COMPREPLY+=($(compgen -W "$_guix_commands" -- "$word_at_point"))
+    COMPREPLY=($(compgen -W "$_guix_commands" -- "$word_at_point"))
 }
 
 _guix_complete_subcommand ()
@@ -42,7 +40,7 @@ _guix_complete_subcommand ()
     local subcommands="$(${COMP_WORDS[0]} $command --help 2> /dev/null \
                          | grep '^   [a-z]' \
                          | sed -e's/^ \+\([a-z-]\+\).*$/\1/g')"
-    COMPREPLY+=($(compgen -W "$subcommands" -- "${COMP_WORDS[$COMP_CWORD]}"))
+    COMPREPLY=($(compgen -W "$subcommands" -- "${COMP_WORDS[$COMP_CWORD]}"))
 }
 
 _guix_complete_available_package ()
@@ -55,7 +53,7 @@ _guix_complete_available_package ()
 	_guix_available_packages="$(${COMP_WORDS[0]} package -A 2> /dev/null \
                                     | cut -f1)"
     fi
-    COMPREPLY+=($(compgen -W "$_guix_available_packages" -- "$prefix"))
+    COMPREPLY=($(compgen -W "$_guix_available_packages" -- "$prefix"))
 }
 
 _guix_complete_installed_package ()
@@ -65,40 +63,36 @@ _guix_complete_installed_package ()
     local prefix="$1"
     local packages="$(${COMP_WORDS[0]} package -I "^$prefix" 2> /dev/null \
                       | cut -f1)"
-    COMPREPLY+=($(compgen -W "$packages" -- "$prefix"))
+    COMPREPLY=($(compgen -W "$packages" -- "$prefix"))
 }
 
 _guix_complete_option ()
 {
-    local command="${COMP_WORDS[$1]}"
-    local subcommand="${COMP_WORDS[$(($1 + 1))]}"
-
-    if [ $1 -eq 0 ]
-    then
-	command=""
-	subcommand=""
-    elif _guix_is_option "$subcommand"
-    then
-	subcommand=""
-    fi
-
-    local options="$(${COMP_WORDS[0]} $command $subcommand --help 2> /dev/null \
+    local subcommand
+    case "${COMP_WORDS[2]}" in
+	-*)     subcommand="";;
+	[a-z]*) subcommand="${COMP_WORDS[2]}";;
+    esac
+    local options="$(${COMP_WORDS[0]} ${COMP_WORDS[1]} $subcommand --help 2> /dev/null \
                             | grep '^  \+-' \
                             | sed -e's/^.*--\([a-zA-Z0-9_-]\+\)\(=\?\).*/--\1\2/g')"
     compopt -o nospace
-    COMPREPLY+=($(compgen -W "$options" -- "$2"))
+    COMPREPLY=($(compgen -W "$options" -- "${COMP_WORDS[${#COMP_WORDS[*]} - 1]}"))
 }
 
-_guix_is_option ()
+_guix_is_command ()
 {
-    case "$1" in
-	-*)
-	    true
-	    ;;
-	*)
-	    false
-	    ;;
-    esac
+    local word
+    local result="false"
+    for word in ${COMP_WORDS[*]}
+    do
+	if [ "$word" = "$1" ]
+	then
+	    result=true
+	    break
+	fi
+    done
+    $result
 }
 
 _guix_is_removing ()
@@ -178,22 +172,10 @@ _guix_complete_file ()
     COMPREPLY=()
 }
 
-_guix_complete_available_package_or_store_file ()
-{
-    _guix_complete_available_package "$@"
-
-    # The current _guix_complete_file implementation doesn't compose (append to
-    # COMPREPLY), so we suggest file names only if no package names matched.
-    if [[ -z "$COMPREPLY" ]]
-    then
-	_guix_complete_file # TODO: restrict to store files
-    fi
-}
-
 _guix_complete_pid ()
 {
     local pids="$(cd /proc; echo [0-9]*)"
-    COMPREPLY+=($(compgen -W "$pids" -- "$1"))
+    COMPREPLY=($(compgen -W "$pids" -- "$1"))
 }
 
 _guix_complete ()
@@ -201,44 +183,22 @@ _guix_complete ()
     local word_count=${#COMP_WORDS[*]}
     local word_at_point="${COMP_WORDS[$COMP_CWORD]}"
 
-    # Find the innermost command at point, e.g. "build" in the case of
-    # "guix time-machine OPTIONS -- build<Tab>" -- but "time-machine" if
-    # point is moved before "build".
-    local command_index=0
-    local command
-    local word_index=0
-    local word
-    local expect_command="true"
-    while [[ $((++word_index)) -le COMP_CWORD ]]
-    do
-	word="${COMP_WORDS[$word_index]}"
-	if $expect_command
-	then
-	    command_index=$word_index
-	    command="$word"
-	    expect_command="false"
-	    continue
-	fi
-	if [[ "$word" = "--" ]]
-	then
-	    case "$command" in
-		environment|shell)
-		    break
-		    ;;
-		time-machine)
-		    expect_command="true"
-		    ;;
-	    esac
-	fi
-    done
+    if [ "$COMP_CWORD" -gt 1 ]
+    then
+	case "$word_at_point" in
+	    -*)
+		_guix_complete_option "$word_at_point"
+		return
+		;;
+	esac
+    fi
 
     case $COMP_CWORD in
-	$command_index)
+	1)
 	    _guix_complete_command
-	    _guix_complete_option 0 "$word_at_point"
 	    ;;
 	*)
-	    if [[ "$command" = "package" ]]
+	    if _guix_is_command "package"
 	    then
 		if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p || _guix_is_dash_f
 		then
@@ -249,7 +209,7 @@ _guix_complete ()
 		else
 		    _guix_complete_available_package "$word_at_point"
 		fi
-	    elif [[ "$command" = "install" ]]
+	    elif _guix_is_command "install"
 	    then
                 if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p
                 then
@@ -257,7 +217,7 @@ _guix_complete ()
 		else
 		    _guix_complete_available_package "$word_at_point"
 		fi
-	    elif [[ "$command" = "upgrade" || "$command" = "remove" ]]
+	    elif _guix_is_command "remove"
 	    then
                 if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p
                 then
@@ -265,84 +225,77 @@ _guix_complete ()
 		else
 		    _guix_complete_installed_package "$word_at_point"
 		fi
-            elif [[ "$command" = "build" ]]
+	    elif _guix_is_command "upgrade"
+	    then
+                if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p
+                then
+                    _guix_complete_file
+		else
+		    _guix_complete_installed_package "$word_at_point"
+		fi
+            elif _guix_is_command "build"
             then
                 if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_f
                 then
                     _guix_complete_file
 		else
-		    _guix_complete_available_package_or_store_file "$word_at_point"
+		    _guix_complete_available_package "$word_at_point"
                 fi
-	    elif [[ "$command" = "environment" || "$command" = "shell" ]]
+	    elif _guix_is_command "environment"
 	    then
-		if _guix_is_dash_f && [[ "$command" = "shell" ]]
-		then
-		    # The otherwise identical ‘guix environment’ lacks the ‘-f’ option.
-		    _guix_complete_file
-		elif _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p || _guix_is_dash_l
-		then
-		    _guix_complete_file
-		elif _guix_is_option "$word_at_point"
-		then
-		    _guix_complete_option "$command_index" "$word_at_point"
+                if _guix_is_dash_L || _guix_is_dash_m || _guix_is_dash_p || _guix_is_dash_l
+                then
+                    _guix_complete_file
 		else
 		    _guix_complete_available_package "$word_at_point"
 		fi
-	    elif [[ "$command" = "download" || "$command" = "gc" || "$command" = "hash" ]]
+	    elif _guix_is_command "download"
 	    then
-		_guix_complete_file
-	    elif [[ "$command" = "size" ]]
+		 _guix_complete_file
+	    elif _guix_is_command "system"
 	    then
-		_guix_complete_available_package_or_store_file "$word_at_point"
-	    elif [[ "$command" = "system" || "$command" = "home" ]]
-	    then
-		case $((COMP_CWORD - command_index)) in
-		    1) _guix_complete_subcommand;;
+		case $COMP_CWORD in
+		    2) _guix_complete_subcommand;;
 		    *) _guix_complete_file;; # TODO: restrict to *.scm
 		esac
-            elif [[ "$command" = "pull" ]]
+            elif _guix_is_command "pull"
             then
                 if _guix_is_dash_C || _guix_is_dash_p
                 then
                     _guix_complete_file
                 fi
-            elif [[ "$command" = "time-machine" ]]
+            elif _guix_is_command "time-machine"
             then
                 if _guix_is_dash_C
                 then
                     _guix_complete_file
 		else
-		    _guix_complete_option "$command_index" "$word_at_point"
+		    _guix_complete_command
                 fi
-	    elif [[ "$command" = "container" ]]
+	    elif _guix_is_command "container"
 	    then
-		case $((COMP_CWORD - command_index)) in
-		    1) _guix_complete_subcommand;;
-		    2) _guix_complete_pid "$word_at_point";;
+		case $COMP_CWORD in
+		    2) _guix_complete_subcommand;;
+		    3) _guix_complete_pid "$word_at_point";;
 		    *) _guix_complete_file;;
 		esac
-	    elif [[ "$command" = "import" ]]
+	    elif _guix_is_command "import"
 	    then
 		_guix_complete_subcommand
-            elif [[ "$command" = "weather" ]]
+	    elif _guix_is_command "hash" || _guix_is_command "gc"
+	    then
+		_guix_complete_file
+            elif _guix_is_command "weather"
             then
                 if _guix_is_dash_m
                 then
                     _guix_complete_file
-		else
-		    _guix_complete_available_package "$word_at_point"
                 fi
 	    else
 		_guix_complete_available_package "$word_at_point"
 	    fi
 	    ;;
     esac
-
-    if [[ -z "$COMPREPLY" && COMP_CWORD -gt command_index ]] &&
-        _guix_is_option "$word_at_point"
-    then
-	_guix_complete_option "$command_index" "$word_at_point"
-    fi
 }
 
 complete -F _guix_complete guix

etc/completion/zsh/_guix

@@ -2,8 +2,6 @@
 #
 # GNU Guix --- Functional package management for GNU
 # Copyright © 2016 Eric Le Bihan <eric.le.bihan.dev@free.fr>
-# Copyright © 2021 Noah Evans <noah@nevans.me>
-# Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 #
 # This file is part of GNU Guix.
 #
@@ -58,7 +56,6 @@ _guix_list_available_packages()
     if ( [[ ${+_guix_available_packages} -eq 0 ]] || _cache_invalid GUIX_AVAILABLE_PACKAGES ) \
        && ! _retrieve_cache GUIX_AVAILABLE_PACKAGES; then
         _guix_available_packages=(${${(f)"$(guix package -A | cut -f1)"}})
-        _guix_available_packages=("${_guix_available_packages[@]// /}")
         _store_cache GUIX_AVAILABLE_PACKAGES _guix_available_packages
     fi
 }
@@ -71,24 +68,21 @@ _guix_list_installed_packages()
 (( $+functions[_guix_build] )) || _guix_build()
 {
     _arguments \
-        {-e,--expression=}'[build the package or derivation EXPR evaluates to]:EXPR' \
-        {-f,--file=}'[build the package or derivation that the code within FILE evaluates to]:FILE:_files' \
-        {-m,--manifest=}'[build the packages that the manifest given in FILE evaluates to]:FILE:_files' \
-        {-S,--source}'[build the packages source derivations]' \
-        '--sources=[build source derivations]:TYPE:(package all transitive)' \
-        {-s,--system=}'[attempt to build for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
+        '--expression=[build the package matching EXPR]:EXPR' \
+        '--file=[build the package matching code evaluated from FILE]:FILE:_files' \
+        '--source[build the packages source derivations]' \
+        '--sources=[build source derivations]:TYPE:(all package transitive)' \
+        '--system=[attempt to build for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
         '--target=[cross-build for TRIPLET (e.g. "armel-linux-gnu")]:TRIPLET' \
-        {-d,--derivations}'[return the derivation paths of the given packages]' \
+        '--derivations[return the derivation paths of the given packages]' \
         '--check[rebuild items to check for non-determinism issues]' \
-        '--repair[repair the specified items]' \
-        {-r,--root=}'[make FILE a symlink to the result, and register it as a GC root]:FILE:_files' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        {-q,--quiet}'[do not show the build log]' \
+        '--root=[symlink result to FILE and register it as GC root]:FILE:_files' \
+        '--quiet[do not show the build log]' \
         '--log-file[return the log file names for the given derivations]' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -\' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
+        '--load-path=[prepend DIR to the package module search path]:DIR:_dirs' \
+        '--keep-failed[keep build tree of failed builds]' \
+        '--keep-going[keep going when some of the derivations fail]' \
+        '--dry-run[do not build the derivations]' \
         '--fallback[fall back to building when the substituter fails]' \
         '--no-substitutes[build instead of resorting to pre-built substitutes]' \
         '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
@@ -96,12 +90,12 @@ _guix_list_installed_packages()
         '--no-offload[do not attempt to offload builds]' \
         '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
         '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
+        '--verbosity=[use the given verbosity LEVEL]:LEVEL' \
         '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-V,--version}'[display version information and exit]' \
+        '--cores=[allow the use of up to N CPU cores for the build]:N' \
+        '--max-jobs=[allow at most N build jobs]:N' \
+        '--with-source=[use SOURCE when building the corresponding package]:SOURCE' \
+        '--with-input=[replace dependency PACKAGE by REPLACEMENT]:PACKAGE=REPLACEMENT' \
         '*:package:->packages'
 
     if [[ "$state" = packages ]]; then
@@ -113,10 +107,7 @@ _guix_list_installed_packages()
 (( $+functions[_guix_challenge] )) || _guix_challenge()
 {
     _arguments \
-        '--substitute-urls=[compare build results with those at URLS]:URLS:_urls' \
-        '--diff=[show differences according to MODE]:MODE' \
-        {-v,--verbose}'[show details about successful comparisons]' \
-        {-V,--version}'[display version information and exit]' \
+        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URL:_urls' \
         '*:package:->packages'
 
     if [[ "$state" = packages ]]; then
@@ -135,11 +126,7 @@ _guix_list_installed_packages()
 (( $+functions[_guix_download] )) || _guix_download()
 {
     _arguments \
-        {-f,--format=}'[write the hash in the given format]:FMT:(nix-base32 base16 base32 hex)' \
-        {-H,--hash=}'[use the given hash ALGORITHM]:ALGORITHM' \
-        '--no-check-certificate[do not validate the certificate of HTTPS servers ]' \
-        {-o,--output=}'[download to FILE]:FILE:_files' \
-        {-V,--version}'[display version information and exit]' \
+        '--format=[write the hash in the given format]:FMT:(nix-base32 base16 base32 hex)' \
         '1:URL:_urls'
 }
 
@@ -152,29 +139,21 @@ _guix_list_installed_packages()
 (( $+functions[_guix_environment] )) || _guix_environment()
 {
     _arguments \
-        {-e,--expression=}'[create environment for the package that EXPR evaluates to]:EXPR' \
-        {-l,--load=}'[create environment for the package that the code within FILE evaluates to]:FILE:_files' \
-        {-m,--manifest=}'[create environment with the manifest from FILE]:FILE:_files' \
-        {-p,--profile=}'[create environment from profile at PATH]:PATH:_files -/' \
-        '--ad-hoc[include all specified packages in the environment instead of only their inputs]' \
+        '--expression=[create environment for the package evaluated from EXPR]:EXPR' \
+        '--load=[create environment for the package evaluated from FILE]:FILE:_files' \
+        '--ad-hoc[include all specified packages, not only their inputs]' \
         '--pure[unset existing environment variables]' \
-        {-E,--preserve=}'[preserve environment variables that match REGEXP]:REGEXP' \
         '--search-paths[display needed environment variable definitions]' \
-        {-s,--system=}'[attempt to build for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
-        {-r,--root=}'[make FILE a symlink to the result, and register it as a GC root]:FILE:_files' \
-        {-C,--container}'[run command within an isolated container]' \
-        {-N,--network}'[allow containers to access the network]' \
-        {-P,--link-profile}'[link environment profile to ~/.guix-profile within an isolated container]' \
-        {-u,--user=}'[instead of copying the name and home of the current user into an isolated container, use the name USER with home directory /home/USER]:USER:_users' \
-        '--no-cwd[do not share current working directory with an isolated container]' \
-        '--share=[for containers, share writable host file system according to SPEC]:SPEC' \
-        '--expose=[for containers, expose read-only host file system according to SPEC]:SPEC' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
+        '--system=[attempt to build for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
+        '--container[run command within an isolated container]' \
+        '--network[allow containers to access the network]' \
+        '--share=[share writable host file system according to SPEC]:SPEC' \
+        '--expose=[expose read-only host file system according to SPEC]:SPEC' \
         '--bootstrap[use bootstrap binaries to build the environment]' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
+        '--load-path=[prepend DIR to the package module search path]:DIR:_dirs' \
+        '--keep-failed[keep build tree of failed builds]' \
+        '--keep-going[keep going when some of the derivations fail]' \
+        '--dry-run[do not build the derivations]' \
         '--fallback[fall back to building when the substituter fails]' \
         '--no-substitutes[build instead of resorting to pre-built substitutes]' \
         '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
@@ -182,12 +161,10 @@ _guix_list_installed_packages()
         '--no-offload[do not attempt to offload builds]' \
         '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
         '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
+        '--verbosity=[use the given verbosity LEVEL]:LEVEL' \
         '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-V,--version}'[display version information and exit]' \
+        '--cores=[allow the use of up to N CPU cores for the build]:N' \
+        '--max-jobs=[allow at most N build jobs]:N' \
         '*:package:->packages'
 
     if [[ "$state" = packages ]]; then
@@ -200,39 +177,27 @@ _guix_list_installed_packages()
 (( $+functions[_guix_gc] )) || _guix_gc()
 {
     _arguments \
-        {-C,--collect-garbage=}'[collect at least MIN bytes of garbage]:MIN' \
-        {-F,--free-space=}'[attempt to reach FREE available space in the store]:FREE' \
-        {-d,--delete-generations=}'[delete profile generations matching PATTERN]:PATTERN' \
-        {-D,--delete}'[attempt to delete PATHS]' \
-        '--list-roots[list the users GC roots]' \
-        '--list-busy[list store items used by running processes]' \
+        '--collect-garbage=[collect at least MIN bytes of garbage]:MIN' \
+        '--free-space=[attempt to reach FREE available space in the store]:FREE' \
+        '--delete[attempt to delete PATHS]' \
         '--optimize[optimize the store by deduplicating identical files]' \
         '--list-dead[list dead paths]' \
         '--list-live[list live paths]' \
         '--references[list the references of PATHS]' \
-        {-R,--requisites}'[list the requisites of PATHS]' \
+        '--requisites[list the requisites of PATHS]' \
         '--referrers[list the referrers of PATHS]' \
-        '--derivers[list the derivers of PATHS]' \
         '--verify=[verify the integrity of the store]:OPTS:(contents repair)' \
         '--list-failures[list cached build failures]' \
         '--clear-failures[remove PATHS from the set of cached failures]' \
-        {-V,--version}'[display version information and exit]:V' \
-        '1:PATH:_files -/'
+        '1:PATH:_dirs'
 }
 
 (( $+functions[_guix_graph] )) || _guix_graph()
 {
     _arguments \
-        {-b,--backend=}'[produce a graph with the given backend TYPE]:TYPE:->types' \
-        '--list-backends[list the available graph backends]' \
-        {-t,--type=}'[represent nodes of the given TYPE]:TYPE:->types' \
+        '--type=[represent nodes of the given TYPE]:TYPE:->types' \
         '--list-types[list the available graph types]' \
-        '--path[display the shortest path between the given nodes]' \
-        {-e,--expression=}'[consider the package EXPR evaluates to]:EXPR' \
-        {-s,--system=}'[consider the graph for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-V,--version}'[display version information and exit]' \
+        '--expression=[consider the package EXPR evaluates to]:EXPR' \
         '1:PACKAGE:->packages'
 
     case "$state" in
@@ -251,18 +216,14 @@ _guix_list_installed_packages()
 (( $+functions[_guix_hash] )) || _guix_hash()
 {
     _arguments \
-        {-x,--exclude-vcs}'[exclude version control directories]' \
-        {-H,--hash=}'[use the given hash ALGORITHM]:ALGORITHM' \
-        {-f,--format=}'[write the hash in the given format]:FMT:(nix-base32 base16 base32 hex)' \
-        {-r,--recursive}'[compute the hash on FILE recursively]' \
-        {-V,--version}'[display version information and exit]' \
+        '--format=[write the hash in the given format]:FMT:(nix-base32 base16 base32 hex)' \
+        '--recursive[compute the hash on FILE recursively]'\
         '1:FILE:_files'
 }
 
 (( $+functions[_guix_import] )) || _guix_import()
 {
     _arguments \
-        {-V,--version}'[display version information and exit]' \
         '1:IMPORTER:->importer' \
         '*:args:'
 
@@ -275,12 +236,8 @@ _guix_list_installed_packages()
 (( $+functions[_guix_lint] )) || _guix_lint()
 {
     _arguments \
-        {-c,--checkers=}'[only run the specified checkers]:CHECKERS:->checkers' \
-        {-x,--exclude=}'[exclude the specified checkers]:CHECKERSS:->checkers' \
-        {-n,--no-network}'[only run checkers that do not access the network]' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-l,--list-checkers}'[display the list of available lint checkers]' \
-        {-V,--version}'[display version information and exit]' \
+        '--checkers=[only run the specified checkers]:CHECKERS:->checkers' \
+        '--list-checkers[display the list of available lint checkers]' \
         '1:PACKAGE:->packages'
 
     case "$state" in
@@ -298,32 +255,29 @@ _guix_list_installed_packages()
 (( $+functions[_guix_package] )) || _guix_package()
 {
     _arguments \
-        {-i,--install}'[install one or more packages]: :->install' \
-        {-e,--install-from-expression=}'[install the package EXP evaluates to]:EXP' \
-        {-f,--install-from-file=}'[install the package evaluated from FILE]:FILE:_files' \
-        {-r,--remove}'[remove one or more packages]: :->remove' \
-        {-u,--upgrade=}'[upgrade all the installed packages matching REGEXP]:REGEXP' \
-        {-m,--manifest=}'[create a new profile generation from FILE]:FILE:_files' \
+        '--install[install one or more packages]: :->install' \
+        '--install-from-expression=[install the package EXP evaluates to]:EXP' \
+        '--install-from-file=[install the package evaluated from FILE]:FILE:_files' \
+        '--remove[remove one or more packages]: :->remove' \
+        '--upgrade=[upgrade all the installed packages matching REGEXP]:REGEXP' \
+        '--manifest=[create a new profile generation from FILE]:FILE:_files' \
         '--do-not-upgrade=[do not upgrade any packages matching REGEXP]:REGEXP' \
         '--roll-back[roll back to the previous generation]' \
         '--search-paths=[display needed environment variable definitions]:KINDS' \
-        {-l,--list-generations=}'[list generations matching PATTERN]:PATTERN' \
-        {-d,--delete-generations=}'[delete generations matching PATTERN]:PATTERN' \
-        {-S,--switch-generation=}'[switch to a generation matching PATTERN]:PATTERN' \
-        '--export-manifest[print a manifest for the chosen profile]' \
-        '--export-channels[print channels for the chosen profile]' \
-        {-p,--profile}'[use PROFILE instead of the default profile]:PROFILE:_files -/' \
-        '--list-profiles[list the profiles]' \
-        '--allow-collisions[do not treat collisions in the profile as an error]' \
+        '--list-generations=[list generations matching PATTERN]:PATTERN' \
+        '--delete-generations=[delete generations matching PATTERN]:PATTERN' \
+        '--switch-generation=[switch to a generation matching PATTERN]:PATTERN' \
+        '--profile=[use PROFILE instead of the default profile]:PROFILE' \
         '--bootstrap[use the bootstrap Guile to build the profile]' \
-        {-s,--search=}'[search in synopsis and description using REGEXP]:REGEXP' \
-        {-I,--list-installed=}'[list installed packages matching REGEXP]:REGEXP' \
-        {-A,--list-available=}'[list available packages matching REGEXP]:REGEXP' \
+        '--verbose[produce verbose output]' \
+        '--search=[search in synopsis and description using REGEXP]:REGEXP' \
+        '--list-installed=[list installed packages matching REGEXP]:REGEXP' \
+        '--list-available=[list available packages matching REGEXP]:REGEXP' \
         '--show=[show details about a package]: :->show' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
+        '--load-path=[prepend DIR to the package module search path]:DIR:_dirs' \
+        '--keep-failed[keep build tree of failed builds]' \
+        '--keep-going[keep going when some of the derivations fail]' \
+        '--dry-run[do not build the derivations]' \
         '--fallback[fall back to building when the substituter fails]' \
         '--no-substitutes[build instead of resorting to pre-built substitutes]' \
         '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
@@ -331,13 +285,12 @@ _guix_list_installed_packages()
         '--no-offload[do not attempt to offload builds]' \
         '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
         '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
+        '--verbosity=[use the given verbosity LEVEL]:LEVEL' \
         '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]' \
-        {-V,--version}'[display version information and exit]'
+        '--cores=[allow the use of up to N CPU cores for the build]:N' \
+        '--max-jobs=[allow at most N build jobs]:N' \
+        '--with-source=[use SOURCE when building the corresponding package]:SOURCE' \
+        '--with-input=[replace dependency PACKAGE by REPLACEMENT]:PACKAGE=REPLACEMENT'
 
     case "$state" in
         install|show)
@@ -351,165 +304,37 @@ _guix_list_installed_packages()
         esac
 }
 
-(( $+functions[_guix_install] )) || _guix_install()
-{
-    _arguments \
-        {-p,--profile=}'[use PROFILE instead of the users default profile]:PROFILE:_files -/' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
-        '--fallback[fall back to building when the substituter fails]' \
-        '--no-substitutes[build instead of resorting to pre-built substitutes]' \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
-        '--no-grafts[do not graft packages]' \
-        '--no-offload[do not attempt to offload builds]' \
-        '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
-        '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
-        '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-V,--version}'[display version information and exit]' \
-        '*:package:->packages'
-
-    if [[ "$state" = packages ]]; then
-        _guix_list_available_packages
-        compadd -a -- _guix_available_packages
-    fi
-}
-
-(( $+functions[_guix_remove] )) || _guix_remove()
-{
-    _arguments \
-        {-p,--profile=}'[use PROFILE instead of the users default profile]:PROFILE:_files -/' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
-        '--fallback[fall back to building when the substituter fails]' \
-        '--no-substitutes[build instead of resorting to pre-built substitutes]' \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
-        '--no-grafts[do not graft packages]' \
-        '--no-offload[do not attempt to offload builds]' \
-        '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
-        '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
-        '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        {-V,--version}'[display version information and exit]' \
-        '*:package:->packages'
-
-    if [[ "$state" = packages ]]; then
-        _guix_list_installed_packages
-        compadd -a -- _guix_installed_packages
-    fi
-}
-
-(( $+functions[_guix_upgrade] )) || _guix_upgrade()
-{
-    _arguments \
-        {-p,--profile=}'[use PROFILE instead of the users default profile]:PROFILE:_files -/' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        '--do-not-upgrade=[do not upgrade any packages matching REGEXP]:REGEXP' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
-        '--fallback[fall back to building when the substituter fails]' \
-        '--no-substitutes[build instead of resorting to pre-built substitutes]' \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
-        '--no-grafts[do not graft packages]' \
-        '--no-offload[do not attempt to offload builds]' \
-        '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
-        '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
-        '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        '--help-transform[list package transformation options not shown here]' \
-        {-V,--version}'[display version information and exit]' \
-        '*:regexp'
-}
-
 (( $+functions[_guix_publish] )) || _guix_publish()
 {
     _arguments \
-        {-p,--port=}'[listen on PORT]:PORT' \
-        '--listen=[listen on the network interface for HOST]:HOST_hosts' \
-        {-u,--user=}'[change privileges to USER as soon as possible]:USER_users' \
-        {-a,--advertise}'[advertise on the local network]' \
-        {-C,--compression=}'[compress archives with METHOD at LEVEL]:METHOD' \
-        {-c,--cache=}'[cache published items to DIRECTORY]:DIRECTORY:_files -/' \
-        '--cache-bypass-threshold=[serve store items below SIZE even when not cached]:SIZE' \
-        '--workers=[use N workers to bake items]:N' \
+        '--port=[listen on PORT]:PORT:' \
+        '--listen=[listen on the network interface for HOST]:HOST:_hosts' \
+        '--user=[change privileges to USER as soon as possible]:USER:_users' \
+        '--compression=[compress archives at LEVEL]:LEVEL' \
         '--ttl=[announce narinfos can be cached for TTL seconds]:TTL' \
-        '--negative-ttl=[announce missing narinfos can be cached for TTL seconds]:TTL' \
-        '--nar-path=[use PATH as the prefix for nar URLs]:PATH' \
-        '--public-key=[use FILE as the public key for signatures]:FILE:_files' \
-        '--private-key=[use FILE as the private key for signatures]:FILE:_files' \
-        {-r,--repl=}'[spawn REPL server on PORT]:PORT' \
-        {-V,--version}'[display version information and exit]' \
+        '--repl=[spawn REPL server on PORT]:PORT'
 }
 
 (( $+functions[_guix_pull] )) || _guix_pull()
 {
     _arguments \
-        {-C,--channels=}'[deploy the channels defined in FILE]:FILE:_files' \
-        '--url=[download from the Git repository at URL]:URL:_urls' \
-        '--commit=[download the specified COMMIT]:COMMIT' \
-        '--branch=[download the tip of the specified BRANCH]:BRANCH' \
-        '--allow-downgrades[allow downgrades to earlier channel revisions]' \
-        '--disable-authentication[disable channel authentication]' \
-        {-N,--news}'[display news compared to the previous generation]' \
-        {-l,--list-generations=}'[list generations matching PATTERN]:PATTERN' \
-        '--roll-back[roll back to the previous generation]' \
-        {-d,--delete-generations=}'[delete generations matching PATTERN]:PATTERN' \
-        {-S,--switch-generation=}'[switch to a generation matching PATTERN]:PATTERN' \
-        {-p,--profile=}'[use PROFILE instead of ~/.config/guix/current]:PROFILE:_files -/' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        {-s,--system=}'[attempt to build for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
-        '--bootstrap[use the bootstrap Guile to build the new Guix]' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
-        '--fallback[fall back to building when the substituter fails]' \
-        '--no-substitutes[build instead of resorting to pre-built substitutes]' \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
-        '--no-grafts[do not graft packages]' \
-        '--no-offload[do not attempt to offload builds]' \
-        '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
-        '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
-        '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        {-V,--version}'[display version information and exit]'
+        '--verbose[produce verbose output]' \
+        '--url=[download the Guix tarball from URL]:URL:_urls' \
+        '--bootstrap[use the bootstrap Guile to build the new Guix]'
 }
 
 (( $+functions[_guix_refresh] )) || _guix_refresh()
 {
     _arguments \
-        {-e,--expression=}'[consider the package EXPR evaluates to]:EXPR' \
-        {-u,--update}'[update source files in place]' \
-        {-s,--select=}'[select all the packages in SUBSET, one of]:SUBSET:(core non-core)' \
-        {-m,--manifest=}'[select all the packages from the manifest in FILE]:FILE:_files' \
-        {-t,--type=}'[restrict to updates from the specified updaters]:UPDATER:-.updaters' \
-        {-L,--list-updaters}'[list available updaters and exit]' \
-        {-l,--list-dependent}'[list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...]' \
-        {-r,--recursive}'[check the PACKAGE and its inputs for upgrades]' \
-        '--list-transitive[list all the packages that PACKAGE depends on]' \
-        '--keyring=[use FILE as the keyring of upstream OpenPGP keys]:FILE:_files' \
-        '--key-server=[use HOST as the OpenPGP key server]:HOST_hosts' \
+        '--expression=[consider the package EXPR evaluates to]:EXPR' \
+        '--update[update source files in place]' \
+        '--select=[select all the packages in SUBSET]:SUBSET:(core non-core)' \
+        '--type=[restrict to updates from the specified updaters]:UPDATER:->updaters' \
+        '--list-updaters[list available updaters and exit]' \
+        '--list-dependent[list top-level dependent packages]' \
+        '--key-server=[use HOST as the OpenPGP key server]:HOST:_hosts' \
         '--gpg=[use COMMAND as the GnuPG 2.x command]:COMMAND' \
-        '--key-download=[handle missing OpenPGP keys according to POLICY:]:POLICY:(always interactive never)' \
-        '--load-path=[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-V,--version}'[display version information and exit]' \
+        '--key-download=[policy to handle missing OpenPGP keys]:POLICY:(always interactive never)' \
         '*:package:->packages'
 
     case "$state" in
@@ -527,12 +352,9 @@ _guix_list_installed_packages()
 (( $+functions[_guix_size] )) || _guix_size()
 {
     _arguments \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
-        {-s,--system=}'[consider packages for SYSTEM (e.g. "i686-linux")]:SYSTEM' \
-        '--sort=[sort according to KEY]:KEY:(closure self)' \
-        {-m,--map-file=}'[write to FILE a graphical map of disk usage]:FILE:_files' \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-V,--version}'[display version information and exit]' \
+        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URL:_urls' \
+        '-system=[consider packages for SYSTEM--e.g., "i686-linux"]:SYSTEM' \
+        '--map-file=[write to FILE a graphical map of disk usage]:FILE:_files' \
         '*:package:->packages'
 
         if [[ "$state" = packages ]]; then
@@ -544,42 +366,28 @@ _guix_list_installed_packages()
 (( $+functions[_guix_system] )) || _guix_system()
 {
     _arguments \
-        {-L,--load-path=}'[prepend DIR to the package module search path]:DIR:_files -/' \
-        {-K,--keep-failed}'[keep build tree of failed builds]' \
-        {-k,--keep-going}'[keep going when some of the derivations fail]' \
-        {-n,--dry-run}'[do not build the derivations]' \
+        '--load-path=[prepend DIR to the package module search path]:DIR:_dirs' \
+        '--keep-failed[keep build tree of failed builds]' \
+        '--keep-going[keep going when some of the derivations fail]' \
+        '--dry-run[do not build the derivations]' \
         '--fallback[fall back to building when the substituter fails]' \
         '--no-substitutes[build instead of resorting to pre-built substitutes]' \
-        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URLS:_urls' \
+        '--substitute-urls=[fetch substitute from URLS if they are authorized]:URL:_urls' \
         '--no-grafts[do not graft packages]' \
         '--no-offload[do not attempt to offload builds]' \
         '--max-silent-time=[mark the build as failed after SECONDS of silence]:SECONDS' \
         '--timeout=[mark the build as failed after SECONDS of activity]:SECONDS' \
+        '--verbosity=[use the given verbosity LEVEL]:LEVEL' \
         '--rounds=[build N times in a row to detect non-determinism]:N' \
-        {-c,--cores=}'[allow the use of up to N CPU cores for the build]:N' \
-        {-M,--max-jobs=}'[allow at most N build jobs]:N' \
-        '--debug=[produce debugging output at LEVEL]:LEVEL' \
-        {-d,--derivation}'[return the derivation of the given system]' \
-        {-e,--expression=}'[consider the operating-system EXPR evaluates to instead of reading FILE, when applicable]:EXPR' \
-        '--allow-downgrades[for reconfigure, allow downgrades to earlier channel revisions]' \
-        '--on-error=[apply STRATEGY  when an error occurs while reading FILE]:STRATEGY:(nothing-special backtrace debug)' \
-        '--list-image-types[list available image types]' \
-        {-t,--image-type=}'[for image, produce an image of TYPE]:TYPE' \
-        '--image-size=[for image, produce an image of SIZE]:SIZE' \
-        '--no-bootloader[for init, do not install a bootloader]' \
-        '--volatile[for image, make the root file system volatile]' \
-        '--label=[for image, label disk image with LABEL]:LABEL' \
-        '--save-provenance[save provenance information]' \
-        '--share=[for vm and container, share host file system with read/write access according to SPEC]:SPEC' \
-        '--expose=[for vm and container, expose host file system directory as read-only according to SPEC]:SPEC' \
-        {-N,--network}'[for container, allow containers to access the network]' \
-        {-r,--root=}'[for vm, image, container and build, make FILE a symlink to the result, and register it as a GC root]:FILE:_files' \
-        '--full-boot[for vm, make a full boot sequence]' \
-        '--skip-checks[skip file system and initrd module safety checks]' \
-        '--target=[cross-build for TRIPLET (e.g. "armel-linux-gnu")]:TRIPLET' \
-        {-v,--verbosity=}'[use the given verbosity LEVEL]:LEVEL' \
-        '--graph-backend=[use BACKEND for extension-graphs and shepherd-graph]:BACKEND' \
-        {-V,--version}'[display version information and exit]' \
+        '--cores=[allow the use of up to N CPU cores for the build]:N' \
+        '--max-jobs=[allow at most N build jobs]:N' \
+        '--derivation[return the derivation of the given system]' \
+        '--on-error=[apply STRATEGY when an error occurs while reading FILE]:STRATEGY' \
+        '--image-size=[for "image", produce an image of SIZE]:SIZE' \
+        '--no-grub[for "init", do not install GRUB]' \
+        '--share=[for "vm", share host file system according to SPEC]:SPEC' \
+        '--expose=[for "vm", expose host file system according to SPEC]:SPEC' \
+        '--full-boot[for "vm", make a full boot sequence]' \
         '1:action:->actions' \
         '*:file:_files'
 
@@ -597,35 +405,20 @@ _guix_list_installed_packages()
         "build:Build a given package"
         "challenge:Challenge the substitutes for a package"
         "container:Build and manipulate Linux containers"
-        "copy:Copy store items remotely over SSH"
-        "deploy:Deploy operating systems on a set of machines"
-        "describe:Describe the channel revisions currently used"
         "download:Download the file at given URL and add it to the store"
         "edit:Edit the definitions of a package"
         "environment:Build an environment with a package and its dependencies"
         "gc:Invoke the garbage collector"
-        "git:Operate on Git repositories"
         "graph:Emit a DOT representation of the dependencies of a package"
         "hash:Return the cryptographic hash of a file"
         "import:Run an importer"
-        "install:Install packages"
         "lint:Run a set of checkers on a package"
-        "offload:Set up and operate build offloading"
-        "pack:Create application bundles"
         "package:Install, remove, or upgrade packages"
-        "processes:List currently running sessions"
         "publish:Publish /gnu/store over HTTP."
         "pull:Download and deploy the latest version of Guix"
         "refresh:Update package definitions to match the latest version"
-        "remove:Remove packages"
-        "repl:Read-eval-print loop (REPL) for interactive programming"
-        "search:Search for packages"
-        "show:Show information about packages"
         "size:Report the size of a package and its dependencies"
         "system:Build the operating system"
-        "time-machine:Run commands from a different revision"
-        "upgrade:Upgrade packages"
-        "weather:Report on the availability of pre-built package binaries"
     )
 
     if (( CURRENT == 1 )); then

etc/disarchive-manifest.scm

@@ -1,112 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 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 that builds a directory containing Disarchive
-;;; metadata for all the tarballs packages refer to.
-
-(use-modules (srfi srfi-1) (ice-9 match)
-             (guix packages) (guix gexp) (guix profiles)
-             (guix base16)
-             (gnu packages))
-
-(include "source-manifest.scm")
-
-(define (tarball-origin? origin)
-  (match (origin-actual-file-name origin)
-    (#f #f)
-    ((? string? file)
-     ;; 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" file))))))
-
-(define (origin->disarchive origin)
-  "Return a directory containing Disarchive metadata for ORIGIN, a tarball, or
-an empty directory if ORIGIN could not be disassembled."
-  (define file-name
-    (let ((hash (origin-hash origin)))
-      (string-append (symbol->string (content-hash-algorithm hash))
-                     "/"
-                     (bytevector->base16-string
-                      (content-hash-value hash)))))
-
-  (define disarchive
-    (specification->package "disarchive"))
-
-  (define build
-    (with-imported-modules '((guix build utils))
-      #~(begin
-          (use-modules (guix build utils)
-                       (srfi srfi-34))
-
-          (define tarball
-            #+(upstream-origin origin))
-
-          (define file-name
-            (string-append #$output "/" #$file-name))
-
-          (define profile
-            #+(profile (content (packages->manifest (list disarchive)))))
-
-          (mkdir-p (dirname file-name))
-          (setenv "PATH" (string-append profile "/bin"))
-          (setenv "GUILE_LOAD_PATH"
-                  (string-append profile "/share/guile/site/"
-                                 (effective-version)))
-          (setenv "GUILE_LOAD_COMPILED_PATH"
-                  (string-append profile "/lib/guile/" (effective-version)
-                                 "/site-ccache"))
-
-          (guard (c ((invoke-error? c)
-                     ;; Sometimes Disarchive fails with "could not find Gzip
-                     ;; compressor".  When that happens, produce an empty
-                     ;; directory instead of failing.
-                     (report-invoke-error c)
-                     (delete-file file-name)))
-            (with-output-to-file file-name
-              (lambda ()
-                ;; Disarchive records the tarball name in its output.  Thus,
-                ;; strip the hash from TARBALL.
-                (let ((short-name (strip-store-file-name tarball)))
-                  (symlink tarball short-name)
-                  (invoke "disarchive" "disassemble" short-name))))))))
-
-  (computed-file (match (origin-actual-file-name origin)
-                   ((? string? str) (string-append str ".dis"))
-                   (#f "anonymous-tarball.dis"))
-                 build))
-
-(define (disarchive-collection origins)
-  "Return a directory containing all the Disarchive metadata for ORIGINS."
-  (directory-union "disarchive-collection"
-                   (filter-map (lambda (origin)
-                                 (and (tarball-origin? origin)
-                                      (origin->disarchive origin)))
-                               origins)
-                   #:copy? #t))
-
-
-;; The manifest containing Disarchive data.
-(let ((origins (all-origins)))
-  (manifest
-   (list (manifest-entry
-           (name "disarchive-collection")
-           (version (number->string (length origins)))
-           (item (disarchive-collection origins))))))

etc/git/gitconfig

@@ -1,5 +0,0 @@
-[diff "scheme"]
-	xfuncname = "^(\\(define.*)$"
-
-[diff "texinfo"]
-	xfuncname = "^@node[[:space:]]+([^,]+).*$"

etc/guix-daemon.cil.in

@@ -301,7 +301,7 @@
                 open read write)))
   (allow guix_daemon_t
          guix_daemon_conf_t
-         (lnk_file (create getattr rename unlink read)))
+         (lnk_file (create getattr rename unlink)))
   (allow guix_daemon_t net_conf_t
          (file (getattr open read)))
   (allow guix_daemon_t net_conf_t
@@ -328,9 +328,6 @@
   (allow guix_daemon_t
          cache_home_t
          (dir (search)))
-  (allow guix_daemon_t
-         cache_home_t
-         (lnk_file (getattr read)))
 
   ;; self upgrades
   (allow guix_daemon_t
@@ -343,7 +340,7 @@
   ;; Socket operations
   (allow guix_daemon_t
          guix_daemon_socket_t
-         (sock_file (unlink write)))
+         (sock_file (unlink)))
   (allow guix_daemon_t
          init_t
          (fd (use)))
@@ -355,7 +352,7 @@
          (unix_stream_socket (listen)))
   (allow guix_daemon_t
          guix_daemon_conf_t
-         (sock_file (create unlink write)))
+         (sock_file (create unlink)))
   (allow guix_daemon_t
          self
          (unix_stream_socket (create

etc/guix-daemon.conf.in

@@ -7,4 +7,4 @@ start on runlevel [2345]
 
 stop on runlevel [016]
 
-exec @localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon --build-users-group=guixbuild --discover=no
+exec @localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon --build-users-group=guixbuild

etc/guix-daemon.service.in

@@ -6,8 +6,7 @@
 Description=Build daemon for GNU Guix
 
 [Service]
-ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon \
-    --build-users-group=guixbuild --discover=no
+ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon --build-users-group=guixbuild
 Environment='GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale' LC_ALL=en_US.utf8
 RemainAfterExit=yes
 StandardOutput=syslog

etc/guix-gc.service.in

@@ -1,20 +0,0 @@
-# This is a "service unit file" for the systemd init system to perform a
-# one-shot 'guix gc' operation.  It is meant to be triggered by a timer.
-# Drop it in /etc/systemd/system or similar together with 'guix-gc.timer'
-# to set it up.
-
-[Unit]
-Description=Discard unused Guix store items
-
-[Service]
-Type=oneshot
-# Customize the 'guix gc' arguments to fit your needs.
-ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix gc -d 1m -F 10G
-PrivateDevices=yes
-PrivateNetwork=yes
-PrivateUsers=no
-ProtectKernelTunables=yes
-ProtectKernelModules=yes
-ProtectControlGroups=yes
-MemoryDenyWriteExecute=yes
-SystemCallFilter=@default @file-system @basic-io @system-service

etc/guix-gc.timer

@@ -1,15 +0,0 @@
-# This is a "timer unit file" for the systemd init system to trigger
-# 'guix-gc.service' periodically.  Drop it in /etc/systemd/system or similar
-# together with 'guix-gc.service' to set it up.
-
-[Unit]
-Description=Discard unused Guix store items
-
-[Timer]
-OnCalendar=weekly
-AccuracySec=1h
-Persistent=true
-RandomizedDelaySec=6000
-
-[Install]
-WantedBy=timers.target

etc/guix-install.sh

@@ -96,7 +96,7 @@ _debug()
 # $1: The prompt question.
 prompt_yes_no() {
     while true; do
-        read -rp "$1 " yn
+        read -rp "$1" yn
         case $yn in
             [Yy]*) return 0;;
             [Nn]*) return 1;;
@@ -139,12 +139,12 @@ chk_gpg_keyring()
 required to verify the Guix binary signature: $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 -
+                     -qO - | 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 - | \
+  wget \"https://sv.gnu.org/people/viewgpg.php?user_id=$user_id\" -qO - | \
 sudo -i gpg --import -"
                 exit_flag=yes
             fi
@@ -249,16 +249,6 @@ chk_sys_nscd()
     fi
 }
 
-# Configure substitute discovery according to user's preferences.
-# $1 is the installed service file to edit.
-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? (yes/no)"; then
-        sed -i 's/--discover=no/--discover=yes/' "$1"
-    fi
-}
-
 # ------------------------------------------------------------------------------
 #+MAIN
 
@@ -272,7 +262,7 @@ guix_get_bin_list()
     _debug "--- [ ${FUNCNAME[0]} ] ---"
 
     # Filter only version and architecture
-    bin_ver_ls=("$(wget "$gnu_url" --no-verbose -O- \
+    bin_ver_ls=("$(wget -qO- "$gnu_url" \
         | sed -n -e 's/.*guix-binary-\([0-9.]*[a-z0-9]*\)\..*.tar.xz.*/\1/p' \
         | sort -Vu)")
 
@@ -305,7 +295,7 @@ guix_get_bin()
     _msg "${INF}Downloading Guix release archive"
 
     wget --help | grep -q '\--show-progress' \
-        && wget_args=("--no-verbose" "--show-progress")
+        && wget_args=("-q" "--show-progress")
 
     if wget "${wget_args[@]}" -P "$dl_path" \
             "${url}/${bin_ver}.tar.xz" "${url}/${bin_ver}.tar.xz.sig"; then
@@ -345,11 +335,11 @@ sys_create_store()
     mv "${tmp_path}/gnu" /
 
     _msg "${INF}Linking the root user's profile"
-    mkdir -p ~root/.config/guix
+    mkdir -p "~root/.config/guix"
     ln -sf /var/guix/profiles/per-user/root/current-guix \
-       ~root/.config/guix/current
+       "~root/.config/guix/current"
 
-    GUIX_PROFILE=~root/.config/guix/current
+    GUIX_PROFILE="~root/.config/guix/current"
     # shellcheck disable=SC1090
     source "${GUIX_PROFILE}/etc/profile"
     _msg "${PAS}activated root profile at ${GUIX_PROFILE}"
@@ -369,7 +359,7 @@ sys_create_build_user()
 
     if getent group kvm > /dev/null; then
         _msg "${INF}group kvm exists and build users will be added to it"
-        local KVMGROUP=,kvm
+	local KVMGROUP=,kvm
     fi
 
     for i in $(seq -w 1 10); do
@@ -405,9 +395,8 @@ sys_enable_guix_daemon()
     case "$INIT_SYS" in
         upstart)
             { initctl reload-configuration;
-              cp ~root/.config/guix/current/lib/upstart/system/guix-daemon.conf \
+              cp "~root/.config/guix/current/lib/upstart/system/guix-daemon.conf" \
                  /etc/init/ &&
-                  configure_substitute_discovery /etc/init/guix-daemon.conf &&
                   start guix-daemon; } &&
                 _msg "${PAS}enabled Guix daemon via upstart"
             ;;
@@ -415,15 +404,15 @@ sys_enable_guix_daemon()
             { # systemd .mount units must be named after the target directory.
               # Here we assume a hard-coded name of /gnu/store.
               # XXX Work around <https://issues.guix.gnu.org/41356> until next release.
-              if [ -f ~root/.config/guix/current/lib/systemd/system/gnu-store.mount ]; then
-                  cp ~root/.config/guix/current/lib/systemd/system/gnu-store.mount \
+              if [ -f "~root/.config/guix/current/lib/systemd/system/gnu-store.mount" ]; then
+                  cp "~root/.config/guix/current/lib/systemd/system/gnu-store.mount" \
                      /etc/systemd/system/;
                   chmod 664 /etc/systemd/system/gnu-store.mount;
                   systemctl daemon-reload &&
                       systemctl enable gnu-store.mount;
               fi
 
-              cp ~root/.config/guix/current/lib/systemd/system/guix-daemon.service \
+              cp "~root/.config/guix/current/lib/systemd/system/guix-daemon.service" \
                  /etc/systemd/system/;
               chmod 664 /etc/systemd/system/guix-daemon.service;
 
@@ -437,9 +426,6 @@ sys_enable_guix_daemon()
                        -e 's/^Environment=\(.*\)$/Environment=\1 LC_ALL=en_US.UTF-8';
               fi;
 
-              configure_substitute_discovery \
-                  /etc/systemd/system/guix-daemon.service
-
               systemctl daemon-reload &&
                   systemctl enable guix-daemon &&
                   systemctl start  guix-daemon; } &&
@@ -447,12 +433,10 @@ sys_enable_guix_daemon()
             ;;
         sysv-init)
             { mkdir -p /etc/init.d;
-              cp ~root/.config/guix/current/etc/init.d/guix-daemon \
+              cp "~root/.config/guix/current/etc/init.d/guix-daemon" \
                  /etc/init.d/guix-daemon;
               chmod 775 /etc/init.d/guix-daemon;
 
-              configure_substitute_discovery /etc/init.d/guix-daemon
-
               update-rc.d guix-daemon defaults &&
                   update-rc.d guix-daemon enable &&
                   service guix-daemon start; } &&
@@ -460,12 +444,10 @@ sys_enable_guix_daemon()
             ;;
         openrc)
             { mkdir -p /etc/init.d;
-              cp ~root/.config/guix/current/etc/openrc/guix-daemon \
+              cp "~root/.config/guix/current/etc/openrc/guix-daemon" \
                  /etc/init.d/guix-daemon;
               chmod 775 /etc/init.d/guix-daemon;
 
-              configure_substitute_discovery /etc/init.d/guix-daemon
-
               rc-update add guix-daemon default &&
                   rc-service guix-daemon start; } &&
                 _msg "${PAS}enabled Guix daemon via OpenRC"
@@ -490,9 +472,9 @@ sys_enable_guix_daemon()
 sys_authorize_build_farms()
 { # authorize the public key of the build farm
     if prompt_yes_no "Permit downloading pre-built package binaries from the \
-project's build farm? (yes/no)"; then
+project's build farm? (yes/no) "; then
         guix archive --authorize \
-             < ~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub \
+             < "~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"
@@ -517,7 +499,7 @@ export INFOPATH="$_GUIX_PROFILE/share/info:$INFOPATH"
 GUIX_PROFILE="$HOME/.guix-profile"
 [ -L $GUIX_PROFILE ] || return
 GUIX_LOCPATH="$GUIX_PROFILE/lib/locale"
-export GUIX_LOCPATH
+export GUIX_PROFILE GUIX_LOCPATH
 
 [ -f "$GUIX_PROFILE/etc/profile" ] && . "$GUIX_PROFILE/etc/profile"
 

etc/indent-code.el

@@ -0,0 +1,117 @@
+:;exec emacs --batch --quick --load="$0" --funcall=main "$@"
+;;; indent-code.el --- Run Emacs to indent a package definition.
+
+;; Copyright © 2017 Alex Kost <alezost@gmail.com>
+;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+
+;; 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This scripts indents the given file or package definition in the specified
+;; file using Emacs.
+
+;;; Code:
+
+;; Load Scheme indentation rules from ".dir-locals.el".
+(with-temp-buffer
+  (scheme-mode)
+  (let ((default-directory (file-name-as-directory load-file-name))
+        (enable-local-variables :all))
+    (hack-dir-local-variables)
+    (hack-local-variables-apply)))
+
+;; Add indentation info for Scheme constructs that are not Guix-specific.
+;; This is normally provided by Geiser but this file is for people who may not
+;; be running Geiser, so we just copy it here (from 'geiser-syntax.el').
+(defmacro guix-syntax--scheme-indent (&rest pairs)
+  `(progn ,@(mapcar (lambda (p)
+                      `(put ',(car p) 'scheme-indent-function ',(cadr p)))
+                    pairs)))
+
+(guix-syntax--scheme-indent
+ (and-let* 1)
+ (case-lambda 0)
+ (catch defun)
+ (class defun)
+ (dynamic-wind 0)
+ (guard 1)
+ (let*-values 1)
+ (let-values 1)
+ (let/ec 1)
+ (letrec* 1)
+ (match 1)
+ (match-lambda 0)
+ (match-lambda* 0)
+ (match-let scheme-let-indent)
+ (match-let* 1)
+ (match-letrec 1)
+ (opt-lambda 1)
+ (parameterize 1)
+ (parameterize* 1)
+ (receive 2)
+ (require-extension 0)
+ (syntax-case 2)
+ (test-approximate 1)
+ (test-assert 1)
+ (test-eq 1)
+ (test-equal 1)
+ (test-eqv 1)
+ (test-group-with-cleanup 1)
+ (test-runner-on-bad-count! 1)
+ (test-runner-on-bad-end-name! 1)
+ (test-runner-on-final! 1)
+ (test-runner-on-group-begin! 1)
+ (test-runner-on-group-end! 1)
+ (test-runner-on-test-begin! 1)
+ (test-runner-on-test-end! 1)
+ (test-with-runner 1)
+ (unless 1)
+ (when 1)
+ (while 1)
+ (with-exception-handler 1)
+ (with-syntax 1))
+
+
+(defun main ()
+  (pcase command-line-args-left
+    (`(,file-name ,package-name)
+     ;; Indent the definition of PACKAGE-NAME in FILE-NAME.
+     (find-file file-name)
+     (goto-char (point-min))
+     (if (re-search-forward (concat "^(define\\(\\|-public\\) +"
+                                    package-name)
+                            nil t)
+         (let ((indent-tabs-mode nil))
+           (beginning-of-defun)
+           (indent-sexp)
+           (save-buffer)
+           (message "Done!"))
+       (error "Package '%s' not found in '%s'"
+              package-name file-name)))
+    (`(,file-name)
+     ;; Indent all of FILE-NAME.
+     (find-file file-name)
+     (let ((indent-tabs-mode nil))
+       (indent-region (point-min) (point-max))
+       (save-buffer)
+       (message "Done!")))
+    (x
+     (error "Usage: indent-code.el FILE [PACKAGE]"))))
+
+;;; indent-code.el ends here

etc/init.d/guix-daemon.in

@@ -36,7 +36,7 @@ start)
       -E LC_ALL=en_US.utf8 \
       -p "/var/run/guix-daemon.pid" \
       @localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon \
-      --build-users-group=guixbuild --discover=no
+      --build-users-group=guixbuild
   fi
   ;;
 stop)

etc/news.scm

@@ -1,22 +1,19 @@
 ;; GNU Guix news, for use by 'guix pull'.
 ;;
-;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
 ;; 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 © 2019, 2020, 2021 Florian Pelz <pelzflorian@pelzflorian.de>
 ;; 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 © 2020, 2021 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 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>
 ;;
 ;; Copying and distribution of this file, with or without modification, are
 ;; permitted in any medium without royalty provided the copyright notice and
@@ -25,721 +22,6 @@
 (channel-news
  (version 0)
 
- (entry (commit "094a2cfbe45c104d0da30ff9d975d052ca0c118c")
-        (title
-         (en "New @command{guix home container} command")
-         (de "Neuer Befehl @command{guix home container}")
-         (fr "Nouvelle commande @command{guix home container}"))
-        (body
-         (en "The new @command{guix home} tool, which lets you to manage
-entire \"home environments\" in a declarative fashion, has gained a
-@command{container} sub-command.  The new @command{guix home container}
-command allows you to test your configuration in an isolated @dfn{container},
-without touching your home directory:
-
-@example
-guix home container config.scm
-@end example
-
-This provides a simple and safe way to test your configuration before
-deploying it with @command{guix home reconfigure}.  Run @code{info \"(guix)
-Invoking guix home\"} for more information.")
-         (de "Das neue Werkzeug @command{guix home}, womit Sie vollständige
-„Persönliche Umgebungen“ deklarativ verwalten können, hat einen neuen
-Unterbefehl @command{container} hinzubekommen.  Mit dem neuen Befehl
-@command{guix home container} können Sie Ihre Konfiguration in einem isolierten
-@dfn{Container} ausprobieren, ohne Ihr Persönliches Verzeichnis anzutasten.
-
-@example
-guix home container config.scm
-@end example
-
-So ist es ein Leichtes, Ihre Konfiguration in einer sicheren Umgebung zu testen,
-bevor Sie mit @command{guix home reconfigure} auf sie umsteigen.  Führen Sie
-@code{info \"(guix.de) Aufruf von guix home\"} aus, um mehr zu erfahren.")
-         (fr "La nouvelle commande @command{guix home}, qui sert à gérer son
-« environnement d'accueil » de manière déclarative, dispose maintenant d'une
-sous-commande @command{container}.  La nouvelle commande @command{guix home
-container} permet de tester sa configuration dans un @dfn{conteneur} isolé,
-sans toucher à son répertoire d'accueil :
-
-@example
-guix home container config.scm
-@end example
-
-C'est un moyen simple et sûr de tester sa configuration avant de la déployer
-avec @command{guix home reconfigure}.  Lancer @code{info \"(guix.fr) Invoquer
-guix home\"} pour plus d'informations.")))
-
- (entry (commit "f1d18adbed39a3bacae93be29346fd4c86b480ef")
-        (title
-         (en "More compact @samp{guix pull --news}")
-         (de "@samp{guix pull --news} wird knapper")
-         (nl "Meer beknopte @samp{guix pull --news}"))
-        (body
-         (en "The output of @samp{guix pull --news} has been shortened to
-display only fresh news items such as this one.  It no longer includes the
-partial selection of new and updated packages, which was often long enough to
-be distracting whilst being too short to be useful.
-
-The complete list of new and updated packages can now be obtained separately
-using @samp{guix pull --news --details}.")
-         (de "Die Ausgabe von @samp{guix pull --news} wurde gekürzt
-und informiert nur mehr über ungezeigte Neuigkeiten wie diese. Es
-fehlt der unvollständige Bericht über neue und aktualisierte Pakete,
-der oft so lang war, dass er gestört hat, doch zu kurz war, um
-nützlich zu sein.
-
-Die vollständige Liste neuer und aktualisierter Pakete bekommen Sie
-jetzt mit @samp{guix pull --news --details}.")
-         (nl "De uitvoer van @samp{guix pull --news} is vanaf nu beperkt tot
-verse nieuwsberichten zoals dit, zonder de onvolledige bloemlezing van nieuwe
-en bijgewerkte pakketten.  Die was vaak lang genoeg om de lezer af te leiden
-maar te kort om nuttig te zijn.
-
-De volledige list van nieuwe en bijgewerkte pakketten is nu afzonderlijk
-beschikbaar met @samp{guix pull --news --details}.")))
-
- (entry (commit "96d7535b030c65b2d8cb0bea52c4bd96cbdefaf0")
-        (title
-         (en "ci.guix.gnu.org to stop offering Gzip substitutes")
-         (de "ci.guix.gnu.org wird keine Substitute mit Gzip mehr anbieten"))
-        (body
-         (en "This is a notice to let you know that starting next
-month (2022/03/01), Gzip-compressed substitutes will no longer be available,
-which means that Guix daemons from a revision older than commit
-@samp{3092f1b835d79655eecb2f8a79dda20ad9ba6bd6} (2019/06/02) will loose the
-ability to download binary substitutes.  Starting next month, only lzip and
-zstd substitutes will be offered.  Dropping Gzip substitutes will free about
-6.5 TiB of storage space from the build farm.")
-         (de "Hiermit weisen wir Sie darauf hin, dass ab nächstem
-Monat (2022/03/01) keine Gzip-komprimierten Substitute mehr zur Verfügung
-stehen.  Dadurch können Guix-Daemons, deren Version älter ist als Commit
-@samp{3092f1b835d79655eecb2f8a79dda20ad9ba6bd6} (2019/06/02), keine binären
-Substitute mehr beziehen.  Ab kommendem Monat werden nur Substitute mit lzip
-und zstd angeboten.  Indem wir auf Gzip-Substitute verzichten, sparen wir 6.5
-TiB Speicherplatz auf der Erstellungsfarm.")))
-
- (entry (commit "5c13484646069064c834bbd3cd02c3bc80d94cb6")
-        (title
-         (en "New @option{--execute} option to @command{guix deploy}")
-         (de "Neue Option @option{--execute} für @command{guix deploy}")
-         (fr "Nouvelle option @option{--execute} pour @command{guix deploy}"))
-        (body
-         (en "The @command{guix deploy} command has a new @option{--execute}
-or @option{-x} option, which allows you to execute a command on all the
-machines that your configuration file specifies, as in this example:
-
-@example
-guix deploy deploy.scm -x -- herd restart guix-daemon
-@end example
-
-This is no substitute for full-featured tools such as pdsh but it is a useful
-helper.")
-         (de "Der Befehl @command{guix deploy} verfügt über eine neue Option
-@option{--execute} oder @option{-x}, mit der Sie einen Befehl auf allen in der
-Konfigurationsdatei angegebenen Maschinen ausführen können.  Zum Beispiel:
-
-@example
-guix deploy deploy.scm -x -- herd restart guix-daemon
-@end example
-
-Dies ist kein Ersatz für vollumfängliche Werkzeuge wie pdsh, aber es kann doch
-von Nutzen sein.")
-         (fr "La commande @command{guix deploy} a une nouvelle option
-@option{--execute} ou @option{-x} qui permet d'exécuter une commande sur
-toutes les machines spécifiées dans son fichier de configuration, comme dans
-cet exemple :
-
-@example
-guix deploy deploy.scm -x -- herd restart guix-daemon
-@end example
-
-Ça ne remplace pas les outils sophistiqués comme pdsh mais c'est bien
-pratique.")))
-
- (entry (commit "c4fe13c294cc1e31dd8a49ce3981f603fb169e0a")
-        (title
-         (en "@command{guix style} can format package definitions")
-         (de "@command{guix style} kann Paketdefinitionen formatieren")
-         (fr "@command{guix style} peut mettre en forme les définitions de paquets"))
-        (body
-         (en "The recently-introduced @command{guix style} command can now be
-used to automatically format package definitions according to the Guix
-project's formatting guidelines.  If you contribute packages to Guix or to a
-third-party channel, you may find it useful.
-
-The new @option{--styling} option can currently be passed one of the following
-@dfn{styling rules}: @code{format}, to format package definitions, or
-@code{inputs}, to remove labels from package inputs.  Omitting
-@option{--styling} is equivalent to passing @samp{--styling=format};
-previously it was equivalent to @samp{--styling=inputs}.
-
-Run @code{info \"(guix) Invoking guix style\"}, for more info.")
-         (de "Der kürzlich eingeführte Befehl @command{guix style} kann jetzt
-benutzt werden, um Paketdefinitionen automatisch nach den
-Formatierungsrichtlinien des Guix-Projekts zu formatieren. Wenn Sie Pakete zu
-Guix oder zu einem Drittanbieterkanal beitragen, könnte Ihnen das helfen.
-
-Für die neue Befehlszeilenoption @option{--styling} können Sie derzeit eine
-der folgenden @dfn{Stilregeln} angeben: @code{format}, wodurch
-Paketdefinitionen formatiert werden, oder @code{inputs}, wodurch die
-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) 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
-suivant les règles de style du projet Guix.  Si vous contribuez des paquets à
-Guix ou à un canal tiers, cela peut vous être utile.
-
-La nouvelle option @option{--style} peut pour le moment recevoir une des deux
-@dfn{règles de style} suivantes : @code{format}, pour mettre en forme les
-définitions de paquet, ou @code{inputs}, pour retirer les étiquettes des
-champs @code{inputs} des paquets.  Omettre @option{--styling} revient à passer
-@samp{--styling=format} ; auparavant c'était équivalent à
-@samp{--styling=inputs}.
-
-Lancer @command{info \"(guix.fr) Invoquer guix style\"}, pour plus
-d'informations.")))
-
- (entry (commit "d090e9c37d693f5a0f381482c17fb03462cb6a48")
-        (title
-         (en "New @option{--tune} option for CPU micro-architecture tuning")
-         (de "Neue Option @option{--tune} ermöglicht mikroarchitekturspezifische Optimierungen")
-         (fr "Nouvelle option @option{--tune} pour optimiser pour une
-micro-architecture"))
-        (body
-         (en "The new @option{--tune} package transformation option instructs
-Guix to tune relevant packages for the micro-architecture of the host CPU.
-This lets the compiler use single-instruction/multiple-data (SIMD)
-instructions beyond the baseline instruction set architecture (ISA), which can
-noticeably improve performance in some cases such as linear algebra code.
-
-As an example, here is how you would install the GNU Astronomy Utilities
-against an optimized variant of the GNU Scientific Library (GSL):
-
-@example
-guix install gnuastro --tune
-@end example
-
-Run @command{info \"(guix) Package Transformation Options\"} for more
-information.")
-         (de "Die neue Paketumwandlungsoption @option{--tune} lässt Guix die
-betroffenen Pakete an die im Prozessor dieses Rechners benutzte
-Mikroarchitektur anpassen.  Dadurch kann der Compiler Befehle für
-Single-Instruction/Multiple-Data (SIMD) einsetzen, die über den gemeinsamen
-Befehlssatz hinausgehen. Das kann in manchen Fällen die Leistung beträchtlich
-steigern, etwa für Berechnungen der linearen Algebra.
-
-Zum Beispiel würden Sie so die GNU-Astronomieprogramme unter Nutzung einer
-optimierten Variante der GNU Scientific Library (GSL) installieren:
-
-@example
-guix install gnuastro --tune
-@end example
-
-Führen Sie für mehr Informationen @command{info \"(guix.de)
-Paketumwandlungsoptionen\"} aus.")
-         (fr "La nouvelle option de transformation de paquets @option{--tune}
-demande à Guix d'optimiser les paquets pour lesquels c'est pertinent pour la
-micro-architecture du processeur hôte.  Cela permet au compilateur d'utiliser
-des instructions vectorielles (SIMD) en plus des instructions de base de
-l'architecture, ce qui peut sensiblement améliorer les performance dans
-certains cas tels que pour du code d'algèbre linéaire.
-
-Par exemple, voici comment installer les Utilitaires d'astronomie GNU de
-manière à ce qu'ils utilisent une variante optimisée de la Bibliothèque
-scientifique GNU (GSL) :
-
-@example
-guix install gnuastro --tune
-@end example
-
-Lancer @command{info \"(guix.fr) Options de transformation de paquets\"} pour
-plus d'informations.")))
-
- (entry (commit "ea2fd313d52dc62593b478acf5c3e7ea052c45de")
-        (title
-         (en "@samp{integer expected from stream}?  Update your Guix daemon")
-         (de "@samp{integer expected from stream}? Aktualisieren Sie Ihren Guix-Daemon")
-         (nl "@samp{integer expected from stream}?  Werk je Guix daemon bij"))
-        (body
-         (en "We recently fixed a bug where substitution would fail with
-@samp{error: integer expected from stream}.  Be sure to update your system's
-Guix package that provides the @command{guix-daemon} if you haven't done so
-recently.  Run @command{info \"(guix) Upgrading Guix\"} for instructions.")
-         (de "Unlängst haben wir einen Fehler behoben, dass die Substitution
-mit der Fehlermeldung @samp{error: integer expected from stream}
-fehlschlägt. Bitte aktualisieren Sie daher Ihr systemweites Guix-Paket, das
-@command{guix-daemon} zur Verfügung stellt, wenn es noch nicht geschehen
-ist. Führen Sie @command{info \"(guix.de) Aktualisieren von Guix\"} aus für
-genaue Anweisungen.")
-         (nl "Onlangs herstelden we een fout waarbij substitutie mislukt met
-een @samp{error: integer expected from stream}.  Werk zeker je systeemwijde
-Guix-pakket bij, dat de @command{guix-daemon} levert, als dat nog niet is
-gebeurd.  Voer @command{info \"(guix) Upgrading Guix\"} uit voor meer uitleg.")))
-
- (entry (commit "223f1b1eb3707f1d3ef91200dd616ee6c8b77db0")
-        (title
-         (en "Improved static networking support on Guix System")
-         (de "Bessere Unterstützung für statische Netzwerkanbindungen auf Guix System")
-         (fr "Meilleure prise en charge des réseaux statiques sur Guix System"))
-        (body
-         (en "Support for declarative static networking setup on Guix System
-has been improved.  It now allows you to list IPv4 and IPv6 addresses in
-routes in a flexible way, similar to what you would do with the @command{ip}
-command, but in a declarative fashion, as in this example:
-
-@lisp
-;; Static networking for one NIC, IPv4-only.
-(service static-networking-service-type
-         (list (static-networking
-                (addresses
-                 (list (network-address
-                        (device \"eno1\")
-                        (value \"10.0.2.15/24\"))))
-                (routes
-                 (list (network-route
-                        (destination \"default\")
-                        (gateway \"10.0.2.2\"))))
-                (name-servers '(\"10.0.2.3\")))))
-@end lisp
-
-The @code{static-networking-service} procedure remains available but is
-deprecated.  Run @command{info \"(guix) Networking Setup\"} for more
-information.")
-         (de "Die deklarative Konfiguration für statische Netzwerkanbindungen
-auf Guix System wurde verbessert.  Sie können jetzt die IPv4- und
-IPv6-Adressen in Routen flexibel auflisten, ähnlich wie Sie es mit dem
-@command{ip}-Befehl tun würden, aber auf deklarative Weise wie in diesem
-Beispiel:
-
-@lisp
-;; Statische Netzwerkkonfiguration mit einer Netzwerkkarte, nur IPv4.
-(service static-networking-service-type
-         (list (static-networking
-                (addresses
-                 (list (network-address
-                        (device \"eno1\")
-                        (value \"10.0.2.15/24\"))))
-                (routes
-                 (list (network-route
-                        (destination \"default\")
-                        (gateway \"10.0.2.2\"))))
-                (name-servers '(\"10.0.2.3\")))))
-@end lisp
-
-Die Prozedur @code{static-networking-service} gibt es noch, aber sie gilt als
-veraltet.  Führen Sie @command{info \"(guix) Networking Setup\"} aus für
-weitere Informationen.")
-         (fr "La configuration déclarative et statique du réseau est mieux
-prise en charge sur Guix System.  Il est maintenant possible d'énumérer des
-adresses IPv6 et IPv4 et les chemins avec plus de flexibilité, un peu comme ce
-qu'on peut faire avec la commande @command{ip} mais de manière déclarative,
-comme dans cet exemple :
-
-@lisp
-;; Réseau statique à une seule interface, IPv4 seulement.
-(service static-networking-service-type
-         (list (static-networking
-                (addresses
-                 (list (network-address
-                        (device \"eno1\")
-                        (value \"10.0.2.15/24\"))))
-                (routes
-                 (list (network-route
-                        (destination \"default\")
-                        (gateway \"10.0.2.2\"))))
-                (name-servers '(\"10.0.2.3\")))))
-@end lisp
-
-La procédure @code{static-networking-service} reste disponible mais elle est
-obsolète.  Lancer @command{info \"(guix) Networking Setup\"} pour plus
-d'informations.")))
-
- (entry (commit "52cb5cf5b852117b5151a67af187d80764849ad3")
-        (title
-         (en "Icedove 91: profile folder moved to @file{~/.thunderbird}")
-         (de "Icedove 91: Profilordner jetzt unter @file{~/.thunderbird}"))
-        (body
-         (en "Icedove 91 expects your profile folder under @file{~/.thunderbird}.
-You need to manually copy your Icedove profiles from @file{~/.icedove} to
-@file{~./thunderbird}.  It may be required to start Icedove with
-@option{--ProfileManager} for the first time after the migration.")
-         (de "Icedove 91 erwartet Ihren Profilordner unter @file{~/.thunderbird}.
-Dafür müssen sie Ihre Icedove-Profile von @file{~/.icedove} nach
-@file{~/.thunderbird} kopieren.  Eventuell muss Icedove das erste Mal nach der
-Migration mit @option{--ProfileManager} gestartet werden.")))
-
- (entry (commit "746584e0ca200e7bf51b139ceb36c19ea81d6ef1")
-        (title
-         (en "New @command{guix shell} command supersedes @command{guix
-environment}")
-         (de "Neuer Befehl @command{guix shell} löst @command{guix
-environment} ab")
-         (fr "Nouvelle commande @command{guix shell} en remplacement de
-@command{guix environment}"))
-        (body
-         (en "A new @command{guix shell} command is now available.  It is
-similar to @command{guix environment}, but with a more convenient interface
-(@command{guix environment} is deprecated but will remain available until May,
-1st 2023).  The main difference compared to @command{guix environment} is that
-the \"ad hoc\" mode is the default.  Thus, to create an interactive
-environment containing Python, NumPy, and SciPy, you would run:
-
-@example
-guix shell python python-numpy python-scipy
-@end example
-
-To get a development environment for, say, Inkscape, pass the @option{-D}
-flag:
-
-@example
-guix shell -D inkscape
-@end example
-
-Another difference is that running @command{guix shell} without arguments
-loads @file{manifest.scm} or @file{guix.scm} for the current directory or an
-ancestor, provided you allowed it.  The command maintains a cache to speed up
-access to such environments.
-
-Run @command{info \"(guix) Invoking guix shell\"} for more information.")
-         (de "Ein neuer Befehl @command{guix shell} ist ab jetzt
-verfügbar. Er ähnelt @command{guix environment}, ist aber leichter zu
-benutzen (@command{guix environment} gilt als veraltet, bleibt aber
-bis zum 1.@: Mai 2023 verfügbar). Der größte Unterschied ist, dass das
-Verhalten mit @option{--ad-hoc} nun der Normalfall ist. D.h.@: um eine
-interaktive Umgebung mit Python, NumPy und SciPy zu bekommen, lautet
-der Befehl:
-
-@example
-guix shell python python-numpy python-scipy
-@end example
-
-Wenn Sie eine Entwicklungsumgebung für, sagen wir, Inkscape schaffen
-wollen, übergeben Sie die Option @option{-D}:
-
-@example
-guix shell -D inkscape
-@end example
-
-Noch ein Unterschied ist, dass wenn Sie @command{guix shell} ohne
-Argumente ausführen, @file{manifest.scm} oder @file{guix.scm} aus dem
-aktuellen Arbeitsverzeichnis oder einem übergeordneten Verzeichnis
-geladen wird, wenn Sie die Berechtigung dazu erteilt haben. Für den
-Befehl wird ein Zwischenspeicher vorgehalten, damit Sie schneller auf
-solche Umgebungen zugreifen können.
-
-Führen Sie @command{info \"(guix) Invoking guix shell\"} aus, um mehr
-zu erfahren.")
-         (fr "Une nouvelle commande, @command{guix shell}, est maintenant
-disponible.  Elle est similaire à @command{guix environment}, mais avec une
-interface plus pratique (@command{guix environment} est désuet mais restera
-disponible jusqu'au 1er mai 2023).  La principale différence par rapport à
-@command{guix environment} est que le mode par défaut est le mode \"ad hoc\".
-Pour créer un environnement interactif contenant Python, NumPy et SciPy, il
-faut donc lancer :
-
-@example
-guix shell python python-numpy python-scipy
-@end example
-
-Pour obtenir un environnement de développement pour Inkscape, par exemple,
-passer l'option @option{-D} :
-
-@example
-guix shell -D inkscape
-@end example
-
-Une autre différence est qu'en lançant @command{guix shell} sans argument, le
-fichier @file{manifest.scm} ou @file{guix.scm} du répertoire courant ou d'un
-parent est automatiquement chargé, à condition de l'avoir autorisé.  La
-commande garde un cache pour accélérer l'accès à ces environnements.
-
-Lancer @command{info \"(guix.fr) Invoquer guix shell\"} pour plus
-d'informations.")))
-
- (entry (commit "a2324d8b56eabf8117bca220a507cc791edffd2e")
-        (title
-         (en "Guix Home is a part of GNU Guix")
-         (de "Guix Home ist jetzt Teil von GNU Guix")
-         (ru "Guix Home теперь поставляется в составе GNU Guix"))
-        (body
-         (en "Guix Home splitted out from rde project and now is a part of
-Guix proper.  It is available as a @emph{technology preview} and thus subject
-to change.
-
-The new @command{guix home} command with its actions allows users to
-manage their packages and configurations (aka. dotfiles) in a declarative way,
-similar to how many people manage their system with @command{guix system}.
-
-Take a look at available actions and arguments:
-@example
-guix home --help
-@end example
-
-See @command{info \"(guix) Home Configuration\"} for more information.")
-         (de "Guix Home ist aus dem rde-Projekt ins offizielle Guix übernommen
-worden. Es ist als @emph{Technologievorschau} bereits verfügbar, aber die
-Schnittstelle kann sich in Zukunft noch ändern.
-
-Der neue Befehl @command{guix home} ermöglicht es, die Pakete und
-Konfigurationsdateien (Dotfiles) für ein Benutzerkonto im deklarativen Stil zu
-verwalten. Es ist analog dazu, wie man @command{guix system} benutzen kann, um
-sein System zu verwalten.
-
-Werfen Sie einen Blick auf die verfügbaren Aktionen und Argumente:
-@example
-guix home --help
-@end example
-
-Führen Sie für mehr Informationen @command{info \"(guix) Home Configuration\"}
-aus.")
-         (ru "Guix Home отделился от проекта rde и теперь является частью
-Guix.  Новая команда @command{guix home} даёт возможность пользователям
-управлять их пакетами и конфигурациями (дотфайлами) для них в декларативном
-стиле, аналогично тому, как многие люди управляют своими системами с помощью
-@command{guix system}.
-
-Чтобы получить список доступных действий и аргументов:
-@example
-guix home --help
-@end example
-
-Смотрите @command{info \"(guix) Home Configuration\"} для получения более
-детальных сведений.")))
-
- (entry (commit "5b32ad4f6f555d305659cee825879df075b06331")
-        (title
-         (en "New @option{--max-depth} option for @command{guix graph}")
-         (de "Neue Option @option{--max-depth} für @command{guix graph}")
-         (fr "Nouvelle option @option{--max-depth} pour @command{guix graph}"))
-        (body
-         (en "The @command{guix graph} command has a new @option{--max-depth}
-(or @option{-M}) option, which allows you to restrict a graph to the given
-depth---very useful when visualizing large graphs.  For example, the command
-below displays, using the @code{xdot} package, the dependency graph of
-LibreOffice, including only nodes that are at most at distance 2 of
-LibreOffice itself:
-
-@example
-guix graph -M 2 libreoffice | xdot -
-@end example
-
-See @command{info \"(guix) Invoking guix graph\"} for more information.")
-         (de "Der Befehl @command{guix graph} verfügt über eine neue
-Befehlszeilenoption @option{--max-depth} (oder @option{-M}), mit der
-Sie einen Graphen auf die angegebene Tiefe einschränken. Das ist vor
-allem bei großen Graphen nützlich; zum Beispiel zeigt der folgende
-Befehl, unter Verwendung des Pakets @code{xdot}, den
-Abhängigkeitsgraphen von LibreOffice unter Ausschluss der Knoten, die
-eine Distanz größer als 2 von LibreOffice selbst haben:
-
-@example
-guix graph -M 2 libreoffice | xdot -
-@end example
-
-Führen Sie @code{info \"(guix.de) Aufruf von guix graph\"} aus, um mehr zu
-erfahren.")
-         (fr "La commande @command{guix graph} dispose d'une nouvelle option
-@option{--max-depth} (ou @option{-M}) pour restreindre la profondeur d'un
-graphe---très utile pour visualiser des gros graphes.  Par exemple, la
-commande ci-dessous affiche, en utilisant @code{xdot}, le graphe de dépendance
-de LibreOffice en n'incluant que les nœuds qui sont au plus à distance 2 de
-LibreOffice soi-même :
-
-@example
-guix graph -M 2 libreoffice | xdot -
-@end example
-
-Voir @command{info \"(guix.fr) Invoquer guix graph\"} pour plus
-d'informations.")))
-
- (entry (commit "05f44c2d858a1e7b13c90362c35fa86bdc4d5a24")
-        (title
-         (en "Channel clones fall back to Software Heritage")
-         (de "Zum Klonen von Kanälen wird notfalls auf Software Heritage zurückgegriffen")
-         (fr "Les clones de canaux peuvent recourir à Software Heritage"))
-        (body
-         (en "When @command{guix time-machine} or @command{guix pull} fetches
-a channel pinned to a specific commit, it now automatically falls back to
-cloning it from the Software Heritage archive if the original URL is
-unreachable.  This contributes to long-term reproducibility.  See
-@command{info \"(guix) Replicating Guix\"}.
-
-Automatic fallback also works for other Git clones made on your behalf, such
-as when using @option{--with-commit} and related package transformation
-options.")
-         (de "Wenn bei @command{guix time-machine} oder @command{guix
-pull} ein bestimmter Commit eines Kanals bezogen werden soll, wird
-jetzt für den Fall, dass die ursprüngliche URL unerreichbar ist,
-automatisch vom Software-Heritage-Archiv geklont. Das trägt zur
-langfristigen Reproduzierbarkeit bei. Siehe @command{info \"(guix.de)
-Guix nachbilden\"}.
-
-Der automatische Rückgriff auf Software Heritage findet auch
-Verwendung bei anderen Arten von Git-Klon, die Guix durchführt, z.B.@:
-wenn Sie @option{--with-commit} und ähnliche Paketumwandlungsoptionen
-einsetzen.")
-         (fr "Quand la commande @command{guix time-machine} ou @command{guix
-pull} récupère un canal fixé à une révision spécifique, elle est maintenant
-capable de le cloner depuis l'archive Software Heritage si l'URL initiale
-n'est plus disponible.  Cela contribue à la reproductibilité à long terme.
-Voir @command{info \"(guix.fr) Répliquer Guix\"}.
-
-Ce recours à Software Heritage fonctionne aussi pour les autres clones Git que
-Guix peut faire, comme lorsqu'on utilise @option{--with-commit} et les options
-de transformation de paquet similaires.")))
-
- (entry (commit "db4681a4c17d282a661552f2f57e5c453d02e414")
-        (title
-         (en "@code{gdm-service-type} now supports Wayland")
-         (de "@code{gdm-service-type} bietet nun Unterstützung für Wayland")
-         (fr "@code{gdm-service-type} prend maintenant en charge Wayland"))
-        (body
-         (en "@code{gdm-service-type} has been updated to support being launched
-as a Wayland client, and to launch Wayland sessions. The @code{wayland?} boolean
-field in @code{gdm-configuration} controls whether GDM starts in Wayland or X
-mode. See @command{info \"(guix) X Window\"} for more information.
-
-Wayland mode for GDM will soon become the default in Guix, so if your
-hardware doesn't support Wayland (Nvidia users are the most concerned here),
-please consider disabling it now.")
-         (de "@code{gdm-service-type} wurde um Unterstützung dafür
-aktualisiert, als Wayland-Client gestartet zu werden und Wayland-Sitzungen zu
-starten.  Der Boolesche Wert im Feld @code{wayland?} in
-@code{gdm-configuration} bestimmt, ob GDM im Wayland- oder X-Modus gestartet
-wird.  Siehe @command{info \"(guix.de) X Window\"} für weitere Informationen.
-
-Bald wird der Wayland-Modus für GDM die Vorgabeeinstellung in Guix werden,
-daher sollten Sie, wenn Ihre Hardware kein Wayland unterstützt (Nvidia-Nutzer
-betrifft dies am ehesten), ihn jetzt ausdrücklich abschalten.")
-         (fr "@code{gdm-service-type} a été mis à jour et peut maintenant être
-lancé comme client Wayland, ainsi que lancer des sessions Wayland. Le champ
-booléen @code{wayland?} de @code{gdm-configuration} contrôle le mode dans lequel
-GDM est lancé (Wayland ou X). Pour plus d'informations, voir
-@command{info \"(guix) X Window\"} (en anglais).
-
-GDM sera bientôt lancé en mode Wayland par défaut sur Guix, donc si votre matériel
-ne le prend pas en charge (les utilisateur·ices de cartes Nvidia sont les plus
-concerné·es), merci de le désactiver dès maintenant.")))
-
- (entry (commit "f23803af2018a148fb088f2516d79c20d6bf95f0")
-        (title
-         (en "Input labels can now be omitted in package definitions")
-         (de "Eingaben in Paketdefinitionen brauchen keine Bezeichnungen mehr"))
-        (body
-         (en "If you have written package definitions before, you may know
-that package inputs required a bit of boilerplate: each input needs to have an
-associated label (a string), which you can refer to in ``build-side code''.
-
-Input labels are now unnecessary, meaning that you can write code like:
-
-@lisp
-(package
-  ;; @dots{}
-  (inputs (list libunistring libffi libgc)))
-@end lisp
-
-Notice that the @code{inputs} field is simplified compared to the ``old
-style''.  When needed, you can now use g-expressions (gexps) to refer to
-another package in build-side code.  Additionally, the new
-@code{modify-inputs} macro facilitates common operations on inputs---deleting,
-replacing, adding inputs.
-
-To ease transition to the ``new style'', a new @command{guix style} command is
-provided.  Run @command{info \"(guix) Invoking guix style\"} for more info.")
-         (de "Wenn Sie bereits Paketdefinitionen verfasst haben,
-erinnern Sie sich vielleicht, dass Sie für Paketeingaben manches
-doppelt schreiben mussten: Jede Eingabe wird assoziiert mit einer
-Bezeichnung (als Zeichenkette), auf die Sie sich in
-„erstellungsseitigem Code“ beziehen können.
-
-Diese Eingabebezeichnungen sind @emph{nicht} mehr nötig.  Sie können
-jetzt solchen Code schreiben:
-
-@lisp
-(package
-  ;; …
-  (inputs (list libunistring libffi libgc)))
-@end lisp
-
-Achten Sie auf das gegenüber früher vereinfachte @code{inputs}-Feld.
-Wenn nötig können Sie in erstellungsseitigem Code G-Ausdrücke (gexps)
-benutzen, um andere Pakete zu referenzieren.  Des Weiteren erleichtert
-das Makro @code{modify-inputs} geläufige Operationen auf Eingaben —
-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) Invoking guix style\"} aus, um mehr Informationen zu
-erhalten.")))
-
- (entry (commit "82daab42811a2e3c7684ebdf12af75ff0fa67b99")
-        (title
-         (en "New @samp{deb} format for the @command{guix pack} command")
-         (de "Neues Format @samp{deb} für den Befehl @command{guix pack}"))
-        (body
-         (en "Debian archives (with the .deb file extension) can now be
-produced via the @command{guix pack --format=deb} command, providing an
-alternative distribution path for software built with Guix.  Here is a simple
-example that generates a Debian archive for the @code{hello} package:
-
-@example
-guix pack --format=deb --symlink=/usr/bin/hello=bin/hello hello
-@end example
-
-See @command{info \"(guix) Invoking guix pack\"} for more information.")
-         (de "Debian-Archive (mit der Dateinamenserweiterung .deb) können
-jetzt auch mit dem Befehl @command{guix pack --format=deb} erzeugt werden, um
-mit Guix erstellte Software auf andere Art anzubieten.  Hier sehen Sie ein
-einfaches Beispiel, wie ein Debian-Archiv für das Paket @code{hello} angelegt
-wird:
-
-@example
-guix pack --format=deb --symlink=/usr/bin/hello=bin/hello hello
-@end example
-
-Siehe @command{info \"(guix.de) Aufruf von guix pack\"} für mehr
-Informationen.")))
-
- (entry (commit "bdc298ecee15283451d3aa20a849dd7bb22c8538")
-        (title
-         (en "New @command{guix import egg} command")
-         (de "Neuer Befehl @command{guix import egg}")
-         (zh "新的 @command{guix import egg} 命令"))
-        (body
-         (en "The new @command{guix import egg} command allows packagers to
-generate a package definition or a template thereof given the name of a
-CHICKEN egg package, like so:
-
-@example
-guix import egg sourcehut
-@end example
-
-Run @command{info \"(guix) Invoking guix import\"} for more info.")
-         (de "Mit dem neuen Befehl @command{guix import egg} können
-Paketautoren eine Paketdefinition oder eine Vorlage dafür anhand des Namens
-eines „Egg“-Pakets für CHICKEN erzeugen, etwa so:
-
-@example
-guix import egg sourcehut
-@end example
-
-Führen Sie @command{info \"(guix.de) Aufruf von guix import\"} aus, um mehr
-Informationen zu bekommen.")
-         (zh "新的 @command{guix import egg} 命令能让贡献者从一个CHICKEN egg生
-成一个包装或包装样板。
-
-@example
-guix import egg sourcehut
-@end example
-
-想了解更多可以运行 @command{info \"(guix) Invoking guix import\"}。")))
-
  (entry (commit "2161820ebbbab62a5ce76c9101ebaec54dc61586")
         (title
          (en "Risk of local privilege escalation during user account creation")
@@ -964,7 +246,7 @@ Nous conseillons de mettre à jour @command{guix-daemon}.  Lancer @command{info
 \"(guix.fr) Mettre à niveau Guix\"} pour voir comment faire.  Voir
 @uref{https://issues.guix.gnu.org/47229} pour plus d'informations sur cette
 faille.")
-         (nl "In @command{guix-daemon} werd een beveiligingsprobleem
+                  (nl "In @command{guix-daemon} werd een beveiligingsprobleem
 gevonden dat kan leiden tot de escalatie van lokale bevoegdheden.  Het
 probleem doet zich voor bij installaties met meerdere gebruikers waarop een
 lokale @command{guix-daemon} draait.
@@ -1054,7 +336,7 @@ guix import go golang.org/x/sys
 @end example
 
 Lancez @command{info \"(guix.fr) Invoquer guix import\"} pour en savoir plus.")
-         (nl "Met de nieuwe @command{guix import go}-opdracht kunnen
+                  (nl "Met de nieuwe @command{guix import go}-opdracht kunnen
 pakketschrijvers een pakketdefinitie of -sjabloon aanmaken, op basis van de
 naam van een Go-pakket te vinden op @url{https://proxy.golang.org}:
 
@@ -1067,28 +349,28 @@ informatie.")))
 
  (entry (commit "1b5b882120daf7d111aa351a919a90e818324347")
         (title
-         (en "The @code{linux-libre} kernel is updated to 5.11.2")
-         (de "Der Kernel @code{linux-libre} wird auf 5.11.2 aktualisiert")
-         (fr "Le noyau @code{linux-libre} est mis à jour vers la 5.11.2")
-         (nl "De @code{linux-libre}-kernel werd bijgewertk naar 5.11.2"))
+          (en "The @code{linux-libre} kernel is updated to 5.11.2")
+          (de "Der Kernel @code{linux-libre} wird auf 5.11.2 aktualisiert")
+          (fr "Le noyau @code{linux-libre} est mis à jour vers la 5.11.2")
+          (nl "De @code{linux-libre}-kernel werd bijgewertk naar 5.11.2"))
         (body
-         (en "The default @code{linux-libre} kernel is now based on the 5.11
+          (en "The default @code{linux-libre} kernel is now based on the 5.11
 stable kernel series, beginning with version 5.11.2.  Promiment features include
 improved Wine performance, unprivileged Overlayfs mounts, support for Intel SGX,
 support for new graphics hardware, and improved performance of the Btrfs
 file system.")
-         (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
+          (de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
 jetzt auf der 5.11-„stable“-Versionsreihe, angefangen mit Version 5.11.2.  Zu
 den markanten Neuerungen gehören bessere Wine-Unterstützung, Einbinden per
 Overlayfs für Nutzer ohne erweiterte Rechte, Unterstützung für Intel SGX, für
 neue Grafikhardware und bessere Leistung beim Btrfs-Dateisystem.")
-         (fr "Le noyau @code{linux-libre} par défaut est maintenant basé sur la
+          (fr "Le noyau @code{linux-libre} par défaut est maintenant basé sur la
 lignée stable 5.11 du noyau, à commencer par la version 5.11.2.  Parmi les
 fonctionnalités notables on trouve des performances améliorées pour Wine, le
 montage Overlayfs non privilégié, la prise en charge d'Intel SGX, celle des
 nouveaux périphériques graphiques et de meilleures performances du système de
 fichiers Btrfs.")
-         (nl "De standaard @code{linux-libre}-kernel is nu geëent op de
+          (nl "De standaard @code{linux-libre}-kernel is nu geëent op de
 stabiele 5.11-reeks, te beginnen met versie 5.11.2.  Deze update biedt onder
 andere verbeterde prestaties voor Wine en het Btfrs-bestandssysteem, laat
 gewone gebruikers toe om met Overlayfs bestandssystemen te combineren, en

etc/openrc/guix-daemon.in

@@ -20,7 +20,7 @@
 export GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale
 export LC_ALL=en_US.utf8
 command="@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon"
-command_args="--build-users-group=guixbuild --discover=no"
+command_args="--build-users-group=guixbuild"
 command_background="yes"
 pidfile="/var/run/guix-daemon.pid"
 

etc/release-manifest.scm

@@ -125,13 +125,8 @@ TARGET."
 (define %system-manifest
   (manifest
    (append-map (lambda (system)
-                 ;; Some of %SYSTEM-PACKAGES are currently unsupported on some
-                 ;; systems--e.g., GNOME on non-x86_64, due to Rust.  Filter
-                 ;; them out.
-                 (filter-map (lambda (package)
-                               (and (supported-package? package system)
-                                    (package->manifest-entry* package system)))
-                             %system-packages))
+                 (map (cut package->manifest-entry* <> system)
+                      %system-packages))
                '("x86_64-linux" "i686-linux"))))  ;Guix System
 
 (define %cross-manifest

etc/snippets/scheme-mode/guix-origin

@@ -19,9 +19,7 @@
                  (t "(string-append \\"https://\\" version \\".tar.gz\\")"))}$0)
  ${1:$(cond ((equal yas-text "git-fetch")
              "(file-name (git-file-name name version))")
-            ((equal yas-text "hg-fetch")
-             "(file-name (hg-file-name name version))")
-            ((member yas-text '("svn-fetch" "cvs-fetch" "bzr-fetch"))
+            ((member yas-text '("svn-fetch" "hg-fetch" "cvs-fetch" "bzr-fetch"))
              "(file-name (string-append name \\"-\\" version \\"-checkout\\"))")
             (t ""))}
  (sha256

etc/snippets/text-mode/guix-commit-message-update-package

@@ -8,7 +8,7 @@ gnu: ${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)
+           (when (re-search-forward "(define-public \\(\\S-+\\)" nil 'noerror)
              (match-string-no-properties 1)))`}: Update to ${2:`(with-temp-buffer
     (magit-git-wash #'magit-diff-wash-diffs
       "diff" "--staged")

etc/source-manifest.scm

@@ -1,66 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 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 origins of all the packages.  The
-;;; main purpose is to allow continuous integration services to keep upstream
-;;; source code around.  It can also be passed to 'guix weather -m'.
-
-(use-modules (srfi srfi-1) (srfi srfi-26)
-             (ice-9 match) (ice-9 vlist)
-             (guix packages) (guix profiles)
-             (gnu packages))
-
-(define (all-packages)
-  "Return the list of all the packages, public or private, omitting only
-superseded packages."
-  (fold-packages (lambda (package lst)
-                   (match (package-replacement package)
-                     (#f (cons package lst))
-                     (replacement
-                      (append (list replacement package) lst))))
-                 '()
-                 #:select? (negate package-superseded)))
-
-(define (upstream-origin source)
-  "Return SOURCE without any patches or snippet."
-  (origin (inherit source)
-          (snippet #f) (patches '())))
-
-(define (all-origins)
-  "Return the list of origins referred to by all the packages."
-  (let loop ((packages (all-packages))
-             (origins  '())
-             (visited   vlist-null))
-    (match packages
-      ((head . tail)
-       (let ((new (remove (cut vhash-assq <> visited)
-                          (package-direct-sources head))))
-         (loop tail (append new origins)
-               (fold (cut vhash-consq <> #t <>)
-                     visited new))))
-      (()
-       origins))))
-
-;; Return a manifest containing all the origins.
-(manifest (map (lambda (origin)
-                 (manifest-entry
-                   (name (or (origin-actual-file-name origin)
-                             "origin"))
-                   (version "0")
-                   (item (upstream-origin origin))))
-               (all-origins)))

etc/substitutes/bordeaux.guix.gnu.org.pub

@@ -1,6 +0,0 @@
-(public-key
- (ecc
-  (curve Ed25519)
-  (q #7D602902D3A2DBB83F8A0FB98602A754C5493B0B778C8D1DD4E0F41DE14DE34F#)
-  )
- )

gnu/bootloader.scm

@@ -2,7 +2,7 @@
 ;;; Copyright © 2017 David Craven <david@craven.ch>
 ;;; 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 © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,10 +25,7 @@
   #:use-module (guix gexp)
   #:use-module (guix profiles)
   #:use-module (guix records)
-  #:use-module (guix deprecation)
-  #:use-module ((guix ui) #:select (warn-about-load-error))
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
+  #:use-module (guix ui)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (menu-entry
@@ -58,8 +55,7 @@
             bootloader-configuration
             bootloader-configuration?
             bootloader-configuration-bootloader
-            bootloader-configuration-target ;deprecated
-            bootloader-configuration-targets
+            bootloader-configuration-target
             bootloader-configuration-menu-entries
             bootloader-configuration-default-entry
             bootloader-configuration-timeout
@@ -183,22 +179,12 @@ record."
 ;; The <bootloader-configuration> record contains bootloader independant
 ;; configuration used to fill bootloader configuration file.
 
-(define-with-syntax-properties (warn-target-field-deprecation
-                                (value properties))
-  (when value
-    (warning (source-properties->location properties)
-             (G_ "the 'target' field is deprecated, please use 'targets' \
-instead~%")))
-  value)
-
 (define-record-type* <bootloader-configuration>
   bootloader-configuration make-bootloader-configuration
   bootloader-configuration?
   (bootloader         bootloader-configuration-bootloader) ;<bootloader>
-  (targets            %bootloader-configuration-targets    ;list of strings
+  (target             bootloader-configuration-target      ;string
                       (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
@@ -218,19 +204,6 @@ instead~%")))
   (serial-speed       bootloader-configuration-serial-speed ;integer | #f
                       (default #f)))
 
-(define-deprecated (bootloader-configuration-target config)
-  bootloader-configuration-targets
-  (%bootloader-configuration-target config))
-
-(define (bootloader-configuration-targets config)
-  (or (%bootloader-configuration-targets config)
-      ;; TODO: Remove after the deprecated 'target' field is removed.
-      (list (%bootloader-configuration-target config))
-      ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
-      ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
-      ;; hence the default value of '(#f) rather than '().
-      (list #f)))
-
 
 ;;;
 ;;; Bootloaders.

gnu/bootloader/grub.scm

@@ -264,38 +264,36 @@ is a string that can be inserted in grub.cfg."
                          at_keyboard usb_keyboard))
 
          (io (string-append
-              ;; UNIT and SPEED are arguments to the same GRUB command
-              ;; ("serial"), so we process them together.
-              (if (or unit speed)
-                  (string-append
-                   "serial"
-                   (if unit
-                       ;; COM ports 1 through 4
-                       (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
-                           (string-append " --unit=" (number->string unit))
-                           #f)
-                       "")
-                   (if speed
-                       (if (exact-integer? speed)
-                           (string-append " --speed=" (number->string speed))
-                           #f)
-                       "")
-                   "\n")
-                  "")
-              (if (null? inputs)
-                  ""
-                  (string-append
+               "terminal_output "
+               (symbols->string
+                 (map
+                   (lambda (output)
+                     (if (memq output valid-outputs) output #f)) outputs)) "\n"
+               (if (null? inputs)
+                 ""
+                 (string-append
                    "terminal_input "
                    (symbols->string
-                    (map
-                     (lambda (input)
-                       (if (memq input valid-inputs) input #f)) inputs))
-                   "\n"))
-              "terminal_output "
-              (symbols->string
-               (map
-                (lambda (output)
-                  (if (memq output valid-outputs) output #f)) outputs)))))
+                     (map
+                       (lambda (input)
+                         (if (memq input valid-inputs) input #f)) inputs)) "\n"))
+               ;; UNIT and SPEED are arguments to the same GRUB command
+               ;; ("serial"), so we process them together.
+               (if (or unit speed)
+                 (string-append
+                   "serial"
+                   (if unit
+                     ;; COM ports 1 through 4
+                     (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
+                       (string-append " --unit=" (number->string unit))
+                       #f)
+                     "")
+                   (if speed
+                     (if (exact-integer? speed)
+                       (string-append " --speed=" (number->string speed))
+                       #f)
+                     ""))
+                 ""))))
     (format #f "~a" io)))
 
 (define (grub-root-search device file)
@@ -417,7 +415,8 @@ menuentry ~s {
           ;; Other type of devices aren't implemented.
           #~()))
     (let ((devices (map crypto-device->cryptomount store-crypto-devices))
-          (modules #~(format port "insmod luks~%insmod luks2~%")))
+          ;; XXX: Add luks2 when grub 2.06 is packaged.
+          (modules #~(format port "insmod luks~%")))
       (if (null? devices)
           devices
           (cons modules devices))))
@@ -648,12 +647,11 @@ below the directory TARGET for the system whose root is mounted at MOUNT-POINT.
 MOUNT-POINT is the last argument in 'guix system init /etc/config.scm mnt/point'
 or '/' for other 'guix system' commands.
 
-Where TARGET comes from the targets argument given to the
-bootloader-configuration in:
+TARGET is the target argument given to the bootloader-configuration in
 
 (operating-system
  (bootloader (bootloader-configuration
-              (targets '(\"/boot\"))
+              (target \"/boot\")
               …))
  …)
 

gnu/bootloader/u-boot.scm

@@ -73,12 +73,9 @@
 
 (define install-allwinner64-u-boot
   #~(lambda (bootloader root-index image)
-      (let ((spl (string-append bootloader "/libexec/u-boot-sunxi-with-spl.bin"))
-            (u-boot (string-append bootloader "/libexec/u-boot-sunxi-with-spl.fit.itb")))
+      (let ((spl (string-append bootloader "/libexec/u-boot-sunxi-with-spl.fit.itb")))
         (write-file-on-device spl (stat:size (stat spl))
-                              image (* 8 1024))
-        (write-file-on-device u-boot (stat:size (stat u-boot))
-                              image (* 40 1024)))))
+                              image (* 8 1024)))))
 
 (define install-imx-u-boot
   #~(lambda (bootloader root-index image)

gnu/build/accounts.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -490,11 +490,7 @@ new UIDs."
                                (uid id)
                                (directory directory)
                                (gid (if (number? group) group (group-id group)))
-
-                               ;; Users might change their name to something
-                               ;; other than what the sysadmin chose, with
-                               ;; 'chfn'.  Thus consider it "stateful".
-                               (real-name (if (and previous (not system?))
+                               (real-name (if previous
                                               (password-entry-real-name previous)
                                               real-name))
 

gnu/build/activation.scm

@@ -6,8 +6,6 @@
 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
-;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
-;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,7 +24,6 @@
 
 (define-module (gnu build activation)
   #:use-module (gnu system accounts)
-  #:use-module (gnu system setuid)
   #:use-module (gnu build accounts)
   #:use-module (gnu build linux-boot)
   #:use-module (guix build utils)
@@ -282,17 +279,14 @@ they already exist."
   "/run/setuid-programs")
 
 (define (activate-setuid-programs programs)
-  "Turn PROGRAMS, a list of file setuid-programs record, into setuid programs
-stored under %SETUID-DIRECTORY."
-  (define (make-setuid-program program setuid? setgid? uid gid)
+  "Turn PROGRAMS, a list of file names, into setuid programs stored under
+%SETUID-DIRECTORY."
+  (define (make-setuid-program prog)
     (let ((target (string-append %setuid-directory
-                                 "/" (basename program)))
-          (mode (+ #o0555                   ; base permissions
-                   (if setuid? #o4000 0)    ; setuid bit
-                   (if setgid? #o2000 0)))) ; setgid bit
-      (copy-file program target)
-      (chown target uid gid)
-      (chmod target mode)))
+                                 "/" (basename prog))))
+      (copy-file prog target)
+      (chown target 0 0)
+      (chmod target #o4555)))
 
   (format #t "setting up setuid programs in '~a'...~%"
           %setuid-directory)
@@ -308,27 +302,15 @@ stored under %SETUID-DIRECTORY."
   (for-each (lambda (program)
               (catch 'system-error
                 (lambda ()
-                  (let* ((program-name (setuid-program-program program))
-                         (setuid?      (setuid-program-setuid? program))
-                         (setgid?      (setuid-program-setgid? program))
-                         (user         (setuid-program-user program))
-                         (group        (setuid-program-group program))
-                         (uid (match user
-                                ((? string?) (passwd:uid (getpwnam user)))
-                                ((? integer?) user)))
-                         (gid (match group
-                                ((? string?) (group:gid (getgrnam group)))
-                                ((? integer?) group))))
-                    (make-setuid-program program-name setuid? setgid? uid gid)))
+                  (make-setuid-program program))
                 (lambda args
                   ;; If we fail to create a setuid program, better keep going
                   ;; so that we don't leave %SETUID-DIRECTORY empty or
                   ;; half-populated.  This can happen if PROGRAMS contains
                   ;; incorrect file names: <https://bugs.gnu.org/38800>.
                   (format (current-error-port)
-                          "warning: failed to make ~s setuid/setgid: ~a~%"
-                          (setuid-program-program program)
-                          (strerror (system-error-errno args))))))
+                          "warning: failed to make '~a' setuid-root: ~a~%"
+                          program (strerror (system-error-errno args))))))
             programs))
 
 (define (activate-special-files special-files)
@@ -389,8 +371,8 @@ improvement."
   "/run/current-system")
 
 (define (boot-time-system)
-  "Return the 'gnu.system' argument passed on the kernel command line."
-  (find-long-option "gnu.system" (if (string-contains %host-type "linux-gnu")
+  "Return the '--system' argument passed on the kernel command line."
+  (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
                                    (linux-command-line)
                                    (command-line))))
 

gnu/build/bootloader.scm

@@ -94,7 +94,6 @@ load the Grub bootloader located in the 'Guix_image' root partition."
         ;; (not eliminate it).
         (format port
                 "insmod part_msdos~@
-               insmod part_gpt~@
                search --set=root --label Guix_image~@
                configfile /boot/grub/grub.cfg~%")))
     (install-efi grub-efi grub-config esp)

gnu/build/chromium-extension.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,8 +17,13 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build chromium-extension)
+  #:use-module (gcrypt base16)
+  #:use-module ((gcrypt hash) #:prefix hash:)
+  #:use-module (ice-9 iconv)
   #:use-module (guix gexp)
   #:use-module (guix packages)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages check)
   #:use-module (gnu packages chromium)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages tls)
@@ -34,30 +39,28 @@
 
 (define (make-signing-key seed)
   "Return a derivation for a deterministic PKCS #8 private key using SEED."
-  (computed-file
-   (string-append seed "-signing-key.pem")
-   (with-extensions (list guile-gcrypt)
-     #~(begin
-         (use-modules (gcrypt base16) (gcrypt hash) (ice-9 iconv))
-         (let* ((sha256sum (bytevector->base16-string
-                            (sha256 (string->bytevector #$seed "UTF-8"))))
-                ;; certtool.c wants a 56 byte seed for a 2048 bit key.
-                (key-size 2048)
-                (normalized-seed (string-take sha256sum 56)))
 
-           (system* #$(file-append gnutls "/bin/certtool")
-                    "--generate-privkey"
-                    "--key-type=rsa"
-                    "--pkcs8"
-                    ;; Use the provable FIPS-PUB186-4 algorithm for
-                    ;; deterministic results.
-                    "--provable"
-                    "--password="
-                    "--no-text"
-                    (string-append "--bits=" (number->string key-size))
-                    (string-append "--seed=" normalized-seed)
-                    "--outfile" #$output))))
-   #:local-build? #t))
+  (define sha256sum
+    (bytevector->base16-string (hash:sha256 (string->bytevector seed "UTF-8"))))
+
+  ;; certtool.c wants a 56 byte seed for a 2048 bit key.
+  (define size 2048)
+  (define normalized-seed (string-take sha256sum 56))
+
+  (computed-file (string-append seed "-signing-key.pem")
+                 #~(system* #$(file-append gnutls "/bin/certtool")
+                            "--generate-privkey"
+                            "--key-type=rsa"
+                            "--pkcs8"
+                            ;; Use the provable FIPS-PUB186-4 algorithm for
+                            ;; deterministic results.
+                            "--provable"
+                            "--password="
+                            "--no-text"
+                            (string-append "--bits=" #$(number->string size))
+                            (string-append "--seed=" #$normalized-seed)
+                            "--outfile" #$output)
+                 #:local-build? #t))
 
 (define* (make-crx signing-key package #:optional (package-output "out"))
   "Create a signed \".crx\" file from the unpacked Chromium extension residing
@@ -65,9 +68,9 @@ in PACKAGE-OUTPUT of PACKAGE.  The extension will be signed with SIGNING-KEY."
   (define name (package-name package))
   (define version (package-version package))
 
-  (computed-file
-   (string-append name "-" version ".crx")
-   (with-imported-modules '((guix build utils))
+  (with-imported-modules '((guix build utils))
+    (computed-file
+     (string-append name "-" version ".crx")
      #~(begin
          ;; This is not great.  We pull Xorg and Chromium just to Zip and
          ;; sign an extension.  This should be implemented with something
@@ -75,22 +78,27 @@ in PACKAGE-OUTPUT of PACKAGE.  The extension will be signed with SIGNING-KEY."
          (use-modules (guix build utils))
          (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)
+               (packdir "/tmp/extension"))
+           (mkdir-p (dirname packdir))
+           (copy-recursively (ungexp package package-output) packdir)
            (system (string-append xvfb " :1 &"))
            (setenv "DISPLAY" ":1")
            (sleep 2)                    ;give Xorg some time to initialize...
-           (invoke chromium
-                   "--user-data-dir=chromium-profile"
+           ;; Chromium stores the current time in the .crx Zip archive.
+           ;; Use a fixed timestamp for deterministic behavior.
+           ;; FIXME (core-updates): faketime is missing an absolute reference
+           ;; to 'date', hence the need to set PATH.
+           (setenv "PATH" #$(file-append coreutils "/bin"))
+           (invoke #$(file-append libfaketime "/bin/faketime")
+                   "2000-01-01 00:00:00"
+                   chromium
+                   "--user-data-dir=/tmp/signing-profile"
                    (string-append "--pack-extension=" packdir)
                    (string-append "--pack-extension-key=" #$signing-key))
-           (copy-file (string-append packdir ".crx") #$output))))
-   #:local-build? #t))
+           (copy-file (string-append packdir ".crx") #$output)))
+     #:local-build? #t)))
 
-(define (crx->chromium-json crx version)
+(define* (crx->chromium-json crx version)
   "Return a derivation that creates a Chromium JSON settings file for the
 extension given as CRX.  VERSION is used to signify the CRX version, and
 must match the version listed in the extension manifest.json."
@@ -119,47 +127,66 @@ format."
                             "--outder")
                  #:local-build? #t))
 
-(define (file-sha256sum file)
-  (with-extensions (list guile-gcrypt)
-    #~(begin
-        (use-modules (gcrypt base16) (gcrypt hash))
-        (bytevector->base16-string (file-sha256 #$file)))))
+(define (chromium-json->profile-object json signing-key)
+  "Return a derivation that installs JSON to the directory searched by
+Chromium, using a file name (aka extension ID) derived from SIGNING-KEY."
+  (define der (signing-key->public-der signing-key))
 
-(define* (make-chromium-extension pkg #:optional (pkg-output "out"))
-  "Create a Chromium extension from package PKG and return a package that,
-when installed, will make the extension contained in PKG available as a
-Chromium browser extension.  PKG-OUTPUT specifies which output of PKG to use."
-  (let* ((name (package-name pkg))
-         (version (package-version pkg))
-         (private-key (make-signing-key name))
-         (public-key (signing-key->public-der private-key))
-         (checksum (file-sha256sum public-key))
-         (crx (make-crx private-key pkg pkg-output))
-         (json (crx->chromium-json crx version)))
+  (with-extensions (list guile-gcrypt)
+    (with-imported-modules '((guix build utils))
+      (computed-file
+       "chromium-extension"
+       #~(begin
+           (use-modules (guix build utils)
+                        (gcrypt base16)
+                        (gcrypt hash))
+           (define (base16-string->chromium-base16 str)
+             ;; Translate STR, a hexadecimal string, to a Chromium-style
+             ;; representation using the letters a-p (where a=0, p=15).
+             (define s1 "0123456789abcdef")
+             (define s2 "abcdefghijklmnop")
+             (let loop ((chars (string->list str))
+                        (converted '()))
+               (if (null? chars)
+                   (list->string (reverse converted))
+                   (loop (cdr chars)
+                         (cons (string-ref s2 (string-index s1 (car chars)))
+                               converted)))))
+
+           (let* ((checksum (bytevector->base16-string (file-sha256 #$der)))
+                  (file-name (base16-string->chromium-base16
+                              (string-take checksum 32)))
+                  (extension-directory (string-append #$output
+                                                      "/share/chromium/extensions")))
+             (mkdir-p extension-directory)
+             (symlink #$json (string-append extension-directory "/"
+                                            file-name ".json"))))
+       #:local-build? #t))))
+
+(define* (make-chromium-extension p #:optional (output "out"))
+  "Create a Chromium extension from package P and return a package that,
+when installed, will make the extension contained in P available as a
+Chromium browser extension.  OUTPUT specifies which output of P to use."
+  (let* ((pname (package-name p))
+         (version (package-version p))
+         (signing-key (make-signing-key pname)))
     (package
-      (inherit pkg)
-      (name (string-append name "-chromium"))
+      (inherit p)
+      (name (string-append pname "-chromium"))
       (source #f)
+      (build-system trivial-build-system)
       (native-inputs '())
-      (inputs '())
+      (inputs
+       `(("extension" ,(chromium-json->profile-object
+                        (crx->chromium-json (make-crx signing-key p output)
+                                            version)
+                        signing-key))))
       (propagated-inputs '())
       (outputs '("out"))
-      (build-system trivial-build-system)
       (arguments
-       (list #:modules '((guix build utils))
-             #:builder
-             #~(begin
-                 (use-modules (guix build utils))
-                 (define (base16-char->chromium-base16 char)
-                   ;; Translate CHAR, a hexadecimal character, to a Chromium-style
-                   ;; representation using the letters a-p (where a=0, p=15).
-                   (string-ref "abcdefghijklmnop"
-                               (string-index "0123456789abcdef" char)))
-                 (let ((file-name (string-map base16-char->chromium-base16
-                                              (string-take #$checksum 32)))
-                       (extension-directory
-                        (string-append #$output
-                                       "/share/chromium/extensions")))
-                   (mkdir-p extension-directory)
-                   (symlink #$json (string-append extension-directory "/"
-                                                  file-name ".json")))))))))
+       '(#:modules ((guix build utils))
+         #:builder
+         (begin
+           (use-modules (guix build utils))
+           (copy-recursively (assoc-ref %build-inputs "extension")
+                             (assoc-ref %outputs "out"))))))))

gnu/build/file-systems.scm

@@ -3,7 +3,7 @@
 ;;; 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, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
@@ -29,8 +29,6 @@
   #:use-module (guix build bournish)
   #:use-module ((guix build syscalls)
                 #:hide (file-system-type))
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
@@ -56,9 +54,7 @@
 
             mount-flags->bit-mask
             check-file-system
-            mount-file-system
-
-            swap-space->flags-bit-mask))
+            mount-file-system))
 
 ;;; Commentary:
 ;;;
@@ -170,23 +166,14 @@ if DEVICE does not contain an ext2 file system."
   (sub-bytevector sblock 104 16))
 
 (define (ext2-superblock-volume-name sblock)
-  "Return the volume name of ext2 superblock SBLOCK as a string of at most 16
-characters, or #f if SBLOCK has no volume name."
+  "Return the volume name of SBLOCK as a string of at most 16 characters, or
+#f if SBLOCK has no volume name."
   (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
 
-(define (check-ext2-file-system device force? repair)
-  "Return the health of an unmounted ext2 file system on DEVICE.  If FORCE? is
-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."
+(define (check-ext2-file-system device)
+  "Return the health of an ext2 file system on DEVICE."
   (match (status:exit-val
-          (apply system* `("e2fsck" "-v" "-C" "0"
-                           ,@(if force? '("-f") '())
-                           ,@(match repair
-                               (#f '("-n"))
-                               (#t '("-y"))
-                               (_  '("-p")))
-                           ,device)))
+          (system* "e2fsck" "-v" "-p" "-C" "0" device))
     (0 'pass)
     (1 'errors-corrected)
     (2 'reboot-required)
@@ -231,36 +218,6 @@ if DEVICE does not contain an linux-swap file system."
   "Return the label of Linux-swap superblock SBLOCK as a string."
   (null-terminated-latin1->string
    (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))
-
-(define (swap-space->flags-bit-mask swap)
-  "Return the number suitable for the 'flags' argument of 'mount'
-that corresponds to the swap-space SWAP."
-  (define prio-flag
-    (let ((p (swap-space-priority swap))
-          (max (ash SWAP_FLAG_PRIO_MASK (- SWAP_FLAG_PRIO_SHIFT))))
-      (if p
-          (logior SWAP_FLAG_PREFER
-                  (ash (cond
-                        ((< p 0)
-                         (begin (warning
-                                 (G_ "Given swap priority ~a is
-negative, defaulting to 0.~%") p)
-                                0))
-                        ((> p max)
-                         (begin (warning
-                                 (G_ "Limiting swap priority ~a to
-~a.~%")
-                                 p max)
-                                max))
-                        (else p))
-                       SWAP_FLAG_PRIO_SHIFT))
-          0)))
-  (define delayed-flag
-    (if (swap-space-discard? swap)
-        SWAP_FLAG_DISCARD
-        0))
-  (logior prio-flag delayed-flag))
-
 
 
 ;;;
@@ -282,15 +239,15 @@ negative, defaulting to 0.~%") p)
 (define (read-bcachefs-superblock device)
   "Return the raw contents of DEVICE's bcachefs superblock as a bytevector, or #f
 if DEVICE does not contain a bcachefs file system."
-  ;; Field offsets & lengths, in bytes.  There are more (and the superblock is
-  ;; extensible) but we need only some basic information here:
+  ;; We completely ignore the back-up superblock & any checksum errors.
+  ;; Superblock field names, with offset & length respectively, in bytes:
   ;;  0 16 bch_csum
   ;; 16  8 version
   ;; 24 16 magic
-  ;; 40 16 uuid               ← ‘internal’: you probably don't want this one
-  ;; 56 16 user_uuid          ← ‘external’: user-visible one by which to mount
+  ;; 40 16 uuid ← ‘internal UUID’, you probably don't want this
+  ;; 56 16 user_uuid ← ‘external UUID’, the one by which to mount
   ;; 72 32 label
-  ;; Assume a sane file system: ignore the back-up superblock & checksums.
+  ;; … there are more & the superblock is extensible, but we don't care yet.
   (read-superblock device 4096 104 bcachefs-superblock?))
 
 (define (bcachefs-superblock-external-uuid sblock)
@@ -299,28 +256,19 @@ bytevector."
   (sub-bytevector sblock 56 16))
 
 (define (bcachefs-superblock-volume-name sblock)
-  "Return the volume name of bcachefs superblock SBLOCK as a string of at most
-32 characters, or #f if SBLOCK has no volume name."
+  "Return the volume name of SBLOCK as a string of at most 32 characters, or
+#f if SBLOCK has no volume name."
   (null-terminated-latin1->string (sub-bytevector sblock 72 32)))
 
-(define (check-bcachefs-file-system device force? repair)
-  "Return the health of an unmounted bcachefs file system on DEVICE.  If FORCE?
-is 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."
+(define (check-bcachefs-file-system device)
+  "Return the health of a bcachefs file system on DEVICE."
   (let ((ignored-bits (logior 2))       ; DEVICE was mounted read-only
         (status
-         ;; A number, or #f on abnormal termination (e.g., assertion failure).
          (status:exit-val
-          (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)))
+          (apply system* "bcachefs" "fsck" "-p" "-v"
+                 ;; Make each multi-device member a separate argument.
+                 (string-split device #\:)))))
+    (match (logand (lognot ignored-bits) status)
       (0 'pass)
       (1 'errors-corrected)
       (_ 'fatal-error))))
@@ -351,33 +299,16 @@ if DEVICE does not contain a btrfs file system."
   (sub-bytevector sblock 32 16))
 
 (define (btrfs-superblock-volume-name sblock)
-  "Return the volume name of btrfs superblock SBLOCK as a string of at most 256
-characters, or #f if SBLOCK has no volume name."
+  "Return the volume name of SBLOCK as a string of at most 256 characters, or
+#f if SBLOCK has no volume name."
   (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
 
-(define (check-btrfs-file-system device force? repair)
-  "Return the health of an unmounted btrfs file system on DEVICE.  If FORCE? is
-false, return 'PASS unconditionally as btrfs claims no need for off-line checks.
-When FORCE? is true, do perform a real check.  This is not recommended!  See
-@uref{https://bugzilla.redhat.com/show_bug.cgi?id=625967#c8}.  If REPAIR is
-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* `("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))
+(define (check-btrfs-file-system device)
+  "Return the health of a btrfs file system on DEVICE."
+  (match (status:exit-val
+          (system* "btrfs" "device" "scan"))
+    (0 'pass)
+    (_ 'fatal-error)))
 
 
 ;;;
@@ -401,22 +332,15 @@ fix only those considered safe to repair automatically."
   (sub-bytevector sblock 67 4))
 
 (define (fat32-superblock-volume-name sblock)
-  "Return the volume name of fat superblock SBLOCK as a string of at most 11
-characters, or #f if SBLOCK has no volume name.  The volume name is a latin1
-string.  Trailing spaces are trimmed."
+  "Return the volume name of SBLOCK as a string of at most 11 characters, or
+#f if SBLOCK has no volume name.  The volume name is a latin1 string.
+Trailing spaces are trimmed."
   (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
 
-(define (check-fat-file-system device force? repair)
-  "Return the health of an unmounted FAT file system on DEVICE.  FORCE? is
-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."
+(define (check-fat-file-system device)
+  "Return the health of a fat file system on DEVICE."
   (match (status:exit-val
-          (apply system* `("fsck.vfat" "-v"
-                           ,@(match repair
-                               (#f '("-n"))
-                               (_  '("-a"))) ; no 'safe/#t distinction
-                           ,device)))
+          (system* "fsck.vfat" "-v" "-a" device))
     (0 'pass)
     (1 'errors-corrected)
     (_ 'fatal-error)))
@@ -441,9 +365,9 @@ using the least destructive approach."
   (sub-bytevector sblock 39 4))
 
 (define (fat16-superblock-volume-name sblock)
-  "Return the volume name of fat superblock SBLOCK as a string of at most 11
-characters, or #f if SBLOCK has no volume name.  The volume name is a latin1
-string.  Trailing spaces are trimmed."
+  "Return the volume name of SBLOCK as a string of at most 11 characters, or
+#f if SBLOCK has no volume name.  The volume name is a latin1 string.
+Trailing spaces are trimmed."
   (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
                                      (lambda (c) #f))
                      #\space))
@@ -502,8 +426,8 @@ SBLOCK as a bytevector.  If that's not set, returns the creation time."
     (sub-bytevector time 0 16))) ; strips GMT offset.
 
 (define (iso9660-superblock-volume-name sblock)
-  "Return the volume name of iso9660 superblock SBLOCK as a string.  The volume
-name is an ASCII string.  Trailing spaces are trimmed."
+  "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
+string.  Trailing spaces are trimmed."
   ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
   (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
                                      (lambda (c) #f)) #\space))
@@ -534,32 +458,14 @@ if DEVICE does not contain a JFS file system."
   (sub-bytevector sblock 136 16))
 
 (define (jfs-superblock-volume-name sblock)
-  "Return the volume name of JFS superblock SBLOCK as a string of at most 16
-characters, or #f if SBLOCK has no volume name."
+  "Return the volume name of SBLOCK as a string of at most 16 characters, or
+#f if SBLOCK has no volume name."
   (null-terminated-latin1->string (sub-bytevector sblock 152 16)))
 
-(define (check-jfs-file-system device force? repair)
-  "Return the health of an unmounted JFS file system on DEVICE.  If FORCE? is
-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, and replay the transaction log
-only if FORCE?  is true. Otherwise, replay the transaction log before checking
-and automatically fix found errors."
+(define (check-jfs-file-system device)
+  "Return the health of a JFS file system on DEVICE."
   (match (status:exit-val
-          (apply system*
-                 `("jfs_fsck" "-v"
-                   ;; The ‘LEVEL’ logic is convoluted.  To quote fsck/xchkdsk.c
-                   ;; (‘-p’, ‘-a’, and ‘-r’ are aliases in every way):
-                   ;; “If -f was chosen, have it override [-p] by [forcing] a
-                   ;;  check regardless of the outcome after the log is
-                   ;;  replayed”.
-                   ;; “If -n is specified by itself, don't replay the journal.
-                   ;;  If -n is specified with [-p], replay the journal but
-                   ;;  don't make any other changes”.
-                   ,@(if force? '("-f") '())
-                   ,@(match repair
-                       (#f '("-n"))
-                       (_  '("-p"))) ; no 'safe/#t distinction
-                   ,device)))
+          (system* "jfs_fsck" "-p" "-v" device))
     (0 'pass)
     (1 'errors-corrected)
     (2 'reboot-required)
@@ -604,28 +510,18 @@ if DEVICE does not contain an F2FS file system."
                   16))
 
 (define (f2fs-superblock-volume-name sblock)
-  "Return the volume name of F2FS superblock SBLOCK as a string of at most 512
-characters, or #f if SBLOCK has no volume name."
+  "Return the volume name of SBLOCK as a string of at most 512 characters, or
+#f if SBLOCK has no volume name."
   (null-terminated-utf16->string
    (sub-bytevector sblock (- (+ #x470 12) #x400) 512)
    %f2fs-endianness))
 
-(define (check-f2fs-file-system device force? repair)
-  "Return the health of an unmuounted F2FS file system on DEVICE.  If FORCE? is
-true, check the file system even if it's marked as clean.  If either FORCE? or
-REPAIR are true, automatically fix found errors."
-  ;; There's no ‘-n’ equivalent (‘--dry-run’ does not disable writes).
-  ;; ’-y’ is an alias of ‘-f’.  The man page is bad: read main.c.
-  (when (and force? (not repair))
-    (format (current-error-port)
-            "warning: forced check of F2FS ~a implies repairing any errors~%"
-            device))
+(define (check-f2fs-file-system device)
+  "Return the health of a F2FS file system on DEVICE."
   (match (status:exit-val
-          (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.
+          (system* "fsck.f2fs" "-p" device))
+    ;; 0 and -1 are the only two possibilities
+    ;; (according to the manpage)
     (0 'pass)
     (_ 'fatal-error)))
 
@@ -703,81 +599,13 @@ if DEVICE does not contain a NTFS file system."
 ;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
 ;; way harder to access.
 
-(define (check-ntfs-file-system device force? repair)
-  "Return the health of an unmounted NTFS file system on DEVICE.  FORCE? is
-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."
+(define (check-ntfs-file-system device)
+  "Return the health of a NTFS file system on DEVICE."
   (match (status:exit-val
-          (apply system* `("ntfsfix"
-                           ,@(if repair '("--clear-dirty") '("--no-action"))
-                           ,device)))
+          (system* "ntfsfix" device))
     (0 'pass)
     (_ 'fatal-error)))
 
-
-
-;;;
-;;; XFS file systems.
-;;;
-
-;; <https://git.kernel.org/pub/scm/fs/xfs/xfs-documentation.git/tree/design/XFS_Filesystem_Structure/allocation_groups.asciidoc>
-
-(define-syntax %xfs-endianness
-  ;; Endianness of XFS file systems.
-  (identifier-syntax (endianness big)))
-
-(define (xfs-superblock? sblock)
-  "Return #t when SBLOCK is an XFS superblock."
-  (bytevector=? (sub-bytevector sblock 0 4)
-                (string->utf8 "XFSB")))
-
-(define (read-xfs-superblock device)
-  "Return the raw contents of DEVICE's XFS superblock as a bytevector, or #f
-if DEVICE does not contain an XFS file system."
-  (read-superblock device 0 120 xfs-superblock?))
-
-(define (xfs-superblock-uuid sblock)
-  "Return the UUID of XFS superblock SBLOCK as a 16-byte bytevector."
-  (sub-bytevector sblock 32 16))
-
-(define (xfs-superblock-volume-name sblock)
-  "Return the volume name of XFS superblock SBLOCK as a string of at most 12
-characters, or #f if SBLOCK has no volume name."
-  (null-terminated-latin1->string (sub-bytevector sblock 108 12)))
-
-(define (check-xfs-file-system device force? repair)
-  "Return the health of an unmounted XFS file system on DEVICE.  If FORCE? is
-false, return 'PASS unconditionally as XFS claims no need for off-line checks.
-When FORCE? is true, do perform a thorough check.  If REPAIR is false, do not
-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
-     (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
-      ;; can replay the log by {,un}mounting it cleanly.
-      (match (let ((status (xfs_repair)))
-               (if (and repair (eq? 2 status))
-                   (let ((target "/replay-XFS-log"))
-                     ;; The kernel helpfully prints a ‘Mounting…’ notice for us.
-                     (mkdir target)
-                     (mount device target "xfs")
-                     (umount target)
-                     (rmdir target)
-                     (xfs_repair))
-                   status))
-        (0 'pass)
-        (4 'errors-corrected)
-        (_ 'fatal-error))
-      'pass))
-
 
 ;;;
 ;;; Partition lookup.
@@ -871,9 +699,7 @@ partition field reader that returned a value."
         (partition-field-reader read-jfs-superblock
                                 jfs-superblock-volume-name)
         (partition-field-reader read-f2fs-superblock
-                                f2fs-superblock-volume-name)
-        (partition-field-reader read-xfs-superblock
-                                xfs-superblock-volume-name)))
+                                f2fs-superblock-volume-name)))
 
 (define %partition-uuid-readers
   (list (partition-field-reader read-iso9660-superblock
@@ -895,9 +721,7 @@ partition field reader that returned a value."
         (partition-field-reader read-f2fs-superblock
                                 f2fs-superblock-uuid)
         (partition-field-reader read-ntfs-superblock
-                                ntfs-superblock-uuid)
-        (partition-field-reader read-xfs-superblock
-                                xfs-superblock-uuid)))
+                                ntfs-superblock-uuid)))
 
 (define read-partition-label
   (cut read-partition-field <> %partition-label-readers))
@@ -991,13 +815,8 @@ containing ':/')."
               (uuid-bytevector spec)
               uuid->string))))
 
-(define (check-file-system device type force? repair)
-  "Check an unmounted TYPE file system on DEVICE.  Do nothing but warn if it is
-mounted.  If FORCE? is true, check even when considered unnecessary.  If REPAIR
-is false, try not to write to DEVICE at all.  If it's #t, try to fix all errors
-found.  Otherwise, fix only those considered safe to repair automatically.  Not
-all TYPEs support all values or combinations of FORCE? and REPAIR.  Don't throw
-an exception in such cases but perform the nearest sane action."
+(define (check-file-system device type)
+  "Run a file system check of TYPE on DEVICE."
   (define check-procedure
     (cond
      ((string-prefix? "ext" type) check-ext2-file-system)
@@ -1008,44 +827,36 @@ an exception in such cases but perform the nearest sane action."
      ((string-prefix? "f2fs" type) check-f2fs-file-system)
      ((string-prefix? "ntfs" type) check-ntfs-file-system)
      ((string-prefix? "nfs" type) (const 'pass))
-     ((string-prefix? "xfs" type) check-xfs-file-system)
      (else #f)))
 
   (if check-procedure
-      (let ((mount (find (lambda (mount)
-                           (string=? device (mount-source mount)))
-                         (mounts))))
-        (if mount
-            (format (current-error-port)
-                    "Refusing to check ~a file system already mounted at ~a~%"
-                    device (mount-point mount))
-            (match (check-procedure device force? repair)
-              ('pass
-               #t)
-              ('errors-corrected
-               (format (current-error-port)
-                       "File system check corrected errors on ~a; continuing~%"
-                       device))
-              ('reboot-required
-               (format (current-error-port)
-                       "File system check corrected errors on ~a; rebooting~%"
-                       device)
-               (sleep 3)
-               (reboot))
-              ('fatal-error
-               (format (current-error-port) "File system check on ~a failed~%"
-                       device)
+      (match (check-procedure device)
+        ('pass
+         #t)
+        ('errors-corrected
+         (format (current-error-port)
+                 "File system check corrected errors on ~a; continuing~%"
+                 device))
+        ('reboot-required
+         (format (current-error-port)
+                 "File system check corrected errors on ~a; rebooting~%"
+                 device)
+         (sleep 3)
+         (reboot))
+        ('fatal-error
+         (format (current-error-port) "File system check on ~a failed~%"
+                 device)
 
-               ;; Spawn a REPL only if someone might interact with it.
-               (when (isatty? (current-input-port))
-                 (format (current-error-port) "Spawning Bourne-like REPL.~%")
+         ;; Spawn a REPL only if someone would be able to interact with it.
+         (when (isatty? (current-input-port))
+           (format (current-error-port) "Spawning Bourne-like REPL.~%")
 
-                 ;; 'current-output-port' is typically connected to /dev/klog
-                 ;; (in PID 1), but here we want to make sure we talk directly
-                 ;; to the user.
-                 (with-output-to-file "/dev/console"
-                   (lambda ()
-                     (start-repl %bournish-language))))))))
+           ;; 'current-output-port' is typically connected to /dev/klog (in
+           ;; PID 1), but here we want to make sure we talk directly to the
+           ;; user.
+           (with-output-to-file "/dev/console"
+             (lambda ()
+               (start-repl %bournish-language))))))
       (format (current-error-port)
               "No file system check procedure for ~a; skipping~%"
               device)))
@@ -1074,11 +885,7 @@ corresponds to the symbols listed in FLAGS."
       (()
        0))))
 
-(define* (mount-file-system fs #:key (root "/root")
-                            (check? (file-system-check? fs))
-                            (skip-check-if-clean?
-                             (file-system-skip-check-if-clean? fs))
-                            (repair (file-system-repair fs)))
+(define* (mount-file-system fs #:key (root "/root"))
   "Mount the file system described by FS, a <file-system> object, under ROOT."
 
   (define (mount-nfs source mount-point type flags options)
@@ -1116,8 +923,8 @@ corresponds to the symbols listed in FLAGS."
                                (file-system-mount-flags (statfs source)))
                               0)))
          (options (file-system-options fs)))
-    (when check?
-      (check-file-system source type (not skip-check-if-clean?) repair))
+    (when (file-system-check? fs)
+      (check-file-system source type))
 
     (catch 'system-error
       (lambda ()

gnu/build/hurd-boot.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -185,9 +185,13 @@ set."
       ("servers/crash-suspend"   ("/hurd/crash" "--suspend"))
       ("servers/password"        ("/hurd/password"))
       ("servers/socket/1"        ("/hurd/pflocal"))
-      ;; /servers/socket/2 and /26 are created by 'static-networking-service'.
-      ;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
-      ;; client has someone to talk to?
+      ("servers/socket/2"        ("/hurd/pfinet"
+                                  "--interface" "eth0"
+                                  "--address"
+                                  "10.0.2.15" ;the default QEMU guest IP
+                                  "--netmask" "255.255.255.0"
+                                  "--gateway" "10.0.2.2"
+                                  "--ipv6" "/servers/socket/16"))
       ("proc"                    ("/hurd/procfs" "--stat-mode=444"))))
 
   (define devices
@@ -254,7 +258,7 @@ set."
   "This procedure is meant to be called from an early RC script.
 
 Install the relevant passive translators on the first boot.  Then, run system
-activation by using the kernel command-line options 'gnu.system' and 'gnu.load';
+activation by using the kernel command-line options '--system' and '--load';
 starting the Shepherd.
 
 XXX TODO: see linux-boot.scm:boot-system.
@@ -265,14 +269,14 @@ XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
 "
 
   (display "Welcome, this is GNU's early boot Guile.\n")
-  (display "Use 'gnu.repl' for an initrd REPL.\n\n")
+  (display "Use '--repl' for an initrd REPL.\n\n")
 
   (call-with-error-handling
    (lambda ()
 
      (let* ((args    (command-line))
-            (system  (find-long-option "gnu.system" args))
-            (to-load (find-long-option "gnu.load" args)))
+            (system  (find-long-option "--system" args))
+            (to-load (find-long-option "--load" args)))
 
        (format #t "Setting-up essential translators...\n")
        (setenv "PATH" (string-append system "/profile/bin"))
@@ -286,7 +290,7 @@ XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
        (unless (zero? (system* "/hurd/mach-defpager"))
          (format #t "FAILED...Good luck!\n"))
 
-       (cond ((member "gnu.repl" args)
+       (cond ((member "--repl" args)
               (format #t "Starting repl...\n")
               (start-repl))
              (to-load
@@ -298,7 +302,7 @@ XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
               (sleep 2)
               (reboot))
              (else
-              (display "no boot file passed via 'gnu.load'\n")
+              (display "no boot file passed via '--load'\n")
               (display "entering a warm and cozy REPL\n")
               (start-repl)))))
    #:on-error on-error))

gnu/build/image.scm

@@ -1,9 +1,9 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
-;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -61,11 +61,9 @@
    (inexact->exact (ceiling (/ size 1024)))))
 
 (define (estimate-partition-size root)
-  "Given the ROOT directory, evaluate and return its size.  As this doesn't
-take the partition metadata size into account, take a 25% margin.  As this in
-turn doesn't take any constant overhead into account, force a 1-MiB minimum."
-  (max (ash 1 20)
-       (* 1.25 (file-size root))))
+  "Given the ROOT directory, evalute and return its size.  As this doesn't
+take the partition metadata size into account, take a 25% margin."
+  (* 1.25 (file-size root)))
 
 (define* (make-ext-image partition target root
                          #:key
@@ -168,7 +166,6 @@ produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
                                     bootcfg-location
                                     bootloader-package
                                     bootloader-installer
-                                    (copy-closures? #t)
                                     (deduplicate? #t)
                                     references-graphs
                                     (register-closures? #t)
@@ -179,50 +176,30 @@ produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
   "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
 install the bootloader configuration.
 
-If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition.  If
-REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store.  If
+If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store.  If
 DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
 rest of the store when registering the closures.  SYSTEM-DIRECTORY is the name
 of the directory of the 'system' derivation.  Pass WAL-MODE? to
 register-closure."
-  (define root-store
-    (string-append root (%store-directory)))
-
-  (define tmp-store ".tmp-store")
-
   (populate-root-file-system system-directory root)
-
-  (when copy-closures?
-    (populate-store references-graphs root
-                    #:deduplicate? deduplicate?))
+  (populate-store references-graphs root
+                  #:deduplicate? deduplicate?)
 
   ;; Populate /dev.
   (when make-device-nodes
     (make-device-nodes root))
 
   (when register-closures?
-    (unless copy-closures?
-      ;; XXX: 'register-closure' wants to palpate the things it registers, so
-      ;; create a symlink to the store.
-      (rename-file root-store tmp-store)
-      (symlink (%store-directory) root-store))
-
     (for-each (lambda (closure)
                 (register-closure root closure
                                   #:wal-mode? wal-mode?))
-              references-graphs)
+              references-graphs))
 
-    (unless copy-closures?
-      (delete-file root-store)
-      (rename-file tmp-store root-store)))
-
-  ;; There's no point installing a bootloader if we do not populate the store.
-  (when copy-closures?
-    (when bootloader-installer
-      (display "installing bootloader...\n")
-      (bootloader-installer bootloader-package #f root))
-    (when bootcfg
-      (install-boot-config bootcfg bootcfg-location root))))
+  (when bootloader-installer
+    (display "installing bootloader...\n")
+    (bootloader-installer bootloader-package #f root))
+  (when bootcfg
+    (install-boot-config bootcfg bootcfg-location root)))
 
 (define* (make-iso9660-image xorriso grub-mkrescue-environment
                              grub bootcfg system-directory root target

gnu/build/jami-service.scm

@@ -1,587 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 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 helpers used as part of the jami-service-type
-;;; definition.
-;;;
-;;; Code:
-
-(define-module (gnu build jami-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 (account-fingerprint?
-            account-details->recutil
-            get-accounts
-            get-usernames
-            set-account-details
-            add-account
-            account->username
-            username->account
-            username->contacts
-            enable-account
-            disable-account
-
-            add-contact
-            remove-contact
-
-            set-all-moderators
-            set-moderator
-            username->all-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
-                (() '())
-                ((key . value)
-                 (list key value)))
-              alist))
-
-(define account-fingerprint-rx (make-regexp "[0-9A-Fa-f]{40}"))
-
-(define (account-fingerprint? val)
-  "A Jami account fingerprint is 40 characters long and only contains
-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 (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))))
-
-(define (dbus-service-available? service)
-  "Predicate to check for the D-Bus SERVICE availability."
-  (member service (dbus-available-services)))
-
-(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
-;;; concerned with.
-(define (get-account-ids)
-  "Return the available Jami account identifiers (IDs).  Account IDs are an
-implementation detail used to identify the accounts in Jami."
-  (parse-account-ids
-   (send-dbus/configuration-manager #:method "getAccountList")))
-
-(define (id->account-details id)
-  "Retrieve the account data associated with the given account 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."
-  (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."
-  (append (id->volatile-account-details id)
-          (id->account-details id)))
-
-(define %username-to-id-cache #f)
-
-(define (invalidate-username-to-id-cache!)
-  (set! %username-to-id-cache #f))
-
-(define (username->id username)
-  "Return the first account ID corresponding to USERNAME."
-  (unless (assoc-ref %username-to-id-cache username)
-    (set! %username-to-id-cache
-          (append-map
-           (lambda (id)
-             (let* ((account (id->account id))
-                    (username (assoc-ref account "Account.username"))
-                    (registered-name (assoc-ref account
-                                                "Account.registeredName")))
-               `(,@(if username
-                       (list (cons username id))
-                       '())
-                 ,@(if registered-name
-                       (list (cons registered-name id))
-                       '()))))
-           (get-account-ids))))
-  (or (assoc-ref %username-to-id-cache 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 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 USERNAME, the registered username associated with ID, else its
-public key fingerprint, else #f."
-  (account->username (id->account id)))
-
-(define (get-accounts)
-  "Return the list of all accounts, as a list of alists."
-  (map id->account (get-account-ids)))
-
-(define (get-usernames)
-  "Return the list of the usernames associated with the present accounts."
-  (map account->username (get-accounts)))
-
-(define (username->account username)
-  "Return the first account associated with USERNAME, else #f.
-USERNAME can be either the account 40 characters public key fingerprint or a
-registered username."
-  (find (lambda (account)
-          (member username
-                  (list (assoc-ref account "Account.username")
-                        (assoc-ref account "Account.registeredName"))))
-        (get-accounts)))
-
-(define (add-account archive)
-  "Import the Jami account ARCHIVE and return its account ID.  The archive
-should *not* be encrypted with a password.  Return the username associated
-with the account."
-  (invalidate-username-to-id-cache!)
-  (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.
-    (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)))
-    (send-dbus/configuration-manager
-     #:method "removeAccount"
-     #:arguments (list (string-append "string:" id))))
-  (invalidate-username-to-id-cache!))
-
-(define* (username->contacts username)
-  "Return the contacts associated with the account of USERNAME as two values;
-the first one being the regular contacts and the second one the banned
-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))
-         (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? all-contacts))
-         (not-banned (filter (negate banned?) all-contacts))
-         (fingerprint (cut assoc-ref <> "id")))
-    (values (map fingerprint not-banned)
-            (map fingerprint banned))))
-
-(define* (remove-contact contact username #:key ban?)
-  "Remove CONTACT, the 40 characters public key fingerprint of a contact, from
-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)))
-    (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)))
-    (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 `send-dbus/configuration-manager' procedure."
-  (let* ((id (username->id username))
-         (current-details (id->account-details id))
-         (updated-details (map (match-lambda
-                                 ((key . value)
-                                  (or (and=> (assoc-ref details key)
-                                             (cut cons key <>))
-                                      (cons key value))))
-                               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)))
-    (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))
-         (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))
-         (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
-key fingerprint of a contact for the account of USERNAME, a registered
-username or account fingerprint."
-  (validate-fingerprint contact)
-  (let* ((id (username->id username)))
-    (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
-fingerprint."
-  (set-account-details '(("Account.enable" . "false")) username
-                       ;; 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 60000))
-
-(define (enable-account username)
-  "Enable the account known by USERNAME, a registered username or account
-fingerprint."
-  (set-account-details '(("Account.enable" . "true")) username))
-
-
-;;;
-;;; Presentation procedures.
-;;;
-
-(define (.->_ text)
-  "Map each period character to underscore characters."
-  (string-map (match-lambda
-                (#\. #\_)
-                (c c))
-              text))
-
-(define (account-details->recutil account-details)
-  "Serialize the account-details alist into a recutil string.  Period
-characters in the keys are normalized to underscore to meet Recutils' format
-requirements."
-  (define (pair->recutil-property pair)
-    (match pair
-      ((key . value)
-       (string-append (.->_ key) ": " value))))
-
-  (define sorted-account-details
-    ;; Have the account username, display name and alias appear first, for
-    ;; convenience.
-    (let ((first-items '("Account.username"
-                         "Account.displayName"
-                         "Account.alias")))
-      (append (map (cut assoc <> account-details) first-items)
-              (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

@@ -1,9 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016, 2017, 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2016, 2017, 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
-;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,7 +25,6 @@
   #:autoload   (system repl repl) (start-repl)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
@@ -46,6 +44,7 @@
             make-static-device-nodes
             configure-qemu-networking
 
+            device-number
             boot-system))
 
 ;;; Commentary:
@@ -94,7 +93,7 @@
      get-string-all)))
 
 (define (find-long-option option arguments)
-  "Find OPTION among ARGUMENTS, where OPTION is something like \"gnu.load\".
+  "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
 Return the value associated with OPTION, or #f on failure."
   (let ((opt (string-append option "=")))
     (and=> (find (cut string-prefix? opt <>)
@@ -135,9 +134,14 @@ succeeds.  Return nothing otherwise.  The kernel logs any details to dmesg."
            ;; is found on the command line; our canonicalize-device-spec gives
            ;; up after 20 seconds.  We could emulate the former by looping…
            (device (canonicalize-device-spec spec))
-           (rdev (stat:rdev (stat device))))
-      (let-values (((major minor) (device-number->major+minor rdev)))
-        (format #f "~a:~a" major minor))))
+           (rdev (stat:rdev (stat device)))
+           ;; For backwards compatibility, device numbering is a baroque affair.
+           ;; This is the full 64-bit scheme used by glibc's <sys/sysmacros.h>.
+           (major (logior (ash (logand #x00000000000fff00 rdev) -8)
+                          (ash (logand #xfffff00000000000 rdev) -32)))
+           (minor (logior      (logand #x00000000000000ff rdev)
+                          (ash (logand #x00000ffffff00000 rdev) -12))))
+      (format #f "~a:~a" major minor)))
 
   ;; Write the resume DEVICE to this magic file, using the MAJOR:MINOR device
   ;; numbers if possible.  The kernel will immediately try to resume from it.
@@ -386,8 +390,17 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
     (set-network-interface-address sock interface address)
     (set-network-interface-flags sock interface (logior flags IFF_UP))
 
+    ;; Hello!  We used to create /etc/resolv.conf here, with "nameserver
+    ;; 10.0.2.3\n".  However, with Linux-libre 3.16, we're getting ENOSPC.
+    ;; And since it's actually unnecessary, it's gone.
+
     (logand (network-interface-flags sock interface) IFF_UP)))
 
+(define (device-number major minor)
+  "Return the device number for the device with MAJOR and MINOR, for use as
+the last argument of `mknod'."
+  (+ (* major 256) minor))
+
 (define (pidof program)
   "Return the PID of the first presumed instance of PROGRAM."
   (let ((program (basename program)))
@@ -398,18 +411,11 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
           (filter-map string->number (scandir "/proc")))))
 
 (define* (mount-root-file-system root type
-                                 #:key volatile-root? (flags 0) options
-                                 check? skip-check-if-clean? repair)
+                                 #:key volatile-root? (flags 0) options)
   "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is
 true, mount ROOT read-only and make it an overlay with a writable tmpfs using
 the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use
-to mount ROOT, and behave the same as for the `mount' procedure.
-
-If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively.
-If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is
-marked as clean.  If REPAIR is true, fsck may write to ROOT to perform repairs.
-If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it
-considers safe."
+to mount ROOT, and behave the same as for the `mount' procedure."
 
   (if volatile-root?
       (begin
@@ -430,8 +436,7 @@ considers safe."
         (mount "none" "/root" "overlay" 0
                "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
       (begin
-        (when check?
-          (check-file-system root type (not skip-check-if-clean?) repair))
+        (check-file-system root type)
         (mount root "/root" type flags options)))
 
   ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
@@ -500,12 +505,10 @@ LINUX-MODULE-DIRECTORY, then installing KEYMAP-FILE with 'loadkeys' (if
 KEYMAP-FILE is true), then setting up QEMU guest networking if
 QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
 specified in MOUNTS, and finally booting into the new root if any.  The initrd
-supports the kernel command-line options 'gnu.load' and 'gnu.repl'.  It also
-honors a subset of the Linux kernel command-line parameters such as
-'fsck.mode', 'resume', 'rootdelay', rootflags and rootfstype.
+supports kernel command-line options '--load', '--root', and '--repl'.
 
-Mount the root file system, specified by the 'root' command-line argument, if
-any.
+Mount the root file system, specified by the '--root' command-line argument,
+if any.
 
 MOUNTS must be a list of <file-system> objects.
 
@@ -518,71 +521,39 @@ upon error."
     (string=? (file-system-mount-point fs) "/"))
 
   (define (device-string->file-system-device device-string)
-    ;; The "root=SPEC" kernel command-line option always provides a string,
-    ;; but the string can represent a device, an nfs-root, a UUID, or a label.
-    ;; So check for all four.
+    ;; The "--root=SPEC" kernel command-line option always provides a
+    ;; string, but the string can represent a device, an nfs-root, a UUID, or a
+    ;; label.  So check for all four.
     (cond ((string-prefix? "/" device-string) device-string)
           ((string-contains device-string ":/") device-string) ; nfs-root
           ((uuid device-string) => identity)
           (else (file-system-label device-string))))
 
   (display "Welcome, this is GNU's early boot Guile.\n")
-  (display "Use 'gnu.repl' for an initrd REPL.\n\n")
+  (display "Use '--repl' for an initrd REPL.\n\n")
 
   (call-with-error-handling
     (lambda ()
       (mount-essential-file-systems)
       (let* ((args    (linux-command-line))
-             (to-load (find-long-option "gnu.load" args))
-             ;; If present, ‘root’ on the kernel command line takes precedence
-             ;; over the ‘device’ field of the root <file-system> record.
-             (root-device (and=> (find-long-option "root" args)
-                                 device-string->file-system-device))
-             (rootfstype  (find-long-option "rootfstype" args))
-             (rootflags   (find-long-option "rootflags" args))
-             (root-fs*    (find root-mount-point? mounts))
-             (fsck.mode (find-long-option "fsck.mode" args)))
+             (to-load (find-long-option "--load" args))
+             (root-fs (find root-mount-point? mounts))
+             (root-fs-type (or (and=> root-fs file-system-type)
+                               "ext4"))
+             (root-fs-device (and=> root-fs file-system-device))
+             (root-fs-flags (mount-flags->bit-mask
+                             (or (and=> root-fs file-system-flags)
+                                 '())))
+             (root-options (if root-fs
+                               (file-system-options root-fs)
+                               #f))
+             ;; --root takes precedence over the 'device' field of the root
+             ;; <file-system> record.
+             (root-device (or (and=> (find-long-option "--root" args)
+                                     device-string->file-system-device)
+                              root-fs-device)))
 
-        (unless (or root-fs* (and root-device rootfstype))
-          (error "no root file system or 'root' and 'rootfstype' parameters"))
-
-        ;; If present, ‘root’ on the kernel command line takes precedence over
-        ;; the ‘device’ field of the root <file-system> record; likewise for
-        ;; the 'rootfstype' and 'rootflags' arguments.
-        (define root-fs
-          (if root-fs*
-              (file-system
-                (inherit root-fs*)
-                (device (or root-device (file-system-device root-fs*)))
-                (type (or rootfstype (file-system-type root-fs*)))
-                (options (or rootflags (file-system-options root-fs*))))
-              (file-system
-                (device root-device)
-                (mount-point "/")
-                (type rootfstype)
-                (options rootflags))))
-
-        (define (check? fs)
-          (match fsck.mode
-            ("skip"  #f)
-            ("force" #t)
-            (_ (file-system-check? fs)))) ; assume "auto"
-
-        (define (skip-check-if-clean? fs)
-          (match fsck.mode
-            ("force" #f)
-            (_ (file-system-skip-check-if-clean? fs))))
-
-        (define (repair fs)
-          (let ((arg (find-long-option "fsck.repair" args)))
-            (if arg
-                (match arg
-                  ("no"  #f)
-                  ("yes" #t)
-                  (_ 'preen))
-                (file-system-repair fs))))
-
-        (when (member "gnu.repl" args)
+        (when (member "--repl" args)
           (start-repl))
 
         (display "loading kernel modules...\n")
@@ -611,15 +582,6 @@ upon error."
           (unless (configure-qemu-networking)
             (display "network interface is DOWN\n")))
 
-        ;; A big ugly hammer, to be used only for debugging and in desperate
-        ;; situations where no proper device synchonisation is possible.
-        (let ((root-delay (and=> (find-long-option "rootdelay" args)
-                                 string->number)))
-          (when root-delay
-            (format #t "Pausing for rootdelay=~a seconds before mounting \
-the root file system...\n" root-delay)
-            (sleep root-delay)))
-
         ;; Prepare the real root file system under /root.
         (unless (file-exists? "/root")
           (mkdir "/root"))
@@ -633,26 +595,16 @@ the root file system...\n" root-delay)
 
         (setenv "EXT2FS_NO_MTAB_OK" "1")
 
-        ;; Mount the root file system.
-        (mount-root-file-system (canonicalize-device-spec
-                                 (file-system-device root-fs))
-                                (file-system-type root-fs)
-                                #:volatile-root? volatile-root?
-                                #:flags (mount-flags->bit-mask
-                                         (file-system-flags root-fs))
-                                #:options (file-system-options root-fs)
-                                #:check? (check? root-fs)
-                                #:skip-check-if-clean?
-                                (skip-check-if-clean? root-fs)
-                                #:repair (repair root-fs))
+        (if root-device
+            (mount-root-file-system (canonicalize-device-spec root-device)
+                                    root-fs-type
+                                    #:volatile-root? volatile-root?
+                                    #:flags root-fs-flags
+                                    #:options root-options)
+            (mount "none" "/root" "tmpfs"))
 
-        ;; Mount the specified non-root file systems.
-        (for-each (lambda (fs)
-                    (mount-file-system fs
-                                       #:check? (check? fs)
-                                       #:skip-check-if-clean?
-                                       (skip-check-if-clean? fs)
-                                       #:repair (repair fs)))
+        ;; Mount the specified file systems.
+        (for-each mount-file-system
                   (remove root-mount-point? mounts))
 
         (setenv "EXT2FS_NO_MTAB_OK" #f)
@@ -670,7 +622,7 @@ the root file system...\n" root-delay)
               (sleep 2)
               (reboot))
             (begin
-              (display "no boot file passed via 'gnu.load'\n")
+              (display "no boot file passed via '--load'\n")
               (display "entering a warm and cozy REPL\n")
               (start-repl)))))
     #:on-error on-error))

gnu/build/linux-container.scm

@@ -52,7 +52,7 @@ exists."
   (file-exists? "/proc/self/setgroups"))
 
 (define %namespaces
-  '(cgroup mnt pid ipc uts user net))
+  '(mnt pid ipc uts user net))
 
 (define (call-with-clean-exit thunk)
   "Apply THUNK, but exit with a status code of 1 if it fails."
@@ -210,7 +210,6 @@ corresponds to the symbols in NAMESPACES."
   ;; Use the same flags as fork(3) in addition to the namespace flags.
   (apply logior SIGCHLD
          (map (match-lambda
-               ('cgroup  CLONE_NEWCGROUP)
                ('mnt  CLONE_NEWNS)
                ('uts  CLONE_NEWUTS)
                ('ipc  CLONE_NEWIPC)

gnu/build/linux-modules.scm

@@ -354,13 +354,11 @@ appears in BLACK-LIST are not loaded."
              (close-fdes fd)
              #t)
            (lambda args
+             ;; If this module was already loaded and we're in modprobe style, ignore
+             ;; the error.
              (when fd (close-fdes fd))
-             (let ((errno (system-error-errno args)))
-               (or (and recursive?      ; we're operating in ‘modprobe’ style
-                        (member errno
-                                (list EEXIST    ; already loaded
-                                      EINVAL))) ; unsupported by hardware
-                   (apply throw args))))))))
+             (or (and recursive? (= EEXIST (system-error-errno args)))
+                 (apply throw args)))))))
 
 (define (load-linux-modules-from-directory modules directory)
   "Load MODULES and their dependencies from DIRECTORY, a directory containing

gnu/build/marionette.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,11 +20,9 @@
 (define-module (gnu build marionette)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
-  #:use-module (ice-9 regex)
   #:export (marionette?
             make-marionette
             marionette-eval
@@ -35,10 +33,7 @@
             marionette-screen-text
             wait-for-screen-text
             %qwerty-us-keystrokes
-            marionette-type
-
-            system-test-runner
-            qemu-command))
+            marionette-type))
 
 ;;; Commentary:
 ;;;
@@ -363,79 +358,4 @@ to actual keystrokes."
   (for-each (cut marionette-control <> marionette)
             (string->keystroke-commands str keystrokes)))
 
-
-;;;
-;;; Test helper.
-;;;
-
-(define* (system-test-runner #:optional log-directory)
-  "Return a SRFI-64 test runner that calls 'exit' upon 'test-end'.  When
-LOG-DIRECTORY is specified, create log file within it."
-  (let ((runner  (test-runner-simple)))
-    ;; Log to a file under LOG-DIRECTORY.
-    (test-runner-on-group-begin! runner
-      (let ((on-begin (test-runner-on-group-begin runner)))
-        (lambda (runner suite-name count)
-          (when log-directory
-            (catch 'system-error
-              (lambda ()
-                (mkdir log-directory))
-              (lambda args
-                (unless (= (system-error-errno args) EEXIST)
-                  (apply throw args))))
-            (set! test-log-to-file
-                  (string-append log-directory "/" suite-name ".log")))
-          (on-begin runner suite-name count))))
-
-    ;; The default behavior on 'test-end' is to only write a line if the test
-    ;; failed.  Arrange to also write a line on success.
-    (test-runner-on-test-end! runner
-      (let ((on-end (test-runner-on-test-end runner)))
-        (lambda (runner)
-          (let* ((kind      (test-result-ref runner 'result-kind))
-                 (results   (test-result-alist runner))
-                 (test-name (assq-ref results 'test-name)))
-            (unless (memq kind '(fail xpass))
-              (format (current-output-port) "~a: ~a~%"
-                      (string-upcase (symbol->string kind))
-                      test-name)))
-
-          (on-end runner))))
-
-    ;; On 'test-end', display test results and exit with zero if and only if
-    ;; there were no test failures.
-    (test-runner-on-final! runner
-      (lambda (runner)
-        (let ((success? (= (test-runner-fail-count runner) 0)))
-          (test-on-final-simple runner)
-
-          (when (not success?)
-            (let* ((log-port (test-runner-aux-value runner))
-                   (log-file (port-filename log-port)))
-              (format (current-error-port)
-                      "\nTests failed, dumping log file '~a'.\n\n"
-                      log-file)
-
-              ;; At this point LOG-PORT is not closed yet; flush it.
-              (force-output log-port)
-
-              ;; Brute force to avoid dependency on (guix build utils) for
-              ;; 'dump-port'.
-              (let ((content (call-with-input-file log-file
-                               get-bytevector-all)))
-                (put-bytevector (current-error-port) content))))
-
-          (exit success?))))
-    runner))
-
-(define* (qemu-command #:optional (system %host-type))
-  "Return the default name of the QEMU command for SYSTEM."
-  (let ((cpu (substring system 0
-                        (string-index system #\-))))
-    (string-append "qemu-system-"
-                   (cond
-                    ((string-match "^i[3456]86$" cpu) "i386")
-                    ((string-match "armhf" cpu) "arm")
-                    (else cpu)))))
-
 ;;; marionette.scm ends here

gnu/build/secret-service.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -111,15 +111,6 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
        (close-port sock)
        #f))))
 
-(define (delete-file* file)
-  "Ensure FILE does not exist."
-  (catch 'system-error
-    (lambda ()
-      (delete-file file))
-    (lambda args
-      (unless (= ENOENT (system-error-errno args))
-        (apply throw args)))))
-
 (define (secret-service-receive-secrets port)
   "Listen to local PORT and wait for a secret service client to send secrets.
 Write them to the file system.  Return the list of files installed on success,
@@ -179,12 +170,6 @@ and #f otherwise."
                    (log "installing file '~a' (~a bytes)...~%"
                         file size)
                    (mkdir-p (dirname file))
-
-                   ;; It could be that FILE already exists, for instance
-                   ;; because it has been created by a service's activation
-                   ;; snippet (e.g., SSH host keys).  Delete it.
-                   (delete-file* file)
-
                    (call-with-output-file file
                      (lambda (output)
                        (dump port output size)

gnu/build/shepherd.scm

@@ -24,12 +24,6 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
-  #:autoload (shepherd service) (fork+exec-command
-                                 read-pid-file
-                                 exec-command
-                                 %precious-signals)
-  #:autoload (shepherd system) (unblock-signals)
   #:export (make-forkexec-constructor/container
             fork+exec-command/container))
 
@@ -98,6 +92,14 @@
                            (file-exists? (file-system-mapping-source mapping)))
                          mappings)))))
 
+;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
+(module-autoload! (current-module)
+                  '(shepherd service)
+                  '(fork+exec-command read-pid-file exec-command
+                    %precious-signals))
+(module-autoload! (current-module)
+                  '(shepherd system) '(unblock-signals))
+
 (define* (read-pid-file/container pid pid-file #:key (max-delay 5))
   "Read PID-FILE in the container namespaces of PID, which exists in a
 separate mount and PID name space.  Return the \"outer\" PID. "

gnu/build/vm.scm

@@ -0,0 +1,500 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;;
+;;; 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 build vm)
+  #:use-module (guix build utils)
+  #:use-module (guix build store-copy)
+  #:use-module (guix build syscalls)
+  #:use-module (guix store database)
+  #:use-module (gnu build bootloader)
+  #:use-module (gnu build linux-boot)
+  #:use-module (gnu build install)
+  #:use-module (gnu system uuid)
+  #:use-module (guix records)
+  #:use-module ((guix combinators) #:select (fold2))
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 popen)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:export (qemu-command
+            load-in-linux-vm
+            format-partition
+
+            partition
+            partition?
+            partition-device
+            partition-size
+            partition-file-system
+            partition-label
+            partition-flags
+            partition-initializer
+
+            estimated-partition-size
+            root-partition-initializer
+            initialize-partition-table
+            initialize-hard-disk))
+
+;;; Commentary:
+;;;
+;;; This module provides supporting code to run virtual machines and build
+;;; virtual machine images using QEMU.
+;;;
+;;; Code:
+
+(define* (qemu-command #:optional (system %host-type))
+  "Return the default name of the QEMU command for SYSTEM."
+  (let ((cpu (substring system 0
+                        (string-index system #\-))))
+    (string-append "qemu-system-"
+                   (cond
+                    ((string-match "^i[3456]86$" cpu) "i386")
+                    ((string-match "armhf" cpu) "arm")
+                    (else cpu)))))
+
+(define* (load-in-linux-vm builder
+                           #:key
+                           output
+                           (qemu (qemu-command)) (memory-size 512)
+                           linux initrd
+                           make-disk-image?
+                           single-file-output?
+                           (disk-image-size (* 100 (expt 2 20)))
+                           (disk-image-format "qcow2")
+                           (references-graphs '()))
+  "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
+the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
+/xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
+OUTPUT.
+
+When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
+DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
+access it via /dev/hda.
+
+REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
+the #:references-graphs parameter of 'derivation'."
+
+  (define target-arm32?
+    (string-prefix? "arm-" %host-type))
+
+  (define target-aarch64?
+    (string-prefix? "aarch64-" %host-type))
+
+  (define target-arm?
+    (or target-arm32? target-aarch64?))
+
+  (define arch-specific-flags
+    `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
+      ;; hardware limits imposed by other machines.
+      ,@(if target-arm?
+            '("-M" "virt")
+            '())
+
+      ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
+      ;; with VIRT_PCIE_MMIO causing PCI devices not to show up.  Disable
+      ;; explicitely highmem to fix it.
+      ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
+      ,@(if target-arm32?
+            '("-machine" "highmem=off")
+            '())
+
+      ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
+      ;; hardware virtualization to still use these commands.  KVM support is
+      ;; still buggy on some ARM boards. Do not use it even if available.
+      ,@(if (and (file-exists? "/dev/kvm")
+                 (not target-arm?))
+            '("-enable-kvm")
+            '())
+
+      ;; Pass "panic=1" so that the guest dies upon error.
+      "-append"
+      ,(string-append "panic=1 --load=" builder
+
+                      ;; The serial port name differs between emulated
+                      ;; architectures/machines.
+                      " console="
+                      (if target-arm? "ttyAMA0" "ttyS0"))))
+
+  (when make-disk-image?
+    (format #t "creating ~a image of ~,2f MiB...~%"
+            disk-image-format (/ disk-image-size (expt 2 20)))
+    (force-output)
+    (invoke "qemu-img" "create" "-f" disk-image-format output
+             (number->string disk-image-size)))
+
+  (mkdir "xchg")
+  (mkdir "tmp")
+
+  (match references-graphs
+    ((graph-files ...)
+     ;; Copy the reference-graph files under xchg/ so EXP can access it.
+     (map (lambda (file)
+            (copy-file file (string-append "xchg/" file)))
+          graph-files))
+    (_ #f))
+
+  (apply invoke qemu "-nographic" "-no-reboot"
+         ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
+         ;; CPU with the maximum possible feature set otherwise.
+         "-cpu" "max"
+         "-m" (number->string memory-size)
+         "-nic" "user,model=virtio-net-pci"
+         "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
+         "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
+         "-virtfs"
+         (string-append "local,id=store_dev,path="
+                        (%store-directory)
+                        ",security_model=none,mount_tag=store")
+         "-virtfs"
+         (string-append "local,id=xchg_dev,path=xchg"
+                        ",security_model=none,mount_tag=xchg")
+         "-virtfs"
+         ;; Some programs require more space in /tmp than is normally
+         ;; available in the guest.  Accommodate such programs by sharing a
+         ;; temporary directory.
+         (string-append "local,id=tmp_dev,path=tmp"
+                        ",security_model=none,mount_tag=tmp")
+         "-kernel" linux
+         "-initrd" initrd
+         (append
+          (if make-disk-image?
+              `("-device" "virtio-blk,drive=myhd"
+                "-drive" ,(string-append "if=none,file=" output
+                                         ",format=" disk-image-format
+                                         ",id=myhd"))
+              '())
+          arch-specific-flags))
+
+  (unless (file-exists? "xchg/.exit-status")
+    (error "VM did not produce an exit code"))
+
+  (match (call-with-input-file "xchg/.exit-status" read)
+    (0 #t)
+    (status (error "guest VM code exited with a non-zero status" status)))
+
+  (delete-file "xchg/.exit-status")
+
+  ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
+  (unless make-disk-image?
+    (if single-file-output?
+        (let ((graph? (lambda (name stat)
+                        (member (basename name) references-graphs))))
+          (match (find-files "xchg" (negate graph?))
+            ((result)
+             (copy-file result output))
+            (x
+             (error "did not find a single result file" x))))
+        (begin
+          (mkdir output)
+          (copy-recursively "xchg" output)))))
+
+(define* (register-closure prefix closure
+                           #:key
+                           (schema (sql-schema)))
+  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs."
+  (let ((items (call-with-input-file closure read-reference-graph)))
+    (parameterize ((sql-schema schema))
+      (with-database (store-database-file #:prefix prefix) db
+        (register-items db items
+                        #:prefix prefix
+                        #:registration-time %epoch)))))
+
+
+;;;
+;;; Partitions.
+;;;
+
+(define-record-type* <partition> partition make-partition
+  partition?
+  (device      partition-device (default #f))
+  (size        partition-size)
+  (file-system partition-file-system (default "ext4"))
+  (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
+                       (default '()))
+  (label       partition-label (default #f))
+  (uuid        partition-uuid (default #f))
+  (flags       partition-flags (default '()))
+  (initializer partition-initializer (default (const #t))))
+
+(define (estimated-partition-size graphs)
+  "Return the estimated size of a partition that can store the store items
+given by GRAPHS, a list of file names produced by #:references-graphs."
+  ;; Simply add a 25% overhead.
+  (round (* 1.25 (closure-size graphs))))
+
+(define* (initialize-partition-table device partitions
+                                     #:key
+                                     (label-type "msdos")
+                                     (offset (expt 2 20)))
+  "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
+PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
+success, return PARTITIONS with their 'device' field changed to reflect their
+actual /dev name based on DEVICE."
+  (define (partition-options part offset index)
+    (cons* "mkpart" "primary" "ext2"
+           (format #f "~aB" offset)
+           (format #f "~aB" (+ offset (partition-size part)))
+           (append-map (lambda (flag)
+                         (list "set" (number->string index)
+                               (symbol->string flag) "on"))
+                       (partition-flags part))))
+
+  (define (options partitions offset)
+    (let loop ((partitions partitions)
+               (offset     offset)
+               (index      1)
+               (result     '()))
+      (match partitions
+        (()
+         (concatenate (reverse result)))
+        ((head tail ...)
+         (loop tail
+               ;; Leave one sector (512B) between partitions to placate
+               ;; Parted.
+               (+ offset 512 (partition-size head))
+               (+ 1 index)
+               (cons (partition-options head offset index)
+                     result))))))
+
+  (format #t "creating partition table with ~a partitions (~a)...\n"
+          (length partitions)
+          (string-join (map (compose (cut string-append <> " MiB")
+                                     number->string
+                                     (lambda (size)
+                                       (round (/ size (expt 2. 20))))
+                                     partition-size)
+                            partitions)
+                       ", "))
+  (apply invoke "parted" "--script"
+         device "mklabel" label-type
+         (options partitions offset))
+
+  ;; Set the 'device' field of each partition.
+  (reverse
+   (fold2 (lambda (part result index)
+            (values (cons  (partition
+                            (inherit part)
+                            (device (string-append device
+                                                   (number->string index))))
+                           result)
+                    (+ 1 index)))
+          '()
+          1
+          partitions)))
+
+(define MS_BIND 4096)                             ; <sys/mounts.h> again!
+
+(define* (create-ext-file-system partition type
+                                 #:key label uuid (options '()))
+  "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
+use that as the volume name.  If UUID is true, use it as the partition UUID."
+  (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
+          type label (and uuid (uuid->string uuid)))
+  (apply invoke (string-append "mkfs." type)
+         "-F" partition
+         `(,@(if label
+                 `("-L" ,label)
+                 '())
+           ,@(if uuid
+                 `("-U" ,(uuid->string uuid))
+                 '())
+           ,@options)))
+
+(define* (create-fat-file-system partition
+                                 #:key label uuid (options '()))
+  "Create a FAT file system on PARTITION.  The number of File Allocation Tables
+will be determined based on file system size.  If LABEL is true, use that as the
+volume name."
+  ;; FIXME: UUID is ignored!
+  (format #t "creating FAT partition...\n")
+  (apply invoke "mkfs.fat" partition
+         (append (if label `("-n" ,label) '()) options)))
+
+(define* (format-partition partition type
+                           #:key label uuid (options '()))
+  "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
+volume name.  Options is a list of command-line options passed to 'mkfs.FS'."
+  (cond ((string-prefix? "ext" type)
+         (create-ext-file-system partition type #:label label #:uuid uuid
+                                 #:options options))
+        ((or (string-prefix? "fat" type) (string= "vfat" type))
+         (create-fat-file-system partition #:label label #:uuid uuid
+                                 #:options options))
+        (else (error "Unsupported file system."))))
+
+(define (initialize-partition partition)
+  "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
+it, run its initializer, and unmount it."
+  (let ((target "/fs"))
+   (format-partition (partition-device partition)
+                     (partition-file-system partition)
+                     #:label (partition-label partition)
+                     #:uuid (partition-uuid partition)
+                     #:options (partition-file-system-options partition))
+   (mkdir-p target)
+   (mount (partition-device partition) target
+          (partition-file-system partition))
+
+   ((partition-initializer partition) target)
+
+   (umount target)
+   partition))
+
+(define* (root-partition-initializer #:key (closures '())
+                                     copy-closures?
+                                     (register-closures? #t)
+                                     system-directory
+                                     (deduplicate? #t)
+                                     (make-device-nodes
+                                      make-essential-device-nodes)
+                                     (extra-directives '()))
+  "Return a procedure to initialize a root partition.
+
+If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
+store.  If DEDUPLICATE? is true, then also deduplicate files common to
+CLOSURES and the rest of the store when registering the closures.  If
+COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
+SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation.
+
+EXTRA-DIRECTIVES is an optional list of directives to populate the root file
+system that is passed to 'populate-root-file-system'."
+  (lambda (target)
+    (define target-store
+      (string-append target (%store-directory)))
+
+    (when copy-closures?
+      ;; Populate the store.
+      (populate-store (map (cut string-append "/xchg/" <>) closures)
+                      target
+                      #:deduplicate? deduplicate?))
+
+    ;; Populate /dev.
+    (make-device-nodes target)
+
+    ;; Optionally, register the inputs in the image's store.
+    (when register-closures?
+      (unless copy-closures?
+        ;; XXX: 'register-closure' wants to palpate the things it registers, so
+        ;; bind-mount the store on the target.
+        (mkdir-p target-store)
+        (mount (%store-directory) target-store "" MS_BIND))
+
+      (display "registering closures...\n")
+      (for-each (lambda (closure)
+                  (register-closure target
+                                    (string-append "/xchg/" closure)))
+                closures)
+      (unless copy-closures?
+        (umount target-store)))
+
+    ;; Add the non-store directories and files.
+    (display "populating...\n")
+    (populate-root-file-system system-directory target
+                               #:extras extra-directives)
+
+    ;; 'register-closure' resets timestamps and everything, so no need to do it
+    ;; once more in that case.
+    (unless register-closures?
+      ;; 'reset-timestamps' also resets file permissions; do that everywhere
+      ;; except on /dev so that /dev/null remains writable, etc.
+      (for-each (lambda (directory)
+                  (reset-timestamps (string-append target "/" directory)))
+                (scandir target
+                         (match-lambda
+                           ((or "." ".." "dev") #f)
+                           (_ #t))))
+      (reset-timestamps (string-append target "/dev")
+                        #:preserve-permissions? #t))))
+
+(define (register-bootcfg-root target bootcfg)
+  "On file system TARGET, register BOOTCFG as a GC root."
+  (let ((directory (string-append target "/var/guix/gcroots")))
+    (mkdir-p directory)
+    (symlink bootcfg (string-append directory "/bootcfg"))))
+
+(define* (initialize-hard-disk device
+                               #:key
+                               bootloader-package
+                               bootcfg
+                               bootcfg-location
+                               bootloader-installer
+                               (grub-efi #f)
+                               (partitions '()))
+  "Initialize DEVICE as a disk containing all the <partition> objects listed
+in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
+
+Each partition is initialized by calling its 'initializer' procedure,
+passing it a directory name where it is mounted."
+
+  (define (partition-bootable? partition)
+    "Return the first partition found with the boot flag set."
+    (member 'boot (partition-flags partition)))
+
+  (define (partition-esp? partition)
+    "Return the first EFI System Partition."
+    (member 'esp (partition-flags partition)))
+
+  (let* ((partitions (initialize-partition-table device partitions))
+         (root       (find partition-bootable? partitions))
+         (esp        (find partition-esp? partitions))
+         (target     "/fs"))
+    (unless root
+      (error "no bootable partition specified" partitions))
+
+    (for-each initialize-partition partitions)
+
+    (display "mounting root partition...\n")
+    (mkdir-p target)
+    (mount (partition-device root) target (partition-file-system root))
+    (install-boot-config bootcfg bootcfg-location target)
+    (when bootloader-installer
+      (display "installing bootloader...\n")
+      (bootloader-installer bootloader-package device target))
+
+    (when esp
+      ;; Mount the ESP somewhere and install GRUB UEFI image.
+      (let ((mount-point (string-append target "/boot/efi")))
+        (display "mounting EFI system partition...\n")
+        (mkdir-p mount-point)
+        (mount (partition-device esp) mount-point
+               (partition-file-system esp))
+
+        (display "creating EFI firmware image...")
+        (install-efi-loader grub-efi mount-point)
+        (display "done.\n")
+
+        (umount mount-point)))
+
+    ;; Register BOOTCFG as a GC root.
+    (register-bootcfg-root target bootcfg)
+
+    (umount target)))
+
+;;; vm.scm ends here

gnu/ci.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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>
@@ -28,7 +28,6 @@
   #: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)
@@ -86,7 +85,7 @@
 (define* (derivation->job name drv
                           #:key
                           (max-silent-time 3600)
-                          (timeout (* 5 3600)))
+                          (timeout 3600))
   "Return a Cuirass job called NAME and describing DRV.
 
 MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
@@ -108,9 +107,9 @@ building the derivation."
     (#:timeout . ,timeout)))
 
 (define* (package-job store job-name package system
-                      #:key cross? target (suffix ""))
+                      #:key cross? target)
   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (let ((job-name (string-append job-name "." system suffix)))
+  (let ((job-name (string-append job-name "." system)))
     (parameterize ((%graft? #f))
       (let* ((drv (if cross?
                       (package-cross-derivation store package target system
@@ -130,7 +129,7 @@ building the derivation."
 (define (package-cross-job store job-name package target system)
   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
 SYSTEM."
-  (let ((name (string-append target "." job-name)))
+  (let ((name (string-append target "." job-name "." system)))
     (package-job store name package system
                  #:cross? #t
                  #:target target)))
@@ -139,9 +138,9 @@ SYSTEM."
   ;; Note: Don't put the '-final' package variants because (1) that's
   ;; implicit, and (2) they cannot be cross-built (due to the explicit input
   ;; chain.)
-  (list gcc-8 gcc-9 gcc-10 gcc-11 glibc binutils
+  (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
         gmp mpfr mpc coreutils findutils diffutils patch sed grep
-        gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix
+        gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
         %bootstrap-binaries-tarball
         %binutils-bootstrap-tarball
         (%glibc-bootstrap-tarball)
@@ -149,19 +148,6 @@ SYSTEM."
         %guile-bootstrap-tarball
         %bootstrap-tarballs))
 
-(define (commencement-packages system)
-  "Return the list of bootstrap packages from the commencement module for
-SYSTEM."
-  ;; Only include packages supported on SYSTEM.  For example, the Mes
-  ;; bootstrap graph is currently not supported on ARM so it should be
-  ;; excluded.
-  (filter (lambda (obj)
-            (and (package? obj)
-                 (supported-package? obj system)))
-          (module-map (lambda (sym var)
-                        (variable-ref var))
-                      (resolve-module '(gnu packages commencement)))))
-
 (define (packages-to-cross-build target)
   "Return the list of packages to cross-build for TARGET."
   ;; Don't cross-build the bootstrap tarballs for MinGW.
@@ -302,16 +288,20 @@ otherwise use the IMAGE name."
 
 (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)))))
+  (let* ((build (lambda* (store name inputs
+                                #:key source commit system
+                                #:allow-other-keys)
+                  (run-with-store store
+                    ;; SOURCE can be a lowerable object such as <local-file>
+                    ;; or a file name.  Adjust accordingly.
+                    (mlet* %store-monad ((source (if (string? source)
+                                                     (return source)
+                                                     (lower-object source)))
+                                         (instance
+                                          -> (checkout->channel-instance
+                                              source #:commit commit)))
+                      (channel-instances->derivation (list instance)))
+                    #:system system)))
          (lower (lambda* (name #:key system source commit
                                #:allow-other-keys)
                   (bag
@@ -396,39 +386,21 @@ otherwise use the IMAGE name."
                            (((_ inputs _ ...) ...)
                             inputs))))
                       (%final-inputs)))))
-    (lambda* (store package system #:key (suffix ""))
+    (lambda (store package system)
       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
-valid.  Append SUFFIX to the job name."
+valid."
       (cond ((member package base-packages)
              (package-job store (string-append "base." (job-name package))
-                          package system #:suffix suffix))
+                          package system))
             ((supported-package? package system)
              (let ((drv (package-derivation store package system
                                             #:graft? #f)))
                (and (substitutable-derivation? drv)
                     (package-job store (job-name package)
-                                 package system #:suffix suffix))))
+                                 package system))))
             (else
              #f)))))
 
-(define %x86-64-micro-architectures
-  ;; Micro-architectures for which we build tuned variants.
-  '("westmere" "ivybridge" "haswell" "skylake" "skylake-avx512"))
-
-(define (tuned-package-jobs store package system)
-  "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures."
-  (filter-map (lambda (micro-architecture)
-                (define suffix
-                  (string-append "." micro-architecture))
-
-                (package->job store
-                              (tuned-package package micro-architecture)
-                              system
-                              #:suffix suffix))
-              (match system
-                ("x86_64-linux" %x86-64-micro-architectures)
-                (_ '()))))
-
 (define (all-packages)
   "Return the list of packages to build."
   (define (adjust package result)
@@ -462,40 +434,19 @@ valid.  Append SUFFIX to the job name."
               (map channel-url channels)))
        arguments))
 
-(define (manifests->jobs store manifests)
-  "Return the list of jobs for the entries in MANIFESTS, a list of file
-names."
+(define (manifests->packages store manifests)
+  "Return the list of packages found in MANIFESTS."
   (define (load-manifest manifest)
     (save-module-excursion
      (lambda ()
        (set-current-module (make-user-module '((guix profiles) (gnu))))
        (primitive-load manifest))))
 
-  (define (manifest-entry-job-name entry)
-    (string-append (manifest-entry-name entry) "-"
-                   (manifest-entry-version entry)))
-
-  (define (manifest-entry->job entry)
-    (let* ((obj (manifest-entry-item entry))
-           (drv (parameterize ((%graft? #f))
-                  (run-with-store store
-                    (lower-object obj))))
-           (max-silent-time (or (and (package? obj)
-                                     (assoc-ref (package-properties obj)
-                                                'max-silent-time))
-                                3600))
-           (timeout (or (and (package? obj)
-                             (assoc-ref (package-properties obj) 'timeout))
-                        (* 5 3600))))
-      (derivation->job (manifest-entry-job-name entry) drv
-                       #:max-silent-time max-silent-time
-                       #:timeout timeout)))
-
-  (map manifest-entry->job
-       (delete-duplicates
-        (append-map (compose manifest-entries load-manifest)
-                    manifests)
-        manifest-entry=?)))
+  (delete-duplicates!
+   (map manifest-entry-item
+        (append-map (compose manifest-entries
+                             load-manifest)
+                    manifests))))
 
 (define (arguments->systems arguments)
   "Return the systems list from ARGUMENTS."
@@ -546,16 +497,10 @@ names."
          ('all
           ;; Build everything, including replacements.
           (let ((all (all-packages))
-                (jobs (lambda (package)
-                        (match (package->job store package system)
-                          (#f '())
-                          (main-job
-                           (cons main-job
-                                 (if (tunable-package? package)
-                                     (tuned-package-jobs store package system)
-                                     '())))))))
+                (job (lambda (package)
+                       (package->job store package system))))
             (append
-             (append-map jobs all)
+             (filter-map job all)
              (cross-jobs store system))))
          ('core
           ;; Build core packages only.
@@ -563,7 +508,7 @@ names."
            (map (lambda (package)
                   (package-job store (job-name package)
                                package system))
-                (append (commencement-packages system) %core-packages))
+                %core-packages)
            (cross-jobs store system)))
          ('guix
           ;; Build Guix modules only.
@@ -614,8 +559,12 @@ names."
                  packages)))
          (('manifests . rest)
           ;; Build packages in the list of manifests.
-          (let ((manifests (arguments->manifests rest channels)))
-            (manifests->jobs store manifests)))
+          (let* ((manifests (arguments->manifests rest channels))
+                 (packages (manifests->packages store manifests)))
+            (map (lambda (package)
+                   (package-job store (job-name package)
+                                package system))
+                 packages)))
          (else
           (error "unknown subset" subset))))
      systems)))

gnu/home.scm

@@ -1,116 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;;
-;;; 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)
-  #:use-module (gnu home services)
-  #:use-module (gnu home services symlink-manager)
-  #:use-module (gnu home services shells)
-  #:use-module (gnu home services xdg)
-  #:use-module (gnu home services fontutils)
-  #:use-module (gnu services)
-  #:use-module (guix records)
-  #:use-module (guix diagnostics)
-  #:use-module (guix gexp)
-  #:use-module (guix store)
-
-  #:export (home-environment
-            home-environment?
-            this-home-environment
-
-            home-environment-derivation
-            home-environment-user-services
-            home-environment-essential-services
-            home-environment-services
-            home-environment-location
-
-            home-environment-with-provenance))
-
-;;; Comment:
-;;;
-;;; This module provides a <home-environment> record for managing
-;;; per-user packages and configuration files in the similar way as
-;;; <operating-system> do for system packages and configuration files.
-;;;
-;;; Code:
-
-(define-record-type* <home-environment> home-environment
-  make-home-environment
-  home-environment?
-  this-home-environment
-
-  (packages           home-environment-packages            ; list of (PACKAGE OUTPUT...)
-                      (default '()))
-
-  (essential-services home-environment-essential-services  ; list of services
-                      (thunked)
-                      (default (home-environment-default-essential-services
-                                this-home-environment)))
-
-  (services           home-environment-user-services
-                      (default '()))
-
-  (location           home-environment-location            ; <location>
-                      (default (and=> (current-source-location)
-                                      source-properties->location))
-                      (innate)))
-
-(define (home-environment-default-essential-services he)
-  "Return the list of essential services for home environment."
-  (list
-   (service home-run-on-first-login-service-type)
-   (service home-activation-service-type)
-   (service home-environment-variables-service-type)
-
-   (service home-symlink-manager-service-type)
-
-   (service home-fontconfig-service-type)
-   (service home-xdg-base-directories-service-type)
-   (service home-shell-profile-service-type)
-
-   (service home-service-type)
-   (service home-profile-service-type (home-environment-packages he))))
-
-(define* (home-environment-services he)
-  "Return all the services of home environment."
-  (instantiate-missing-services
-   (append (home-environment-user-services he)
-           (home-environment-essential-services he))))
-
-(define* (home-environment-derivation he)
-  "Return a derivation that builds OS."
-  (let* ((services         (home-environment-services he))
-         (home (fold-services services
-                              #:target-type home-service-type)))
-    (service-value home)))
-
-(define* (home-environment-with-provenance he config-file)
-  "Return a variant of HE that stores its own provenance information,
-including CONFIG-FILE, if available.  This is achieved by adding an instance
-of HOME-PROVENANCE-SERVICE-TYPE to its services."
-  (home-environment
-    (inherit he)
-    (services (cons (service home-provenance-service-type config-file)
-                    (home-environment-user-services he)))))
-
-(define-gexp-compiler (home-environment-compiler (he <home-environment>)
-                                                 system target)
-  ((store-lift
-    (lambda (store)
-      (run-with-store store (home-environment-derivation he)
-                      #:system system
-                      #:target target)))))

gnu/home/services.scm

@@ -1,582 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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)
-  #:use-module (gnu services)
-  #:use-module ((gnu packages package-management) #:select (guix))
-  #:use-module (guix channels)
-  #:use-module (guix monads)
-  #:use-module (guix store)
-  #:use-module (guix gexp)
-  #:use-module (guix profiles)
-  #:use-module (guix sets)
-  #:use-module (guix ui)
-  #:use-module (guix discovery)
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
-  #:use-module (guix modules)
-  #:use-module (srfi srfi-1)
-  #:use-module (ice-9 match)
-
-  #:export (home-service-type
-            home-profile-service-type
-            home-environment-variables-service-type
-            home-files-service-type
-            home-xdg-configuration-files-service-type
-            home-run-on-first-login-service-type
-            home-activation-service-type
-            home-run-on-change-service-type
-            home-provenance-service-type
-
-            home-files-directory
-            xdg-configuration-files-directory
-
-            fold-home-service-types
-            home-provenance
-
-            %initialize-gettext)
-
-  #:re-export (service
-               service-type
-               service-extension))
-
-;;; Comment:
-;;;
-;;; This module is similar to (gnu system services) module, but
-;;; provides Home Services, which are supposed to be used for building
-;;; home-environment.
-;;;
-;;; Home Services use the same extension as System Services.  Consult
-;;; (gnu system services) module or manual for more information.
-;;;
-;;; home-service-type is a root of home services DAG.
-;;;
-;;; home-profile-service-type is almost the same as profile-service-type, at least
-;;; for now.
-;;;
-;;; home-environment-variables-service-type generates a @file{setup-environment}
-;;; shell script, which is expected to be sourced by login shell or other program,
-;;; which starts early and spawns all other processes.  Home services for shells
-;;; automatically add code for sourcing this file, if person do not use those home
-;;; services they have to source this script manually in their's shell *profile
-;;; file (details described in the manual).
-;;;
-;;; home-files-service-type is similar to etc-service-type, but doesn't extend
-;;; home-activation, because deploy mechanism for config files is pluggable
-;;; and can be different for different home environments: The default one is
-;;; called symlink-manager, which creates links for various dotfiles and xdg
-;;; configuration files to store, but is possible to implement alternative
-;;; approaches like read-only home from Julien's guix-home-manager.
-;;;
-;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile
-;;; script, which runs provided gexps once, when user makes first login.  It can
-;;; be used to start user's Shepherd and maybe some other process.  It relies on
-;;; assumption that /run/user/$UID will be created on login by some login
-;;; manager (elogind for example).
-;;;
-;;; home-activation-service-type provides an @file{activate} guile script, which
-;;; do three main things:
-;;;
-;;; - Sets environment variables to the values declared in
-;;; @file{setup-environment} shell script.  It's necessary, because user can set
-;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of
-;;; symlink-manager.
-;;;
-;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store.
-;;; Later those variables can be used by activation gexps, for example by
-;;; symlink-manager or run-on-change services.
-;;;
-;;; - Run all activation gexps provided by other home services.
-;;;
-;;; home-run-on-change-service-type allows to trigger actions during
-;;; activation if file or directory specified by pattern is changed.
-;;;
-;;; Code:
-
-
-(define (home-derivation entries mextensions)
-  "Return as a monadic value the derivation of the 'home'
-directory containing the given entries."
-  (mlet %store-monad ((extensions (mapm/accumulate-builds identity
-                                                          mextensions)))
-    (lower-object
-     (file-union "home" (append entries (concatenate extensions))))))
-
-(define home-service-type
-  ;; This is the ultimate service type, the root of the home service
-  ;; DAG.  The service of this type is extended by monadic name/item
-  ;; pairs.  These items end up in the "home-environment directory" as
-  ;; returned by 'home-environment-derivation'.
-  (service-type (name 'home)
-                (extensions '())
-                (compose identity)
-                (extend home-derivation)
-                (default-value '())
-                (description
-                 "Build the home environment top-level directory,
-which in turn refers to everything the home environment needs: its
-packages, configuration files, activation script, and so on.")))
-
-(define (packages->profile-entry packages)
-  "Return a system entry for the profile containing PACKAGES."
-  ;; XXX: 'mlet' is needed here for one reason: to get the proper
-  ;; '%current-target' and '%current-target-system' bindings when
-  ;; 'packages->manifest' is called, and thus when the 'package-inputs'
-  ;; etc. procedures are called on PACKAGES.  That way, conditionals in those
-  ;; inputs see the "correct" value of these two parameters.  See
-  ;; <https://issues.guix.gnu.org/44952>.
-  (mlet %store-monad ((_ (current-target-system)))
-    (return `(("profile" ,(profile
-                           (content (packages->manifest
-                                     (map identity
-                                     ;;(options->transformation transformations)
-                                     (delete-duplicates packages eq?))))))))))
-
-;; MAYBE: Add a list of transformations for packages.  It's better to
-;; place it in home-profile-service-type to affect all profile
-;; packages and prevent conflicts, when other packages relies on
-;; non-transformed version of package.
-(define home-profile-service-type
-  (service-type (name 'home-profile)
-                (extensions
-                 (list (service-extension home-service-type
-                                          packages->profile-entry)))
-                (compose concatenate)
-                (extend append)
-                (description
-                 "This is the @dfn{home profile} and can be found in
-@file{~/.guix-home/profile}.  It contains packages and
-configuration files that the user has declared in their
-@code{home-environment} record.")))
-
-(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
-environment profile, set some default environment variables, and set
-environment variables provided in @code{vars}.  @code{vars} is a list
-of pairs (@code{(key . value)}), @code{key} is a string and
-@code{value} is a string or gexp.
-
-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-defenitions)
-    (fold
-     (lambda (x acc)
-       (when (equal? (car x) (car acc))
-         (warning
-          (G_ "duplicate definition for `~a' environment variable ~%") (car x)))
-       x)
-     (cons "" "")
-     (sort vars (lambda (a b)
-                  (string<? (car a) (car b))))))
-
-  (warn-about-duplicate-defenitions)
-  (with-monad
-   %store-monad
-   (return
-    `(("setup-environment"
-       ;; TODO: It's necessary to source ~/.guix-profile too
-       ;; on foreign distros
-       ,(apply mixed-text-file "setup-environment"
-               "\
-HOME_ENVIRONMENT=$HOME/.guix-home
-GUIX_PROFILE=\"$HOME_ENVIRONMENT/profile\"
-PROFILE_FILE=\"$HOME_ENVIRONMENT/profile/etc/profile\"
-[ -f $PROFILE_FILE ] && . $PROFILE_FILE
-
-case $XDG_DATA_DIRS in
-  *$HOME_ENVIRONMENT/profile/share*) ;;
-  *) export XDG_DATA_DIRS=$HOME_ENVIRONMENT/profile/share:$XDG_DATA_DIRS ;;
-esac
-case $MANPATH in
-  *$HOME_ENVIRONMENT/profile/share/man*) ;;
-  *) export MANPATH=$HOME_ENVIRONMENT/profile/share/man:$MANPATH
-esac
-case $INFOPATH in
-  *$HOME_ENVIRONMENT/profile/share/info*) ;;
-  *) export INFOPATH=$HOME_ENVIRONMENT/profile/share/info:$INFOPATH ;;
-esac
-case $XDG_CONFIG_DIRS in
-  *$HOME_ENVIRONMENT/profile/etc/xdg*) ;;
-  *) export XDG_CONFIG_DIRS=$HOME_ENVIRONMENT/profile/etc/xdg:$XDG_CONFIG_DIRS ;;
-esac
-case $XCURSOR_PATH in
-  *$HOME_ENVIRONMENT/profile/share/icons*) ;;
-  *) export XCURSOR_PATH=$HOME_ENVIRONMENT/profile/share/icons:$XCURSOR_PATH ;;
-esac
-
-"
-
-               (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)
-                (extensions
-                 (list (service-extension
-                        home-service-type
-                        environment-variables->setup-environment-script)))
-                (compose concatenate)
-                (extend append)
-                (default-value '())
-                (description "Set the environment variables.")))
-
-(define (files->files-directory files)
-  "Return a @code{files} directory that contains FILES."
-  (define (assert-no-duplicates files)
-    (let loop ((files files)
-               (seen (set)))
-      (match files
-        (() #t)
-        (((file _) rest ...)
-         (when (set-contains? seen file)
-           (raise (formatted-message (G_ "duplicate '~a' entry for files/")
-                                     file)))
-         (loop rest (set-insert file seen))))))
-
-  ;; Detect duplicates early instead of letting them through, eventually
-  ;; leading to a build failure of "files.drv".
-  (assert-no-duplicates files)
-
-  (file-union "files" files))
-
-;; Used by symlink-manager
-(define home-files-directory "files")
-
-(define (files-entry files)
-  "Return an entry for the @file{~/.guix-home/files}
-directory containing FILES."
-  (with-monad %store-monad
-    (return `((,home-files-directory ,(files->files-directory files))))))
-
-(define home-files-service-type
-  (service-type (name 'home-files)
-                (extensions
-                 (list (service-extension home-service-type
-                                          files-entry)))
-                (compose concatenate)
-                (extend append)
-                (default-value '())
-                (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 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)
-                rest)))
-         files))
-
-(define home-xdg-configuration-files-service-type
-  (service-type (name 'home-files)
-                (extensions
-                 (list (service-extension home-files-service-type
-                                          xdg-configuration-files)))
-                (compose concatenate)
-                (extend append)
-                (default-value '())
-                (description "Files that will be put in
-@file{~~/.guix-home/files/config}, and further processed during activation.")))
-
-(define %initialize-gettext
-  #~(begin
-      (bindtextdomain %gettext-domain
-                      (string-append #$guix "/share/locale"))
-      (textdomain %gettext-domain)))
-
-(define (compute-on-first-login-script _ gexps)
-  (program-file
-   "on-first-login"
-   (with-imported-modules (source-module-closure '((guix i18n)))
-     #~(begin
-       (use-modules (guix i18n))
-       #$%initialize-gettext
-
-       (let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
-                                   (format #f "/run/user/~a" (getuid))))
-              (flag-file-path (string-append
-                               xdg-runtime-dir "/on-first-login-executed"))
-              (touch (lambda (file-name)
-                       (call-with-output-file file-name (const #t)))))
-         ;; XDG_RUNTIME_DIR dissapears on logout, that means such trick
-         ;; allows to launch on-first-login script on first login only
-         ;; after complete logout/reboot.
-         (if (file-exists? xdg-runtime-dir)
-             (unless (file-exists? flag-file-path)
-               (begin #$@gexps (touch flag-file-path)))
-             ;; TRANSLATORS: 'on-first-login' is the name of a service and
-             ;; shouldn't be translated
-             (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'"))))))))
-
-(define (on-first-login-script-entry on-first-login)
-  "Return, as a monadic value, an entry for the on-first-login script
-in the home environment directory."
-  (with-monad %store-monad
-    (return `(("on-first-login" ,on-first-login)))))
-
-(define home-run-on-first-login-service-type
-  (service-type (name 'home-run-on-first-login)
-                (extensions
-                 (list (service-extension
-                        home-service-type
-                        on-first-login-script-entry)))
-                (compose identity)
-                (extend compute-on-first-login-script)
-                (default-value #f)
-                (description "Run gexps on first user login.  Can be
-extended with one gexp.")))
-
-
-(define (compute-activation-script init-gexp gexps)
-  (gexp->script
-   "activate"
-   #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment")))
-            (he-path (string-append (getenv "HOME") "/.guix-home"))
-            (new-home-env (getenv "GUIX_NEW_HOME"))
-            (new-home (or new-home-env
-                          ;; 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))
-                              (readlink he-path)
-                              #f))))
-       (if (file-exists? (he-init-file new-home))
-           (let* ((port   ((@ (ice-9 popen) open-input-pipe)
-                           (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 #\=)))
-                                 (cons (string-take x si)
-                                       (string-drop x (1+ si)))))
-                             ((@ (srfi srfi-1) remove)
-                              string-null?
-                              (string-split result #\nul)))))
-             (close-port port)
-             (map (lambda (x) (setenv (car x) (cdr x))) vars)
-
-             (setenv "GUIX_NEW_HOME" new-home)
-             (setenv "GUIX_OLD_HOME" old-home)
-
-             #$@gexps
-
-             ;; Do not unset env variable if it was set outside.
-             (unless new-home-env (setenv "GUIX_NEW_HOME" #f))
-             (unless old-home-env (setenv "GUIX_OLD_HOME" #f)))
-           (format #t "\
-Activation script was either called or loaded by file from this directory:
-~a
-It doesn't seem that home environment is somewhere around.
-Make sure that you call ./activate by symlink from -home store item.\n"
-                   new-home)))))
-
-(define (activation-script-entry m-activation)
-  "Return, as a monadic value, an entry for the activation script
-in the home environment directory."
-  (mlet %store-monad ((activation m-activation))
-    (return `(("activate" ,activation)))))
-
-(define home-activation-service-type
-  (service-type (name 'home-activation)
-                (extensions
-                 (list (service-extension
-                        home-service-type
-                        activation-script-entry)))
-                (compose identity)
-                (extend compute-activation-script)
-                (default-value #f)
-                (description "Run gexps to activate the current
-generation of home environment and update the state of the home
-directory.  @command{activate} script automatically called during
-reconfiguration or generation switching.  This service can be extended
-with one gexp, but many times, and all gexps must be idempotent.")))
-
-
-;;;
-;;; On-change.
-;;;
-
-(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples)
-  (with-imported-modules (source-module-closure '((guix i18n)))
-    #~(begin
-      (use-modules (guix i18n))
-
-      #$%initialize-gettext
-
-      (define (equal-regulars? file1 file2)
-        "Check if FILE1 and FILE2 are bit for bit identical."
-        (let* ((cmp-binary #$(file-append
-                              (@ (gnu packages base) diffutils) "/bin/cmp"))
-               (stats1     (lstat file1))
-               (stats2     (lstat file2)))
-          (cond
-           ((= (stat:ino stats1) (stat:ino stats2))         #t)
-           ((not (= (stat:size stats1) (stat:size stats2))) #f)
-
-           (else (= (system* cmp-binary file1 file2) 0)))))
-
-      (define (equal-symlinks? symlink1 symlink2)
-        "Check if SYMLINK1 and SYMLINK2 are pointing to the same target."
-        (string=? (readlink symlink1) (readlink symlink2)))
-
-      (define (equal-directories? dir1 dir2)
-        "Check if DIR1 and DIR2 have the same content."
-        (define (ordinary-file file)
-          (not (or (string=? file ".")
-                   (string=? file ".."))))
-        (let* ((files1 (scandir dir1 ordinary-file))
-               (files2 (scandir dir2 ordinary-file)))
-          (if (equal? files1 files2)
-              (map (lambda (file)
-                     (equal-files?
-                      (string-append dir1 "/" file)
-                      (string-append dir2 "/" file)))
-                   files1)
-              #f)))
-
-      (define (equal-files? file1 file2)
-        "Compares files, symlinks or directories of the same type."
-        (case (file-type file1)
-          ((directory) (equal-directories? file1 file2))
-          ((symlink) (equal-symlinks? file1 file2))
-          ((regular) (equal-regulars? file1 file2))
-          (else
-           (display "The file type is unsupported by on-change service.\n")
-           #f)))
-
-      (define (file-type file)
-        (stat:type (lstat file)))
-
-      (define (something-changed? file1 file2)
-        (cond
-         ((and (not (file-exists? file1))
-               (not (file-exists? file2))) #f)
-         ((or  (not (file-exists? file1))
-               (not (file-exists? file2))) #t)
-
-         ((not (eq? (file-type file1) (file-type file2))) #t)
-
-         (else
-          (not (equal-files? file1 file2)))))
-
-      (define expressions-to-eval
-        (map
-         (lambda (x)
-           (let* ((file1 (string-append
-                          (or (getenv "GUIX_OLD_HOME")
-                              "/gnu/store/non-existing-generation")
-                          "/" (car x)))
-                  (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x)))
-                  (_ (format #t (G_ "Comparing ~a and\n~10t~a...") file1 file2))
-                  (any-changes? (something-changed? file1 file2))
-                  (_ (format #t (G_ " done (~a)\n")
-                             (if any-changes? "changed" "same"))))
-             (if any-changes? (cadr x) "")))
-         '#$pattern-gexp-tuples))
-
-      (if #$eval-gexps?
-          (begin
-            ;;; TRANSLATORS: 'on-change' is the name of a service type, it
-            ;;; probably shouldn't be translated.
-            (display (G_ "Evaluating on-change gexps.\n\n"))
-            (for-each primitive-eval expressions-to-eval)
-            (display (G_ "On-change gexps evaluation finished.\n\n")))
-          (display "\
-On-change gexps won't be evaluated; evaluation has been disabled in the
-service configuration")))))
-
-(define home-run-on-change-service-type
-  (service-type (name 'home-run-on-change)
-                (extensions
-                 (list (service-extension
-                        home-activation-service-type
-                        identity)))
-                (compose concatenate)
-                (extend compute-on-change-gexp)
-                (default-value #t)
-                (description "\
-G-expressions to run if the specified files have changed since the
-last generation.  The extension should be a list of lists where the
-first element is the pattern for file or directory that expected to be
-changed, and the second element is the G-expression to be evaluated.")))
-
-
-;;;
-;;; Provenance tracking.
-;;;
-
-(define home-provenance-service-type
-  (service-type
-   (name 'home-provenance)
-   (extensions
-    (list (service-extension
-           home-service-type
-           (service-extension-compute
-            (first (service-type-extensions provenance-service-type))))))
-   (default-value #f)                ;the HE config file
-   (description "\
-Store provenance information about the home environment in the home
-environment itself: the channels used when building the home
-environment, and its configuration file, when available.")))
-
-(define sexp->home-provenance sexp->system-provenance)
-(define home-provenance system-provenance)
-
-
-;;;
-;;; Searching
-;;;
-
-(define (parent-directory directory)
-  "Get the parent directory of DIRECTORY"
-  (string-join (drop-right (string-split directory #\/) 1) "/"))
-
-(define %guix-home-root-directory
-  ;; Absolute file name of the module hierarchy.
-  (parent-directory
-   (dirname (dirname (search-path %load-path "gnu/home/services.scm")))))
-
-(define %service-type-path
-  ;; Search path for service types.
-  (make-parameter `((,%guix-home-root-directory . "gnu/home/services"))))
-
-(define (all-home-service-modules)
-  "Return the default set of `home service' modules."
-  (cons (resolve-interface '(gnu home services))
-        (all-modules (%service-type-path)
-                     #:warn warn-about-load-error)))
-
-(define* (fold-home-service-types proc seed)
-  (fold-service-types proc seed (all-home-service-modules)))

gnu/home/services/desktop.scm

@@ -1,174 +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 desktop)
-  #:use-module (gnu home services)
-  #:use-module (gnu home services shepherd)
-  #:use-module (gnu services configuration)
-  #:autoload   (gnu packages xdisorg) (redshift)
-  #:use-module (guix records)
-  #:use-module (guix gexp)
-  #:use-module (srfi srfi-1)
-  #:use-module (ice-9 match)
-  #:export (home-redshift-configuration
-            home-redshift-configuration?
-
-            home-redshift-service-type))
-
-
-;;;
-;;; Redshift.
-;;;
-
-(define (serialize-integer field value)
-  (string-append (match field
-                   ('daytime-temperature "temp-day")
-                   ('nighttime-temperature "temp-night")
-                   ('daytime-brightness "brightness-day")
-                   ('nighttime-brightness "brightness-night")
-                   ('latitude "lat")
-                   ('longitude "lon")
-                   (_ (symbol->string field)))
-                 "=" (number->string value) "\n"))
-
-(define (serialize-symbol field value)
-  (string-append (symbol->string field)
-                 "=" (symbol->string value) "\n"))
-
-(define (serialize-string field value)
-  (string-append (symbol->string field)
-                 "=" value "\n"))
-
-(define serialize-inexact-number serialize-integer)
-
-(define (inexact-number? n)
-  (and (number? n) (inexact? n)))
-(define-maybe inexact-number)
-(define-maybe string)
-
-(define (serialize-raw-configuration-string field value)
-  value)
-(define raw-configuration-string? string?)
-
-(define-configuration home-redshift-configuration
-  (redshift
-   (file-like redshift)
-   "Redshift package to use.")
-
-  (location-provider
-   (symbol 'geoclue2)
-   "Geolocation provider---@code{'manual} or @code{'geoclue2}.
-
-In the former case, you must also specify the @code{latitude} and
-@code{longitude} fields so Redshift can determine daytime at your place.  In
-the latter case, the Geoclue system service must be running; it will be
-queried for location information.")
-  (adjustment-method
-   (symbol 'randr)
-   "Color adjustment method.")
-
-  ;; Default values from redshift(1).
-  (daytime-temperature
-   (integer 6500)
-   "Daytime color temperature (kelvins).")
-  (nighttime-temperature
-   (integer 4500)
-   "Nighttime color temperature (kelvins).")
-
-  (daytime-brightness
-   (maybe-inexact-number 'disabled)
-   "Daytime screen brightness, between 0.1 and 1.0.")
-  (nighttime-brightness
-   (maybe-inexact-number 'disabled)
-   "Nighttime screen brightness, between 0.1 and 1.0.")
-
-  (latitude
-   (maybe-inexact-number 'disabled)
-   "Latitude, when @code{location-provider} is @code{'manual}.")
-  (longitude
-   (maybe-inexact-number 'disabled)
-   "Longitude, when @code{location-provider} is @code{'manual}.")
-
-  (dawn-time
-   (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 'disabled)
-   "Likewise, custom time for the transition from day to night in the
-evening.")
-
-  (extra-content
-   (raw-configuration-string "")
-   "Extra content appended as-is to the Redshift configuration file.  Run
-@command{man redshift} for more information about the configuration file
-format."))
-
-(define (serialize-redshift-configuration config)
-  (define location-fields
-    '(latitude longitude))
-
-  (define (location-field? field)
-    (memq (configuration-field-name field) location-fields))
-
-  (define (secondary-field? field)
-    (or (location-field? field)
-        (memq (configuration-field-name field)
-              '(redshift extra-content))))
-
-  #~(string-append
-     "[redshift]\n"
-     #$(serialize-configuration config
-                                (remove secondary-field?
-                                        home-redshift-configuration-fields))
-
-     #$(home-redshift-configuration-extra-content config)
-
-     "\n[manual]\n"
-     #$(serialize-configuration config
-                                (filter location-field?
-                                        home-redshift-configuration-fields))))
-
-(define (redshift-shepherd-service config)
-  (define config-file
-    (computed-file "redshift.conf"
-                   #~(call-with-output-file #$output
-                       (lambda (port)
-                         (display #$(serialize-redshift-configuration config)
-                                  port)))))
-
-  (list (shepherd-service
-         (documentation "Redshift program.")
-         (provision '(redshift))
-         ;; FIXME: This fails to start if Home is first activated from a
-         ;; non-X11 session.
-         (start #~(make-forkexec-constructor
-                   (list #$(file-append redshift "/bin/redshift")
-                         "-c" #$config-file)))
-         (stop #~(make-kill-destructor)))))
-
-(define home-redshift-service-type
-  (service-type
-   (name 'home-redshift)
-   (extensions (list (service-extension home-shepherd-service-type
-                                        redshift-shepherd-service)))
-   (default-value (home-redshift-configuration))
-   (description
-    "Run Redshift, a program that adjusts the color temperature of display
-according to time of day.")))

gnu/home/services/fontutils.scm

@@ -1,65 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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 fontutils)
-  #:use-module (gnu home services)
-  #:use-module (gnu packages fontutils)
-  #:use-module (guix gexp)
-
-  #:export (home-fontconfig-service-type))
-
-;;; Commentary:
-;;;
-;;; Services related to fonts.  home-fontconfig service provides
-;;; fontconfig configuration, which allows fc-* utilities to find
-;;; fonts in Guix Home's profile and regenerates font cache on
-;;; activation.
-;;;
-;;; Code:
-
-(define (add-fontconfig-config-file he-symlink-path)
-  `(("fontconfig/fonts.conf"
-     ,(mixed-text-file
-       "fonts.conf"
-       "<?xml version='1.0'?>
-<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>
-<fontconfig>
-  <dir>~/.guix-home/profile/share/fonts</dir>
-</fontconfig>"))))
-
-(define (regenerate-font-cache-gexp _)
-  `(("profile/share/fonts"
-     ,#~(system* #$(file-append fontconfig "/bin/fc-cache") "-fv"))))
-
-(define home-fontconfig-service-type
-  (service-type (name 'home-fontconfig)
-                (extensions
-                 (list (service-extension
-                        home-xdg-configuration-files-service-type
-                        add-fontconfig-config-file)
-                       (service-extension
-                        home-run-on-change-service-type
-                        regenerate-font-cache-gexp)
-                       (service-extension
-                        home-profile-service-type
-                        (const (list fontconfig)))))
-                (default-value #f)
-                (description
-                 "Provides configuration file for fontconfig and make
-fc-* utilities aware of font packages installed in Guix Home's profile.")))

gnu/home/services/mcron.scm

@@ -1,115 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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 mcron)
-  #:use-module (gnu packages guile-xyz)
-  #:use-module (gnu home services)
-  #:use-module (gnu services shepherd)
-  #:use-module (gnu home services shepherd)
-  #:use-module (guix records)
-  #:use-module (guix gexp)
-  #:use-module (srfi srfi-1)
-  #:use-module (ice-9 match)
-
-  #:export (home-mcron-configuration
-            home-mcron-service-type))
-
-;;; Commentary:
-;;
-;; Service for the GNU mcron cron job manager.
-;;
-;; Example configuration, the first job runs mbsync once every ten
-;; minutes, the second one writes "Mcron service" to ~/mcron-file once
-;; every minute.
-;;
-;; (service home-mcron-service-type
-;;            (home-mcron-configuration
-;;             (jobs (list #~(job '(next-minute
-;;                                  (range 0 60 10))
-;;                                (lambda ()
-;;                                  (system* "mbsync" "--all")))
-;;                         #~(job next-minute-from
-;;                                (lambda ()
-;;                                  (call-with-output-file (string-append (getenv "HOME")
-;;                                                                        "/mcron-file")
-;;                                    (lambda (port)
-;;                                      (display "Mcron service" port)))))))))
-;;
-;;; Code:
-
-(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
-  (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-package))
-
-(define (home-mcron-extend config jobs)
-  (home-mcron-configuration
-   (inherit config)
-   (jobs (append (home-mcron-configuration-jobs config)
-                 jobs))))
-
-(define home-mcron-service-type
-  (service-type (name 'home-mcron)
-                (extensions
-                 (list (service-extension
-                        home-shepherd-service-type
-                        home-mcron-shepherd-services)
-                       (service-extension
-                        home-profile-service-type
-                        home-mcron-profile)))
-                (compose concatenate)
-                (extend home-mcron-extend)
-                (default-value (home-mcron-configuration))
-                (description
-                 "Install and configure the GNU mcron cron job manager.")))

gnu/home/services/shells.scm

@@ -1,699 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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 shells)
-  #:use-module (gnu services configuration)
-  #:use-module (gnu home services utils)
-  #:use-module (gnu home services)
-  #:use-module (gnu packages shells)
-  #:use-module (gnu packages bash)
-  #:use-module (guix gexp)
-  #:use-module (guix packages)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (ice-9 match)
-
-  #:export (home-shell-profile-service-type
-            home-shell-profile-configuration
-
-            home-bash-service-type
-            home-bash-configuration
-            home-bash-extension
-
-            home-zsh-service-type
-            home-zsh-configuration
-            home-zsh-extension
-
-            home-fish-service-type
-            home-fish-configuration
-            home-fish-extension))
-
-;;; Commentary:
-;;;
-;;; This module contains shell related services like Zsh.
-;;;
-;;; Code:
-
-
-;;;
-;;; Shell profile.
-;;;
-
-(define path? string?)
-(define (serialize-path field-name val) val)
-
-(define-configuration home-shell-profile-configuration
-  (profile
-   (text-config '())
-   "\
-@code{home-shell-profile} is instantiated automatically by
-@code{home-environment}, DO NOT create this service manually, it can
-only be extended.
-
-@code{profile} is a list of file-like objects, which will go to
-@file{~/.profile}.  By default @file{~/.profile} contains the
-initialization code, which have to be evaluated by login shell to make
-home-environment's profile available to the user, but other commands
-can be added to the file if it is really necessary.
-
-In most cases shell's configuration files are preferred places for
-user's customizations.  Extend home-shell-profile service only if you
-really know what you do."))
-
-(define (add-shell-profile-file config)
-  `(("profile"
-     ,(mixed-text-file
-       "shell-profile"
-       "\
-HOME_ENVIRONMENT=$HOME/.guix-home
-. $HOME_ENVIRONMENT/setup-environment
-$HOME_ENVIRONMENT/on-first-login\n"
-       (serialize-configuration
-        config
-        (filter-configuration-fields
-         home-shell-profile-configuration-fields '(profile)))))))
-
-(define (add-profile-extensions config extensions)
-  (home-shell-profile-configuration
-   (inherit config)
-   (profile
-    (append (home-shell-profile-configuration-profile config)
-            extensions))))
-
-(define home-shell-profile-service-type
-  (service-type (name 'home-shell-profile)
-                (extensions
-                 (list (service-extension
-                        home-files-service-type
-                        add-shell-profile-file)))
-                (compose concatenate)
-                (extend add-profile-extensions)
-                (default-value (home-shell-profile-configuration))
-                (description "Create @file{~/.profile}, which is used
-for environment initialization of POSIX compliant login shells.  This
-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)
-  #~(string-append
-     #$@(map
-         (match-lambda
-           ((key . #f)
-            "")
-           ((key . #t)
-            #~(string-append "export " #$key "\n"))
-           ((key . value)
-            #~(string-append "export " #$key "=" #$value "\n")))
-         val)))
-
-
-;;;
-;;; Zsh.
-;;;
-
-(define-configuration home-zsh-configuration
-  (package
-    (package zsh)
-    "The Zsh package to use.")
-  (xdg-flavor?
-   (boolean #t)
-   "Place all the configs to @file{$XDG_CONFIG_HOME/zsh}.  Makes
-@file{~/.zshenv} to set @env{ZDOTDIR} to @file{$XDG_CONFIG_HOME/zsh}.
-Shell startup process will continue with
-@file{$XDG_CONFIG_HOME/zsh/.zshenv}.")
-  (environment-variables
-   (alist '())
-   "Association list of environment variables to set for the Zsh session."
-   serialize-posix-env-vars)
-  (zshenv
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.zshenv}.
-Used for setting user's shell environment variables.  Must not contain
-commands assuming the presence of tty or producing output.  Will be
-read always.  Will be read before any other file in @env{ZDOTDIR}.")
-  (zprofile
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.zprofile}.
-Used for executing user's commands at start of login shell (In most
-cases the shell started on tty just after login).  Will be read before
-@file{.zlogin}.")
-  (zshrc
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.zshrc}.
-Used for executing user's commands at start of interactive shell (The
-shell for interactive usage started by typing @code{zsh} or by
-terminal app or any other program).")
-  (zlogin
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.zlogin}.
-Used for executing user's commands at the end of starting process of
-login shell.")
-  (zlogout
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.zlogout}.
-Used for executing user's commands at the exit of login shell.  It
-won't be read in some cases (if the shell terminates by exec'ing
-another process for example)."))
-
-(define (zsh-filter-fields field)
-  (filter-configuration-fields home-zsh-configuration-fields (list field)))
-
-(define (zsh-serialize-field config field)
-  (serialize-configuration config (zsh-filter-fields field)))
-
-(define* (zsh-field-not-empty? config field)
-  (let ((file-name (symbol->string field))
-        (field-obj (car (zsh-filter-fields field))))
-    (not (null? ((configuration-field-getter field-obj) config)))))
-
-(define (zsh-file-zshenv config)
-  (mixed-text-file
-   "zshenv"
-   (zsh-serialize-field config 'zshenv)
-   (zsh-serialize-field config 'environment-variables)))
-
-(define (zsh-file-zprofile config)
-  (mixed-text-file
-   "zprofile"
-   "\
-# Setups system and user profiles and related variables
-source /etc/profile
-# Setups home environment profile
-source ~/.profile
-
-# It's only necessary if zsh is a login shell, otherwise profiles will
-# be already sourced by bash
-"
-   (zsh-serialize-field config 'zprofile)))
-
-(define (zsh-file-by-field config field)
-  (match field
-    ('zshenv (zsh-file-zshenv config))
-    ('zprofile (zsh-file-zprofile config))
-    (e (mixed-text-file
-        (symbol->string field)
-        (zsh-serialize-field config field)))))
-
-(define (zsh-get-configuration-files config)
-  `(("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))) '())
-    ,@(if (zsh-field-not-empty? config 'zlogin)
-          `(("zlogin" ,(zsh-file-by-field config 'zlogin))) '())
-    ,@(if (zsh-field-not-empty? config 'zlogout)
-          `(("zlogout" ,(zsh-file-by-field config 'zlogout))) '())))
-
-(define (zsh-home-files config)
-  (define zshenv-auxiliary-file
-    (mixed-text-file
-     "zshenv-auxiliary"
-     "export ZDOTDIR=${XDG_CONFIG_HOME:-$HOME/.config}/zsh\n"
-     "[[ -f $ZDOTDIR/.zshenv ]] && source $ZDOTDIR/.zshenv\n"))
-
-  (if (home-zsh-configuration-xdg-flavor? config)
-      `(("zshenv" ,zshenv-auxiliary-file))
-      (zsh-get-configuration-files config)))
-
-(define (zsh-xdg-configuration-files config)
-  (if (home-zsh-configuration-xdg-flavor? config)
-      (map
-       (lambda (lst)
-         (cons (string-append "zsh/." (car lst))
-               (cdr lst)))
-       (zsh-get-configuration-files config))
-      '()))
-
-(define (add-zsh-packages config)
-  (list (home-zsh-configuration-package config)))
-
-(define-configuration/no-serialization home-zsh-extension
-  (environment-variables
-   (alist '())
-   "Association list of environment variables to set.")
-  (zshrc
-   (text-config '())
-   "List of file-like objects.")
-  (zshenv
-   (text-config '())
-   "List of file-like objects.")
-  (zprofile
-   (text-config '())
-   "List of file-like objects.")
-  (zlogin
-   (text-config '())
-   "List of file-like objects.")
-  (zlogout
-   (text-config '())
-   "List of file-like objects."))
-
-(define (home-zsh-extensions original-config extension-configs)
-  (home-zsh-configuration
-   (inherit original-config)
-   (environment-variables
-    (append (home-zsh-configuration-environment-variables original-config)
-            (append-map
-             home-zsh-extension-environment-variables extension-configs)))
-   (zshrc
-    (append (home-zsh-configuration-zshrc original-config)
-            (append-map
-             home-zsh-extension-zshrc extension-configs)))
-   (zshenv
-    (append (home-zsh-configuration-zshenv original-config)
-            (append-map
-             home-zsh-extension-zshenv extension-configs)))
-   (zprofile
-    (append (home-zsh-configuration-zprofile original-config)
-            (append-map
-             home-zsh-extension-zprofile extension-configs)))
-   (zlogin
-    (append (home-zsh-configuration-zlogin original-config)
-            (append-map
-             home-zsh-extension-zlogin extension-configs)))
-   (zlogout
-    (append (home-zsh-configuration-zlogout original-config)
-            (append-map
-             home-zsh-extension-zlogout extension-configs)))))
-
-(define home-zsh-service-type
-  (service-type (name 'home-zsh)
-                (extensions
-                 (list (service-extension
-                        home-files-service-type
-                        zsh-home-files)
-                       (service-extension
-                        home-xdg-configuration-files-service-type
-                        zsh-xdg-configuration-files)
-                       (service-extension
-                        home-profile-service-type
-                        add-zsh-packages)))
-                (compose identity)
-                (extend home-zsh-extensions)
-                (default-value (home-zsh-configuration))
-                (description "Install and configure Zsh.")))
-
-
-;;;
-;;; Bash.
-;;;
-
-(define (bash-serialize-aliases field-name val)
-  #~(string-append
-     #$@(map
-         (match-lambda
-           ((key . #f)
-            "")
-           ((key . #t)
-            #~(string-append "alias " #$key "\n"))
-           ((key . value)
-            #~(string-append "alias " #$key "=\"" #$value "\"\n")))
-         val)))
-
-(define-configuration home-bash-configuration
-  (package
-   (package bash)
-   "The Bash package to use.")
-  (guix-defaults?
-   (boolean #t)
-   "Add sane defaults like reading @file{/etc/bashrc} and coloring the output of
-@command{ls} to the top of the @file{.bashrc} file.")
-  (environment-variables
-   (alist '())
-   "Association list of environment variables to set for the Bash session.  The
-rules for the @code{home-environment-variables-service-type} apply
-here (@pxref{Essential Home Services}).  The contents of this field will be
-added after the contents of the @code{bash-profile} field."
-   serialize-posix-env-vars)
-  (aliases
-   (alist '())
-   "Association list of aliases to set for the Bash session.  The aliases will be
-defined after the contents of the @code{bashrc} field has been put in the
-@file{.bashrc} file.  The alias will automatically be quoted, so something line
-this:
-
-@lisp
-'((\"ls\" . \"ls -alF\"))
-@end lisp
-
-turns into
-
-@example
-alias ls=\"ls -alF\"
-@end example"
-   bash-serialize-aliases)
-  (bash-profile
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.bash_profile}.
-Used for executing user's commands at start of login shell (In most
-cases the shell started on tty just after login).  @file{.bash_login}
-won't be ever read, because @file{.bash_profile} always present.")
-  (bashrc
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.bashrc}.
-Used for executing user's commands at start of interactive shell (The
-shell for interactive usage started by typing @code{bash} or by
-terminal app or any other program).")
-  (bash-logout
-   (text-config '())
-   "List of file-like objects, which will be added to @file{.bash_logout}.
-Used for executing user's commands at the exit of login shell.  It
-won't be read in some cases (if the shell terminates by exec'ing
-another process for example)."))
-
-;; TODO: Use value from (gnu system shadow)
-(define guix-bashrc
-  "\
-# Bash initialization for interactive non-login shells and
-# for remote shells (info \"(bash) Bash Startup Files\").
-
-# Export 'SHELL' to child processes.  Programs such as 'screen'
-# honor it and otherwise use /bin/sh.
-export SHELL
-
-if [[ $- != *i* ]]
-then
-    # We are being invoked from a non-interactive shell.  If this
-    # is an SSH session (as in \"ssh host command\"), source
-    # /etc/profile so we get PATH and other essential variables.
-    [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
-
-    # Don't do anything else.
-    return
-fi
-
-# Source the system-wide file.
-if [[ -e /etc/bashrc ]]; then
-    source /etc/bashrc
-fi
-
-# Adjust the prompt depending on whether we're in 'guix environment'.
-if [ -n \"$GUIX_ENVIRONMENT\" ]
-then
-    PS1='\\u@\\h \\w [env]\\$ '
-else
-    PS1='\\u@\\h \\w\\$ '
-fi
-alias ls='ls -p --color=auto'
-alias ll='ls -l'
-alias grep='grep --color=auto'\n")
-
-(define (add-bash-configuration config)
-  (define (filter-fields field)
-    (filter-configuration-fields home-bash-configuration-fields
-                                 (list field)))
-
-  (define (serialize-field field)
-    (serialize-configuration
-     config
-     (filter-fields field)))
-
-  (define* (file-if-not-empty field #:optional (extra-content #f))
-    (let ((file-name (symbol->string field))
-          (field-obj (car (filter-fields field))))
-      (if (or extra-content
-              (not (null? ((configuration-field-getter field-obj) config))))
-          `(,(object->snake-case-string file-name)
-            ,(apply mixed-text-file
-                    (object->snake-case-string file-name)
-                    (append (or extra-content '())
-                        (list (serialize-field field)))))
-          '())))
-
-  (filter
-   (compose not null?)
-   `(("bash_profile"
-      ,(mixed-text-file
-        "bash_profile"
-        "\
-# Setups system and user profiles and related variables
-# /etc/profile will be sourced by bash automatically
-# Setups home environment profile
-if [ -f ~/.profile ]; then source ~/.profile; fi
-
-# Honor per-interactive-shell startup file
-if [ -f ~/.bashrc ]; then source ~/.bashrc; fi
-"
-        (serialize-field 'bash-profile)
-        (serialize-field 'environment-variables)))
-
-     ,@(list (file-if-not-empty
-              'bashrc
-              (if (home-bash-configuration-guix-defaults? config)
-                  (list (serialize-field 'aliases) guix-bashrc)
-                  (list (serialize-field 'aliases))))
-             (file-if-not-empty 'bash-logout)))))
-
-(define (add-bash-packages config)
-  (list (home-bash-configuration-package config)))
-
-(define-configuration/no-serialization home-bash-extension
-  (environment-variables
-   (alist '())
-   "Additional environment variables to set.  These will be combined with the
-environment variables from other extensions and the base service to form one
-coherent block of environment variables.")
-  (aliases
-   (alist '())
-   "Additional aliases to set.  These will be combined with the aliases from
-other extensions and the base service.")
-  (bash-profile
-   (text-config '())
-   "Additional text blocks to add to @file{.bash_profile}, which will be combined
-with text blocks from other extensions and the base service.")
-  (bashrc
-   (text-config '())
-   "Additional text blocks to add to @file{.bashrc}, which will be combined
-with text blocks from other extensions and the base service.")
-  (bash-logout
-   (text-config '())
-   "Additional text blocks to add to @file{.bash_logout}, which will be combined
-with text blocks from other extensions and the base service."))
-
-(define (home-bash-extensions original-config 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)
-                (extensions
-                 (list (service-extension
-                        home-files-service-type
-                        add-bash-configuration)
-                       (service-extension
-                        home-profile-service-type
-                        add-bash-packages)))
-                (compose identity)
-                (extend home-bash-extensions)
-                (default-value (home-bash-configuration))
-                (description "Install and configure GNU Bash.")))
-
-
-;;;
-;;; Fish.
-;;;
-
-(define (serialize-fish-aliases field-name val)
-  #~(string-append
-     #$@(map (match-lambda
-               ((key . value)
-                #~(string-append "alias " #$key " \"" #$value "\"\n"))
-               (_ ""))
-             val)))
-
-(define (serialize-fish-abbreviations field-name val)
-  #~(string-append
-     #$@(map (match-lambda
-               ((key . value)
-                #~(string-append "abbr --add " #$key " " #$value "\n"))
-               (_ ""))
-             val)))
-
-(define (serialize-fish-env-vars field-name val)
-  #~(string-append
-     #$@(map (match-lambda
-               ((key . #f)
-                "")
-               ((key . #t)
-                #~(string-append "set " #$key "\n"))
-               ((key . value)
-                #~(string-append "set " #$key " "  #$value "\n")))
-             val)))
-
-(define-configuration home-fish-configuration
-  (package
-    (package fish)
-    "The Fish package to use.")
-  (config
-   (text-config '())
-   "List of file-like objects, which will be added to
-@file{$XDG_CONFIG_HOME/fish/config.fish}.")
-  (environment-variables
-   (alist '())
-   "Association list of environment variables to set in Fish."
-   serialize-fish-env-vars)
-  (aliases
-   (alist '())
-   "Association list of aliases for Fish, both the key and the value
-should be a string.  An alias is just a simple function that wraps a
-command, If you want something more akin to @dfn{aliases} in POSIX
-shells, see the @code{abbreviations} field."
-   serialize-fish-aliases)
-  (abbreviations
-   (alist '())
-   "Association list of abbreviations for Fish.  These are words that,
-when typed in the shell, will automatically expand to the full text."
-   serialize-fish-abbreviations))
-
-(define (fish-files-service config)
-  `(("config/fish/config.fish"
-     ,(mixed-text-file
-       "fish-config.fish"
-       #~(string-append "\
-# if we haven't sourced the login config, do it
-status --is-login; and not set -q __fish_login_config_sourced
-and begin
-
-  set --prepend fish_function_path "
-                        #$fish-foreign-env
-                        "/share/fish/functions
-  fenv source $HOME/.profile
-  set -e fish_function_path[1]
-
-  set -g __fish_login_config_sourced 1
-
-end\n\n")
-       (serialize-configuration
-        config
-        home-fish-configuration-fields)))))
-
-(define (fish-profile-service config)
-  (list (home-fish-configuration-package config)))
-
-(define-configuration/no-serialization home-fish-extension
-  (config
-   (text-config '())
-   "List of file-like objects for extending the Fish initialization file.")
-  (environment-variables
-   (alist '())
-   "Association list of environment variables to set.")
-  (aliases
-   (alist '())
-   "Association list of Fish aliases.")
-  (abbreviations
-   (alist '())
-   "Association list of Fish abbreviations."))
-
-(define (home-fish-extensions original-config extension-configs)
-  (home-fish-configuration
-   (inherit original-config)
-   (config
-    (append (home-fish-configuration-config original-config)
-            (append-map
-             home-fish-extension-config extension-configs)))
-   (environment-variables
-    (append (home-fish-configuration-environment-variables original-config)
-            (append-map
-             home-fish-extension-environment-variables extension-configs)))
-   (aliases
-    (append (home-fish-configuration-aliases original-config)
-            (append-map
-             home-fish-extension-aliases extension-configs)))
-   (abbreviations
-    (append (home-fish-configuration-abbreviations original-config)
-            (append-map
-             home-fish-extension-abbreviations extension-configs)))))
-
-;; TODO: Support for generating completion files
-;; TODO: Support for installing plugins
-(define home-fish-service-type
-  (service-type (name 'home-fish)
-                (extensions
-                 (list (service-extension
-                        home-files-service-type
-                        fish-files-service)
-                       (service-extension
-                        home-profile-service-type
-                        fish-profile-service)))
-                (compose identity)
-                (extend home-fish-extensions)
-                (default-value (home-fish-configuration))
-                (description "\
-Install and configure Fish, the friendly interactive shell.")))
-
-
-(define (generate-home-shell-profile-documentation)
-  (generate-documentation
-   `((home-shell-profile-configuration
-      ,home-shell-profile-configuration-fields))
-   'home-shell-profile-configuration))
-
-(define (generate-home-bash-documentation)
-  (string-append
-   (generate-documentation
-    `((home-bash-configuration
-       ,home-bash-configuration-fields))
-    'home-bash-configuration)
-   "\n\n"
-   (generate-documentation
-    `((home-bash-extension
-       ,home-bash-extension-fields))
-    'home-bash-extension)))
-
-(define (generate-home-zsh-documentation)
-  (generate-documentation
-   `((home-zsh-configuration
-      ,home-zsh-configuration-fields))
-   'home-zsh-configuration))
-
-(define (generate-home-fish-documentation)
-  (string-append
-   (generate-documentation
-    `((home-fish-configuration
-       ,home-fish-configuration-fields))
-    'home-fish-configuration)
-   "\n\n"
-   (generate-documentation
-    `((home-fish-extension
-       ,home-fish-extension-fields))
-    'home-fish-extension)))

gnu/home/services/shepherd.scm

@@ -1,149 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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 shepherd)
-  #:use-module (gnu home services)
-  #:use-module (gnu packages admin)
-  #:use-module (gnu services shepherd)
-  #:use-module (guix sets)
-  #:use-module (guix gexp)
-  #:use-module (guix records)
-  #:use-module (srfi srfi-1)
-  #:export (home-shepherd-service-type
-
-            home-shepherd-configuration
-            home-shepherd-configuration?
-            home-shepherd-configuration-shepherd
-            home-shepherd-configuration-auto-start?
-            home-shepherd-configuration-services)
-  #:re-export (shepherd-service
-               shepherd-service?
-               shepherd-service-documentation
-               shepherd-service-provision
-               shepherd-service-canonical-name
-               shepherd-service-requirement
-               shepherd-service-one-shot?
-               shepherd-service-respawn?
-               shepherd-service-start
-               shepherd-service-stop
-               shepherd-service-auto-start?
-               shepherd-service-modules
-
-               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)) ; package
-  (auto-start? home-shepherd-configuration-auto-start?
-               (default #t))
-  (services home-shepherd-configuration-services
-            (default '())))
-
-(define (home-shepherd-configuration-file services shepherd)
-  "Return the shepherd configuration file for SERVICES.  SHEPHERD is used
-as shepherd package."
-  (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)
-                       (system repl error-handling))
-          (apply
-           register-services
-           (map
-            (lambda (file) (load file))
-            '#$files))
-          (action 'root 'daemonize)
-          (format #t "Starting services...~%")
-          (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))
-         (services (home-shepherd-configuration-services config)))
-    (if (home-shepherd-configuration-auto-start? config)
-        (with-imported-modules '((guix build utils))
-          #~(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))
-         (services (home-shepherd-configuration-services config)))
-    #~(system*
-       #$(file-append shepherd "/bin/herd")
-       "load" "root"
-       #$(home-shepherd-configuration-file services shepherd))))
-
-(define (ensure-shepherd-gexp config)
-  #~(if (file-exists?
-         (string-append
-          (or (getenv "XDG_RUNTIME_DIR")
-              (format #f "/run/user/~a" (getuid)))
-          "/shepherd/socket"))
-        #$(reload-configuration-gexp config)
-        #$(launch-shepherd-gexp 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-activation-service-type
-                        ensure-shepherd-gexp)
-                       (service-extension
-                        home-profile-service-type
-                        (lambda (config)
-                          `(,(home-shepherd-configuration-shepherd config))))))
-                (compose concatenate)
-                (extend
-                 (lambda (config extra-services)
-                   (home-shepherd-configuration
-                    (inherit config)
-                    (services
-                     (append (home-shepherd-configuration-services config)
-                             extra-services)))))
-                (default-value (home-shepherd-configuration))
-                (description "Configure and install userland Shepherd.")))
-
-

gnu/home/services/symlink-manager.scm

@@ -1,232 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; 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 symlink-manager)
-  #:use-module (gnu home services)
-  #:use-module (guix gexp)
-  #:use-module (guix modules)
-  #:export (home-symlink-manager-service-type))
-
-;;; Comment:
-;;;
-;;; symlink-manager cares about xdg configurations and other files: it backs
-;;; up files created by user, removes symlinks and directories created by a
-;;; previous generation, and creates new directories and symlinks to files
-;;; according to the content of directories (created by home-files-service) of
-;;; the current home environment generation.
-;;;
-;;; Code:
-
-(define (update-symlinks-script)
-  (program-file
-   "update-symlinks"
-   (with-imported-modules (source-module-closure
-                           '((guix build utils)
-                             (guix i18n)))
-     #~(begin
-         (use-modules (ice-9 ftw)
-                      (ice-9 match)
-                      (srfi srfi-1)
-                      (guix i18n)
-                      (guix build utils))
-
-         (define home-directory
-           (getenv "HOME"))
-
-         (define xdg-config-home
-           (or (getenv "XDG_CONFIG_HOME")
-               (string-append (getenv "HOME") "/.config")))
-
-         (define backup-directory
-           (string-append home-directory "/" (number->string (current-time))
-                          "-guix-home-legacy-configs-backup"))
-
-         (define (preprocess-file file)
-           "If file is in XDG-CONFIGURATION-FILES-DIRECTORY use
-subdirectory from XDG_CONFIG_HOME to generate a target path."
-           (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 (symlink-to-store? file)
-           (catch 'system-error
-             (lambda ()
-               (store-file-name? (readlink file)))
-             (lambda args
-               (if (= EINVAL (system-error-errno args))
-                   #f
-                   (apply throw args)))))
-
-         (define (backup-file file)
-           (define backup
-             (string-append backup-directory "/" (preprocess-file file)))
-
-           (mkdir-p backup-directory)
-           (format #t (G_ "Backing up ~a...") (target-file file))
-           (mkdir-p (dirname backup))
-           (rename-file (target-file file) backup)
-           (display (G_ " done\n")))
-
-         (define (cleanup-symlinks home-generation)
-           ;; Delete from $HOME files that originate in HOME-GENERATION, the
-           ;; store item containing a home generation.
-           (define config-file-directory
-             ;; Note: Trailing slash is needed because "files" is a symlink.
-             (string-append home-generation "/" #$home-files-directory "/"))
-
-           (define (strip file)
-             (string-drop file
-                          (+ 1 (string-length config-file-directory))))
-
-           (format #t (G_ "Cleaning up symlinks from previous home at ~a.~%")
-                   home-generation)
-           (newline)
-
-           (file-system-fold
-            (const #t)
-            (lambda (file stat _)                 ;leaf
-              (let ((file (target-file (strip 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.
-                  (if (symlink-to-store? file)
-                      (begin
-                        (format #t (G_ "Removing ~a...") file)
-                        (delete-file file)
-                        (display (G_ " done\n")))
-                      (format
-                       #t
-                       (G_ "Skipping ~a (not a symlink to store)... done\n")
-                       file)))))
-
-            (const #t)                            ;down
-            (lambda (directory stat _)            ;up
-              (unless (string=? directory config-file-directory)
-                (let ((directory (target-file (strip directory))))
-                  (catch 'system-error
-                    (lambda ()
-                      (rmdir directory)
-                      (format #t (G_ "Removed ~a.\n") directory))
-                    (lambda args
-                      (let ((errno (system-error-errno args)))
-                        (cond
-                         ((= ENOTEMPTY errno)
-                          (format
-                           #t
-                           (G_ "Skipping ~a (not an empty directory)... done\n")
-                           directory))
-                         ((= ENOTDIR errno) #t)
-                         (else
-                          (apply throw args)))))))))
-            (const #t)                            ;skip
-            (const #t)                            ;error
-            #t                                    ;init
-            config-file-directory
-            lstat)
-
-           (display (G_ "Cleanup finished.\n\n")))
-
-         (define (create-symlinks home-generation)
-           ;; Create in $HOME symlinks for the files in HOME-GENERATION.
-           (define config-file-directory
-             ;; Note: Trailing slash is needed because "files" is a symlink.
-             (string-append home-generation "/" #$home-files-directory "/"))
-
-           (define (strip file)
-             (string-drop file
-                          (+ 1 (string-length config-file-directory))))
-
-           (define (source-file file)
-             (readlink (string-append config-file-directory file)))
-
-           (file-system-fold
-            (const #t)                            ;enter?
-            (lambda (file stat result)            ;leaf
-              (let ((source (source-file (strip file)))
-                    (target (target-file (strip file))))
-                (when (file-exists? target)
-                  (backup-file (strip file)))
-                (format #t (G_ "Symlinking ~a -> ~a...")
-                        target source)
-                (symlink source target)
-                (display (G_ " done\n"))))
-            (lambda (directory stat result)       ;down
-              (unless (string=? directory config-file-directory)
-                (let ((target (target-file (strip directory))))
-                  (when (and (file-exists? target)
-                             (not (file-is-directory? target)))
-                    (backup-file (strip directory)))
-
-                  (catch 'system-error
-                    (lambda ()
-                      (mkdir target))
-                    (lambda args
-                      (let ((errno (system-error-errno args)))
-                        (unless (= EEXIST errno)
-                          (format #t (G_ "failed to create directory ~a: ~s~%")
-                                  target (strerror errno))
-                          (apply throw args))))))))
-            (const #t)                            ;up
-            (const #t)                            ;skip
-            (const #t)                            ;error
-            #t                                    ;init
-            config-file-directory))
-
-         #$%initialize-gettext
-
-         (let* ((home     (string-append home-directory "/.guix-home"))
-                (pivot    (string-append home ".new"))
-                (new-home (getenv "GUIX_NEW_HOME"))
-                (old-home (getenv "GUIX_OLD_HOME")))
-           (when old-home
-             (cleanup-symlinks old-home))
-
-           (create-symlinks new-home)
-
-           (symlink new-home pivot)
-           (rename-file pivot home)
-
-           (display (G_" done\nFinished updating symlinks.\n\n")))))))
-
-(define (update-symlinks-gexp _)
-  #~(primitive-load #$(update-symlinks-script)))
-
-(define home-symlink-manager-service-type
-  (service-type (name 'home-symlink-manager)
-                (extensions
-                 (list
-                  (service-extension
-                   home-activation-service-type
-                   update-symlinks-gexp)))
-                (default-value #f)
-                (description "Provide an @code{update-symlinks}
-script, which creates symlinks to configuration files and directories
-on every activation.  If an existing file would be overwritten by a
-symlink, backs up that file first.")))

gnu/home/services/utils.scm

@@ -1,105 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;;
-;;; 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 utils)
-  #:use-module (ice-9 string-fun)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-
-  #:export (maybe-object->string
-            object->snake-case-string
-            object->camel-case-string
-            list->human-readable-list))
-
-(define (maybe-object->string object)
-  "Like @code{object->string} but don't do anything if OBJECT already is
-a string."
-  (if (string? object)
-      object
-      (object->string object)))
-
-;; Snake case: <https://en.wikipedia.org/wiki/Snake_case>
-(define* (object->snake-case-string object #:optional (style 'lower))
-  "Convert the object OBJECT to the equivalent string in ``snake
-case''.  STYLE can be three `@code{lower}', `@code{upper}', or
-`@code{capitalize}', defaults to `@code{lower}'.
-
-@example
-(object->snake-case-string 'variable-name 'upper)
-@result{} \"VARIABLE_NAME\" @end example"
-  (if (not (member style '(lower upper capitalize)))
-      (error 'invalid-style (format #f "~a is not a valid style" style))
-      (let ((stringified (maybe-object->string object)))
-        (string-replace-substring
-         (cond
-          ((equal? style 'lower) stringified)
-          ((equal? style 'upper) (string-upcase stringified))
-          (else (string-capitalize stringified)))
-         "-" "_"))))
-
-(define* (object->camel-case-string object #:optional (style 'lower))
-  "Convert the object OBJECT to the equivalent string in ``camel case''.
-STYLE can be three `@code{lower}', `@code{upper}', defaults to
-`@code{lower}'.
-
-@example
-(object->camel-case-string 'variable-name 'upper)
-@result{} \"VariableName\"
-@end example"
-  (if (not (member style '(lower upper)))
-      (error 'invalid-style (format #f "~a is not a valid style" style))
-      (let ((stringified (maybe-object->string object)))
-        (cond
-         ((eq? style 'upper)
-          (string-concatenate
-           (map string-capitalize
-                (string-split stringified (cut eqv? <> #\-)))))
-         ((eq? style 'lower)
-          (let ((splitted-string (string-split stringified (cut eqv? <> #\-))))
-            (string-concatenate
-             (cons (first splitted-string)
-                   (map string-capitalize
-                        (cdr splitted-string))))))))))
-
-(define* (list->human-readable-list lst
-                                    #:key
-                                    (cumulative? #f)
-                                    (proc identity))
-  "Turn a list LST into a sequence of terms readable by humans.
-If CUMULATIVE? is @code{#t}, use ``and'', otherwise use ``or'' before
-the last term.
-
-PROC is a procedure to apply to each of the elements of a list before
-turning them into a single human readable string.
-
-@example
-(list->human-readable-list '(1 4 9) #:cumulative? #t #:proc sqrt)
-@result{} \"1, 2, and 3\"
-@end example
-
-yields:"
-  (let* ((word (if cumulative? "and " "or "))
-         (init (append (drop-right lst 1))))
-    (format #f "~a" (string-append
-                     (string-join
-                      (map (compose maybe-object->string proc) init)
-                      ", " 'suffix)
-                     word
-                     (maybe-object->string (proc (last lst)))))))
-

gnu/home/services/xdg.scm

@@ -1,480 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;;
-;;; 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 xdg)
-  #:use-module (gnu services configuration)
-  #:use-module (gnu home services)
-  #:use-module (gnu packages freedesktop)
-  #:use-module (gnu home services utils)
-  #:use-module (guix gexp)
-  #:use-module (guix records)
-  #:use-module (guix i18n)
-  #:use-module (guix diagnostics)
-
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (rnrs enums)
-
-  #:export (home-xdg-base-directories-service-type
-            home-xdg-base-directories-configuration
-            home-xdg-base-directories-configuration?
-
-            home-xdg-user-directories-service-type
-            home-xdg-user-directories-configuration
-            home-xdg-user-directories-configuration?
-
-            xdg-desktop-action
-            xdg-desktop-entry
-            home-xdg-mime-applications-service-type
-            home-xdg-mime-applications-configuration))
-
-;;; Commentary:
-;;
-;; This module contains services related to XDG directories and
-;; applications.
-;;
-;; - XDG base directories
-;; - XDG user directories
-;; - XDG MIME applications
-;;
-;;; Code:
-
-
-;;;
-;;; XDG base directories.
-;;;
-
-(define (serialize-path field-name val) "")
-(define path? string?)
-
-(define-configuration home-xdg-base-directories-configuration
-  (cache-home
-   (path "$HOME/.cache")
-   "Base directory for programs to store user-specific non-essential
-(cached) data.  Files in this directory can be deleted anytime without
-loss of important data.")
-  (config-home
-   (path "$HOME/.config")
-   "Base directory for programs to store configuration files.
-Some programs store here log or state files, but it's not desired,
-this directory should contain static configurations.")
-  (data-home
-   (path "$HOME/.local/share")
-   "Base directory for programs to store architecture independent
-read-only shared data, analogus to @file{/usr/share}, but for user.")
-  (runtime-dir
-   (path "${XDG_RUNTIME_DIR:-/run/user/$UID}")
-   "Base directory for programs to store user-specific runtime files,
-like sockets.")
-  (log-home
-   (path "$HOME/.local/var/log")
-   "Base directory for programs to store log files, analogus to
-@file{/var/log}, but for user.  It is not a part of XDG Base Directory
-Specification, but helps to make implementation of home services more
-consistent.")
-  (state-home
-   (path "$HOME/.local/var/lib")
-   "Base directory for programs to store state files, like databases,
-analogus to @file{/var/lib}, but for user.  It is not a part of XDG
-Base Directory Specification, but helps to make implementation of home
-services more consistent."))
-
-(define (home-xdg-base-directories-environment-variables-service config)
-  (map
-   (lambda (field)
-     (cons (format
-            #f "XDG_~a"
-            (object->snake-case-string (configuration-field-name field) 'upper))
-           ((configuration-field-getter field) config)))
-   home-xdg-base-directories-configuration-fields))
-
-(define (ensure-xdg-base-dirs-on-activation config)
-  #~(map (lambda (xdg-base-dir-variable)
-           ((@@ (guix build utils) mkdir-p)
-            (getenv
-             xdg-base-dir-variable)))
-         '#$(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
-are no extensions use configuration instead."
-  (or (and (not (null? extensions)) (last extensions)) config))
-
-(define home-xdg-base-directories-service-type
-  (service-type (name 'home-xdg-base-directories)
-                (extensions
-                 (list (service-extension
-                        home-environment-variables-service-type
-                        home-xdg-base-directories-environment-variables-service)
-                       (service-extension
-                        home-activation-service-type
-                        ensure-xdg-base-dirs-on-activation)))
-                (default-value (home-xdg-base-directories-configuration))
-                (compose identity)
-                (extend last-extension-or-cfg)
-                (description "Configure XDG base directories.  This
-service introduces two additional variables @env{XDG_STATE_HOME},
-@env{XDG_LOG_HOME}.  They are not a part of XDG specification, at
-least yet, but are convenient to have, it improves the consistency
-between different home services.  The services of this service-type is
-instantiated by default, to provide non-default value, extend the
-service-type (using @code{simple-service} for example).")))
-
-(define (generate-home-xdg-base-directories-documentation)
-  (generate-documentation
-   `((home-xdg-base-directories-configuration
-      ,home-xdg-base-directories-configuration-fields))
-   'home-xdg-base-directories-configuration))
-
-
-;;;
-;;; XDG user directories.
-;;;
-
-(define (serialize-string field-name val)
-  ;; The path has to be quoted
-  (format #f "XDG_~a_DIR=\"~a\"\n"
-          (object->snake-case-string field-name 'upper) val))
-
-(define-configuration home-xdg-user-directories-configuration
-  (desktop
-   (string "$HOME/Desktop")
-   "Default ``desktop'' directory, this is what you see on your
-desktop when using a desktop environment,
-e.g. GNOME (@pxref{XWindow,,,guix.info}).")
-  (documents
-   (string "$HOME/Documents")
-   "Default directory to put documents like PDFs.")
-  (download
-   (string "$HOME/Downloads")
-   "Default directory downloaded files, this is where your Web-broser
-will put downloaded files in.")
-  (music
-   (string "$HOME/Music")
-   "Default directory for audio files.")
-  (pictures
-   (string "$HOME/Pictures")
-   "Default directory for pictures and images.")
-  (publicshare
-   (string "$HOME/Public")
-   "Default directory for shared files, which can be accessed by other
-users on local machine or via network.")
-  (templates
-   (string "$HOME/Templates")
-   "Default directory for templates.  They can be used by graphical
-file manager or other apps for creating new files with some
-pre-populated content.")
-  (videos
-   (string "$HOME/Videos")
-   "Default directory for videos."))
-
-(define (home-xdg-user-directories-files-service config)
-  `(("user-dirs.conf"
-     ,(mixed-text-file
-       "user-dirs.conf"
-       "enabled=False\n"))
-    ("user-dirs.dirs"
-     ,(mixed-text-file
-       "user-dirs.dirs"
-      (serialize-configuration
-       config
-       home-xdg-user-directories-configuration-fields)))))
-
-(define (home-xdg-user-directories-activation-service config)
-  (let ((dirs (map (lambda (field)
-                     ((configuration-field-getter field) config))
-                   home-xdg-user-directories-configuration-fields)))
-    #~(let ((ensure-dir
-             (lambda (path)
-               (mkdir-p
-                ((@@ (ice-9 string-fun) string-replace-substring)
-                 path "$HOME" (getenv "HOME"))))))
-        (display "Creating XDG user directories...")
-        (map ensure-dir '#$dirs)
-        (display " done\n"))))
-
-(define home-xdg-user-directories-service-type
-  (service-type (name 'home-xdg-user-directories)
-                (extensions
-                 (list (service-extension
-                        home-xdg-configuration-files-service-type
-                        home-xdg-user-directories-files-service)
-                       (service-extension
-                        home-activation-service-type
-                        home-xdg-user-directories-activation-service)))
-                (default-value (home-xdg-user-directories-configuration))
-                (description "Configure XDG user directories.  To
-disable a directory, point it to the $HOME.")))
-
-(define (generate-home-xdg-user-directories-documentation)
-  (generate-documentation
-   `((home-xdg-user-directories-configuration
-     ,home-xdg-user-directories-configuration-fields))
-   'home-xdg-user-directories-configuration))
-
-
-;;;
-;;; XDG MIME applications.
-;;;
-
-;; Example config
-;;
-;;  (home-xdg-mime-applications-configuration
-;;   (added '((x-scheme-handler/magnet . torrent.desktop)))
-;;   (default '((inode/directory . file.desktop)))
-;;   (removed '((inode/directory . thunar.desktop)))
-;;   (desktop-entries
-;;    (list (xdg-desktop-entry
-;;           (file "file")
-;;           (name "File manager")
-;;           (type 'application)
-;;           (config
-;;            '((exec . "emacsclient -c -a emacs %u"))))
-;;          (xdg-desktop-entry
-;;           (file "text")
-;;           (name "Text editor")
-;;           (type 'application)
-;;           (config
-;;            '((exec . "emacsclient -c -a emacs %u")))
-;;           (actions
-;;            (list (xdg-desktop-action
-;;                   (action 'create)
-;;                   (name "Create an action")
-;;                   (config
-;;                    '((exec . "echo hi"))))))))))
-
-;; See
-;; <https://specifications.freedesktop.org/shared-mime-info-spec/shared-mime-info-spec-latest.html>
-;; <https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-latest.html>
-
-(define (serialize-alist field-name val)
-  (define (serialize-mimelist-entry key val)
-    (let ((val (cond
-                ((list? val)
-                 (string-join (map maybe-object->string val) ";"))
-                ((or (string? val) (symbol? val))
-                 val)
-                (else (raise (formatted-message
-                              (G_ "\
-The value of an XDG MIME entry must be a list, string or symbol, was given ~a")
-                              val))))))
-      (format #f "~a=~a\n" key val)))
-
-  (define (merge-duplicates alist acc)
-    "Merge values that have the same key.
-
-@example
-(merge-duplicates '((key1 . value1)
-                    (key2 . value2)
-                    (key1 . value3)
-                    (key1 . value4)) '())
-
-@result{} ((key1 . (value4 value3 value1)) (key2 . value2))
-@end example"
-    (cond
-     ((null? alist) acc)
-     (else (let* ((head (first alist))
-                  (tail (cdr alist))
-                  (key (first head))
-                  (value (cdr head))
-                  (duplicate? (assoc key acc))
-                  (ensure-list (lambda (x)
-                                 (if (list? x) x (list x)))))
-             (if duplicate?
-                 ;; XXX: This will change the order of things,
-                 ;; though, it shouldn't be a problem for XDG MIME.
-                 (merge-duplicates
-                  tail
-                  (alist-cons key
-                              (cons value (ensure-list (cdr duplicate?)))
-                              (alist-delete key acc)))
-                 (merge-duplicates tail (cons head acc)))))))
-
-  (string-append (if (equal? field-name 'default)
-                     "\n[Default Applications]\n"
-                     (format #f "\n[~a Associations]\n"
-                             (string-capitalize (symbol->string field-name))))
-                 (generic-serialize-alist string-append
-                                          serialize-mimelist-entry
-                                          (merge-duplicates val '()))))
-
-(define xdg-desktop-types (make-enumeration
-                           '(application
-                             link
-                             directory)))
-
-(define (xdg-desktop-type? type)
-  (unless (enum-set-member? type xdg-desktop-types)
-    (raise (formatted-message
-            (G_ "XDG desktop type must be of of ~a, was given: ~a")
-            (list->human-readable-list (enum-set->list xdg-desktop-types))
-            type))))
-
-;; TODO: Add proper docs for this
-;; XXX: 'define-configuration' require that fields have a default
-;; value.
-(define-record-type* <xdg-desktop-action>
-  xdg-desktop-action make-xdg-desktop-action
-  xdg-desktop-action?
-  (action xdg-desktop-action-action)  ; symbol
-  (name   xdg-desktop-action-name)    ; string
-  (config xdg-desktop-action-config   ; alist
-          (default '())))
-
-(define-record-type* <xdg-desktop-entry>
-  xdg-desktop-entry make-xdg-desktop-entry
-  xdg-desktop-entry?
-  ;; ".desktop" will automatically be added
-  (file    xdg-desktop-entry-file)    ; string
-  (name    xdg-desktop-entry-name)    ; string
-  (type    xdg-desktop-entry-type)    ; xdg-desktop-type
-  (config  xdg-desktop-entry-config   ; alist
-           (default '()))
-  (actions xdg-desktop-entry-actions  ; list of <xdg-desktop-action>
-           (default '())))
-
-(define desktop-entries? (list-of xdg-desktop-entry?))
-(define (serialize-desktop-entries field-name val) "")
-
-(define (serialize-xdg-desktop-entry entry)
-  "Return a tuple of the file name for ENTRY and the serialized
-configuration."
-  (define (format-config key val)
-    (let ((val (cond
-                ((list? val)
-                 (string-join (map maybe-object->string val) ";"))
-                ((boolean? val)
-                 (if val "true" "false"))
-                (else val)))
-          (key (string-capitalize (maybe-object->string key))))
-      (list (if (string-suffix? key "?")
-                (string-drop-right key (- (string-length key) 1))
-                key)
-            "=" val "\n")))
-
-  (define (serialize-alist config)
-    (generic-serialize-alist append format-config 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 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
-   (alist '())
-   "An association list of MIME types and desktop entries which indicate
-that the application should used to open the specified MIME type.  The
-value has to be string, symbol, or list of strings or symbols, this
-applies to the `@code{default}', and `@code{removed}' fields as well.")
-  (default
-    (alist '())
-    "An association list of MIME types and desktop entries which indicate
-that the application should be the default for opening the specified
-MIME type.")
-  (removed
-   (alist '())
-   "An association list of MIME types and desktop entries which indicate
-that the application cannot open the specified MIME type.")
-  (desktop-entries
-   (desktop-entries '())
-   "A list of XDG desktop entries to create.  See
-@code{xdg-desktop-entry}."))
-
-(define (home-xdg-mime-applications-files config)
-  (define (add-xdg-desktop-entry-file entry)
-    (let ((file (first entry))
-          (config (second entry)))
-      (list (format #f "local/share/applications/~a" file)
-          (apply mixed-text-file
-                 (format #f "xdg-desktop-~a-entry" file)
-                 config))))
-  (map (compose add-xdg-desktop-entry-file serialize-xdg-desktop-entry)
-       (home-xdg-mime-applications-configuration-desktop-entries config)))
-
-(define (home-xdg-mime-applications-xdg-files config)
-  `(("mimeapps.list"
-     ,(mixed-text-file
-       "xdg-mime-appplications"
-       (serialize-configuration
-        config
-        home-xdg-mime-applications-configuration-fields)))))
-
-(define (home-xdg-mime-applications-extension old-config extension-configs)
-  (define (extract-fields config)
-    ;; return '(added default removed desktop-entries)
-    (list (home-xdg-mime-applications-configuration-added config)
-          (home-xdg-mime-applications-configuration-default config)
-          (home-xdg-mime-applications-configuration-removed config)
-          (home-xdg-mime-applications-configuration-desktop-entries config)))
-
-  (define (append-configs elem acc)
-    (list (append (first elem) (first acc))
-          (append (second elem) (second acc))
-          (append (third elem) (third acc))
-          (append (fourth elem) (fourth acc))))
-
-  ;; TODO: Implement procedure to check for duplicates without
-  ;; sacrificing performance.
-  ;;
-  ;; Combine all the alists from 'added', 'default' and 'removed'
-  ;; into one big alist.
-  (let ((folded-configs (fold append-configs
-                              (extract-fields old-config)
-                              (map extract-fields extension-configs))))
-    (home-xdg-mime-applications-configuration
-     (added (first folded-configs))
-     (default (second folded-configs))
-     (removed (third folded-configs))
-     (desktop-entries (fourth folded-configs)))))
-
-(define home-xdg-mime-applications-service-type
-  (service-type (name 'home-xdg-mime-applications)
-                (extensions
-                 (list (service-extension
-                        home-files-service-type
-                        home-xdg-mime-applications-files)
-                       (service-extension
-                        home-xdg-configuration-files-service-type
-                        home-xdg-mime-applications-xdg-files)))
-                (compose identity)
-                (extend home-xdg-mime-applications-extension)
-                (default-value (home-xdg-mime-applications-configuration))
-                (description
-                 "Configure XDG MIME applications, and XDG desktop entries.")))

gnu/image.scm

@@ -17,7 +17,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu image)
-  #:use-module (gnu platform)
   #:use-module (guix records)
   #:export (partition
             partition?
@@ -35,15 +34,12 @@
             image?
             image-name
             image-format
-            image-platform
+            image-target
             image-size
             image-operating-system
-            image-partition-table-type
             image-partitions
             image-compression?
             image-volatile-root?
-            image-shared-store?
-            image-shared-network?
             image-substitutable?
 
             image-type
@@ -51,8 +47,7 @@
             image-type-name
             image-type-constructor
 
-            os->image
-            os+platform->image))
+            os->image))
 
 
 ;;;
@@ -83,24 +78,18 @@
   (name               image-name ;symbol
                       (default #f))
   (format             image-format) ;symbol
-  (platform           image-platform ;<platform>
+  (target             image-target
                       (default #f))
   (size               image-size  ;size in bytes as integer
                       (default 'guess))
   (operating-system   image-operating-system  ;<operating-system>
                       (default #f))
-  (partition-table-type image-partition-table-type ; 'mbr or 'gpt
-                      (default 'mbr))
   (partitions         image-partitions ;list of <partition>
                       (default '()))
   (compression?       image-compression? ;boolean
                       (default #t))
   (volatile-root?     image-volatile-root? ;boolean
                       (default #t))
-  (shared-store?      image-shared-store? ;boolean
-                      (default #f))
-  (shared-network?    image-shared-network? ;boolean
-                      (default #f))
   (substitutable?     image-substitutable? ;boolean
                       (default #t)))
 
@@ -123,8 +112,3 @@
 (define* (os->image os #:key type)
   (let ((constructor (image-type-constructor type)))
     (constructor os)))
-
-(define* (os+platform->image os platform #:key type)
-  (image
-   (inherit (os->image os #:type type))
-   (platform platform)))

gnu/installer.scm

@@ -33,7 +33,6 @@
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
-  #:use-module (gnu packages compression)
   #:use-module (gnu packages connman)
   #:use-module (gnu packages cryptsetup)
   #:use-module (gnu packages disk)
@@ -43,10 +42,8 @@
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages iso-codes)
   #:use-module (gnu packages linux)
-  #:use-module (gnu packages nano)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages package-management)
-  #:use-module (gnu packages tls)
   #:use-module (gnu packages xorg)
   #:use-module (gnu system locale)
   #:use-module (ice-9 match)
@@ -333,13 +330,10 @@ selected keymap."
                        btrfs-progs
                        jfsutils ;jfs_mkfs
                        ntfs-3g ;mkfs.ntfs
-                       xfsprogs ;mkfs.xfs
                        kbd ;chvt
+                       guix ;guix system init call
                        util-linux ;mkwap
-                       nano
                        shadow
-                       tar ;dump
-                       gzip ;dump
                        coreutils)))
         (with-output-to-port (%make-void-port "w")
           (lambda ()
@@ -356,8 +350,7 @@ selected keymap."
     ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json-3 guile-git guile-webutils
-                           guix gnutls)
+                           guile-json-3 guile-git guix)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
@@ -368,7 +361,6 @@ selected keymap."
             (use-modules (gnu installer record)
                          (gnu installer keymap)
                          (gnu installer steps)
-                         (gnu installer dump)
                          (gnu installer final)
                          (gnu installer hostname)
                          (gnu installer locale)
@@ -385,8 +377,7 @@ selected keymap."
                          (guix build utils)
                          ((system repl debug)
                           #:select (terminal-width))
-                         (ice-9 match)
-                         (ice-9 textual-ports))
+                         (ice-9 match))
 
             ;; Initialize gettext support so that installers can use
             ;; (guix i18n) module.
@@ -414,56 +405,43 @@ selected keymap."
             ;; verbose.
             (terminal-width 200)
 
-            (define current-installer newt-installer)
-            (define steps (#$steps current-installer))
+            (let* ((current-installer newt-installer)
+                   (steps (#$steps current-installer)))
+              ((installer-init current-installer))
 
-            (dynamic-wind
-              (installer-init current-installer)
-              (lambda ()
-                (parameterize
-                    ((run-command-in-installer
-                      (installer-run-command current-installer)))
-                  (catch #t
-                    (lambda ()
-                      (define results
-                        (run-installer-steps
-                         #:rewind-strategy 'menu
-                         #:menu-proc (installer-menu-page current-installer)
-                         #:steps steps))
+              (catch #t
+                (lambda ()
+                  (define results
+                    (run-installer-steps
+                     #:rewind-strategy 'menu
+                     #:menu-proc (installer-menu-page current-installer)
+                     #:steps steps))
 
-                      (match (result-step results 'final)
-                        ('success
-                         ;; We did it!  Let's reboot!
-                         (sync)
-                         (stop-service 'root))
-                        (_
-                         ;; The installation failed, exit so that it is
-                         ;; restarted by login.
-                         #f)))
-                    (const #f)
-                    (lambda (key . args)
-                      (installer-log-line "crashing due to uncaught exception: ~s ~s"
-                                          key args)
-                      (define dump-dir
-                        (prepare-dump key args #:result %current-result))
-                      (define action
-                        ((installer-exit-error current-installer)
-                         (get-string-all
-                          (open-input-file
-                           (string-append dump-dir "/installer-backtrace")))))
-                      (match action
-                        ('dump
-                         (let* ((dump-files
-                                 ((installer-dump-page current-installer)
-                                  dump-dir))
-                                (dump-archive
-                                 (make-dump dump-dir dump-files)))
-                           ((installer-report-page current-installer)
-                            dump-archive)))
-                        (_ #f))
-                      (exit 1)))))
+                  (match (result-step results 'final)
+                    ('success
+                     ;; We did it!  Let's reboot!
+                     (sync)
+                     (stop-service 'root))
+                    (_
+                     ;; The installation failed, exit so that it is restarted
+                     ;; by login.
+                     #f)))
+                (const #f)
+                (lambda (key . args)
+                  (syslog "crashing due to uncaught exception: ~s ~s~%"
+                          key args)
+                  (let ((error-file "/tmp/last-installer-error"))
+                    (call-with-output-file error-file
+                      (lambda (port)
+                        (display-backtrace (make-stack #t) port)
+                        (print-exception port
+                                         (stack-ref (make-stack #t) 1)
+                                         key args)))
+                    ((installer-exit-error current-installer)
+                     error-file key args))
+                  (primitive-exit 1)))
 
-              (installer-exit current-installer))))))
+              ((installer-exit current-installer)))))))
 
   (program-file
    "installer"

gnu/installer/connman.scm

@@ -287,7 +287,7 @@ list so that each keys of a given technology are gathered in a separate list."
 
 (define (connman-online?)
   (let ((state (connman-state)))
-    (memq state '(ready online))))
+    (eq? state 'online)))
 
 (define (connman-connect-with-auth service password-proc)
   "Connect to the given SERVICE with the password returned by calling

gnu/installer/dump.scm

@@ -1,118 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 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 installer dump)
-  #:use-module (gnu installer utils)
-  #:use-module (guix build utils)
-  #:use-module (srfi srfi-11)
-  #:use-module (ice-9 iconv)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 popen)
-  #:use-module (ice-9 textual-ports)
-  #:use-module (web client)
-  #:use-module (web http)
-  #:use-module (web response)
-  #:use-module (webutils multipart)
-  #:export (prepare-dump
-            make-dump
-            send-dump-report))
-
-;; The installer crash dump type.
-(define %dump-type "installer-dump")
-
-(define (result->list result)
-  "Return the alist for the given RESULT."
-  (hash-map->list (lambda (k v)
-                    (cons k v))
-                  result))
-
-(define* (prepare-dump key args #:key result)
-  "Create a crash dump directory.  KEY and ARGS represent the thrown error.
-RESULT is the installer result hash table.  Returns the created directory path."
-  (define now (localtime (current-time)))
-  (define dump-dir
-    (format #f "/tmp/dump.~a"
-            (strftime "%F.%H.%M.%S" now)))
-  (mkdir-p dump-dir)
-  (with-directory-excursion dump-dir
-    ;; backtrace
-    (call-with-output-file "installer-backtrace"
-      (lambda (port)
-        (display-backtrace (make-stack #t) port)
-        (print-exception port
-                         (stack-ref (make-stack #t) 1)
-                         key args)))
-
-    ;; installer result
-    (call-with-output-file "installer-result"
-      (lambda (port)
-        (write (result->list result) port)))
-
-    ;; syslog
-    (copy-file "/var/log/messages" "syslog")
-
-    ;; dmesg
-    (let ((pipe (open-pipe* OPEN_READ "dmesg")))
-      (call-with-output-file "dmesg"
-        (lambda (port)
-          (dump-port pipe port)
-          (close-pipe pipe)))))
-  dump-dir)
-
-(define* (make-dump dump-dir file-choices)
-  "Create a crash dump archive from DUMP-DIR containing FILE-CHOICES.
-Returns the archive path."
-  (define output (string-append (basename dump-dir) ".tar.gz"))
-  (with-directory-excursion (dirname dump-dir)
-    (apply system* "tar" "-zcf" output
-           (map (lambda (f)
-                  (string-append (basename dump-dir) "/" f))
-                file-choices)))
-  (canonicalize-path (string-append (dirname dump-dir) "/" output)))
-
-(define* (send-dump-report dump
-                           #:key
-                           (url "https://dump.guix.gnu.org"))
-  "Turn the DUMP archive into a multipart body and send it to the Guix crash
-dump server at URL."
-  (define (match-boundary kont)
-    (match-lambda
-      (('boundary . (? string? b))
-       (kont b))
-      (x #f)))
-
-  (define (response->string response)
-    (bytevector->string
-     (read-response-body response)
-     "UTF-8"))
-
-  (let-values (((body boundary)
-                (call-with-input-file dump
-                  (lambda (port)
-                    (format-multipart-body
-                     `((,%dump-type . ,port)))))))
-    (false-if-exception
-     (response->string
-      (http-post
-       (string-append url "/upload")
-       #:keep-alive? #t
-       #:streaming? #t
-       #:headers `((content-type
-                    . (multipart/form-data
-                       (boundary . ,boundary))))
-       #:body body)))))

gnu/installer/final.scm

@@ -85,9 +85,8 @@ USERS."
                              (uid (if root? 0 #f))
                              (home-directory
                               (user-home-directory user))
-                             (password (crypt
-                                        (secret-content (user-password user))
-                                        (salt)))
+                             (password (crypt (user-password user)
+                                              (salt)))
 
                              ;; We need a string here, not a file-like, hence
                              ;; this choice.
@@ -106,6 +105,36 @@ USERS."
   (write-passwd password (string-append etc "/passwd"))
   (write-shadow shadow (string-append etc "/shadow")))
 
+(define* (kill-cow-users cow-path #:key (spare '("udevd")))
+  "Kill all processes that have references to the given COW-PATH in their
+'maps' file.  The process whose names are in SPARE list are spared."
+  (define %not-nul
+    (char-set-complement (char-set #\nul)))
+
+  (let ((pids
+         (filter-map (lambda (pid)
+                       (false-if-exception
+                        (call-with-input-file
+                            (string-append "/proc/" pid "/maps")
+                          (lambda (port)
+                            (and (string-contains (get-string-all port)
+                                                  cow-path)
+                                 (string->number pid))))))
+                     (scandir "/proc" string->number))))
+    (for-each (lambda (pid)
+                ;; cmdline does not always exist.
+                (false-if-exception
+                 (call-with-input-file
+                     (string-append "/proc/" (number->string pid) "/cmdline")
+                   (lambda (port)
+                     (match (string-tokenize (read-string port) %not-nul)
+                       ((argv0 _ ...)
+                        (unless (member (basename argv0) spare)
+                          (syslog "Killing process ~a (~a)~%" pid argv0)
+                          (kill pid SIGKILL)))
+                       (_ #f))))))
+              pids)))
+
 (define (call-with-mnt-container thunk)
   "This is a variant of call-with-container. Run THUNK in a new container
 process, within a separate MNT namespace. The container is not jailed so that
@@ -120,28 +149,6 @@ it can interact with the rest of the system."
     (match (waitpid pid)
       ((_ . status) status))))
 
-(define (install-locale locale)
-  "Install the given LOCALE or the en_US.utf8 locale as a fallback."
-  (let ((supported? (false-if-exception
-                     (setlocale LC_ALL locale))))
-    (if supported?
-        (begin
-          (installer-log-line "install supported locale ~a." locale)
-          (setenv "LC_ALL" locale))
-        (begin
-          ;; If the selected locale is not supported, install a default UTF-8
-          ;; locale. This is required to copy some files with UTF-8
-          ;; characters, in the nss-certs package notably. Set LANGUAGE
-          ;; anyways, to have translated messages if possible.
-          (installer-log-line "~a locale is not supported, installing \
-en_US.utf8 locale instead." locale)
-          (setlocale LC_ALL "en_US.utf8")
-          (setenv "LC_ALL" "en_US.utf8")
-          (setenv "LANGUAGE"
-                  (string-take locale
-                               (or (string-index locale #\_)
-                                   (string-length locale))))))))
-
 (define* (install-system locale #:key (users '()))
   "Create /etc/shadow and /etc/passwd on the installation target for USERS.
 Start COW-STORE service on target directory and launch guix install command in
@@ -192,10 +199,6 @@ or #f.  Return #t on success and #f on failure."
        (lambda ()
          (dynamic-wind
            (lambda ()
-             ;; Install the locale before mounting the cow-store, otherwise
-             ;; the loaded cow-store locale files will prevent umounting.
-             (install-locale locale)
-
              ;; Save the database, so that it can be restored once the
              ;; cow-store is umounted.
              (copy-file database-file saved-database)
@@ -209,9 +212,18 @@ or #f.  Return #t on success and #f on failure."
              (setvbuf (current-output-port) 'none)
              (setvbuf (current-error-port) 'none)
 
-             (setenv "PATH" "/run/current-system/profile/bin/")
-
-             (set! ret (run-command install-command)))
+             ;; If there are any connected clients, assume that we are running
+             ;; installation tests. In that case, dump the standard and error
+             ;; outputs to syslog.
+             (set! ret
+                   (if (not (null? (current-clients)))
+                       (with-output-to-file "/dev/console"
+                         (lambda ()
+                           (with-error-to-file "/dev/console"
+                             (lambda ()
+                               (run-command install-command
+                                            #:locale locale)))))
+                       (run-command install-command #:locale locale))))
            (lambda ()
              ;; Restart guix-daemon so that it does no keep the MNT namespace
              ;; alive.

gnu/installer/keymap.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -79,11 +79,6 @@
   "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
 and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
 Configuration Database, describing possible XKB configurations."
-  (define maybe-empty
-    (match-lambda
-      ((x) x)
-      (#f "")))
-
   (define (model m)
     (sxml-match m
                 [(model
@@ -113,7 +108,7 @@ Configuration Database, describing possible XKB configurations."
                    . ,rest-variant))
                  (x11-keymap-variant
                   (name name)
-                  (description (maybe-empty
+                  (description (car
                                 (assoc-ref rest-variant 'description))))]))
 
   (define (layout l)
@@ -125,9 +120,9 @@ Configuration Database, describing possible XKB configurations."
                   (variantList ,[variant -> v] ...))
                  (x11-keymap-layout
                   (name name)
-                  (synopsis (maybe-empty
+                  (synopsis (car
                              (assoc-ref rest-layout 'shortDescription)))
-                  (description (maybe-empty
+                  (description (car
                                 (assoc-ref rest-layout 'description)))
                   (variants (list v ...)))]
                 [(layout
@@ -136,9 +131,9 @@ Configuration Database, describing possible XKB configurations."
                    . ,rest-layout))
                  (x11-keymap-layout
                   (name name)
-                  (synopsis (maybe-empty
+                  (synopsis (car
                              (assoc-ref rest-layout 'shortDescription)))
-                  (description (maybe-empty
+                  (description (car
                                 (assoc-ref rest-layout 'description)))
                   (variants '()))]))
 

gnu/installer/newt.scm

@@ -19,7 +19,6 @@
 (define-module (gnu installer newt)
   #:use-module (gnu installer record)
   #:use-module (gnu installer utils)
-  #:use-module (gnu installer dump)
   #:use-module (gnu installer newt ethernet)
   #:use-module (gnu installer newt final)
   #:use-module (gnu installer newt parameters)
@@ -40,12 +39,7 @@
   #:use-module (guix config)
   #:use-module (guix discovery)
   #:use-module (guix i18n)
-  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
-  #:use-module (ice-9 ftw)
-  #:use-module (ice-9 match)
   #:use-module (newt)
   #:export (newt-installer))
 
@@ -53,7 +47,7 @@
   (newt-init)
   (clear-screen)
   (set-screen-size!)
-  (installer-log-line "Display is ~ax~a." (screen-columns) (screen-rows))
+  (syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows))
   (push-help-line
    (format #f (G_ "Press <F1> for installation parameters."))))
 
@@ -61,102 +55,25 @@
   (newt-finish)
   (clear-screen))
 
-(define (exit-error error)
+(define (exit-error file key args)
   (newt-set-color COLORSET-ROOT "white" "red")
-  (define action
-    (run-textbox-page
-     #:info-text (G_ "The installer has encountered an unexpected problem. \
-The backtrace is displayed below. You may choose to exit or create a dump \
-archive.")
+  (let ((width (nearest-exact-integer
+                (* (screen-columns) 0.8)))
+        (height (nearest-exact-integer
+                 (* (screen-rows) 0.7))))
+    (run-file-textbox-page
+     #:info-text (format #f (G_ "The installer has encountered an unexpected \
+problem. The backtrace is displayed below. Please report it by email to \
+<~a>.") %guix-bug-report-address)
      #:title (G_ "Unexpected problem")
-     #:content error
-     #:buttons-spec
-     (list
-      (cons (G_ "Dump") (const 'dump))
-      (cons (G_ "Exit") (const 'exit)))))
+     #:file file
+     #:exit-button? #f
+     #:info-textbox-width width
+     #:file-textbox-width width
+     #:file-textbox-height height))
   (newt-set-color COLORSET-ROOT "white" "blue")
-  action)
-
-(define (report-page dump-archive)
-  (define text
-    (format #f (G_ "The dump archive was created as ~a.  Would you like to \
-send this archive to the Guix servers?") dump-archive))
-  (define title (G_ "Dump archive created"))
-  (when (run-confirmation-page text title)
-    (let* ((uploaded-name (send-dump-report dump-archive))
-           (text (if uploaded-name
-                     (format #f (G_ "The dump was uploaded as ~a.  Please \
-report it by email to ~a.") uploaded-name %guix-bug-report-address)
-                     (G_ "The dump could not be uploaded."))))
-      (run-error-page
-       text
-       (G_ "Dump upload result")))))
-
-(define (dump-page dump-dir)
-  (define files
-    (scandir dump-dir (lambda (x)
-                        (not (or (string=? x ".")
-                                 (string=? x ".."))))))
-  (fold (match-lambda*
-          (((file . enable?) acc)
-           (if enable?
-               (cons file acc)
-               acc)))
-        '()
-        (run-dump-page
-         dump-dir
-         (map (lambda (x)
-                (cons x #f))
-              files))))
-
-(define (newt-run-command . args)
-  (define command-output "")
-  (define (line-accumulator line)
-    (set! command-output
-          (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))
-  (define term-sig (status:term-sig result))
-  (define stop-sig (status:stop-sig result))
-
-  (if (and exit-val (zero? exit-val))
-      #t
-      (let ((info-text
-             (cond
-              (exit-val
-               (format #f (G_ "External command ~s exited with code ~a")
-                       args exit-val))
-              (term-sig
-               (format #f (G_ "External command ~s terminated by signal ~a")
-                       args term-sig))
-              (stop-sig
-               (format #f (G_ "External command ~s stopped by signal ~a")
-                       args stop-sig)))))
-        (run-textbox-page #:title (G_ "External command error")
-                          #:info-text info-text
-                          #:content command-output
-                          #:buttons-spec
-                          (list
-                           (cons "Ignore" (const #t))
-                           (cons "Abort"
-                                 (lambda ()
-                                   (abort-to-prompt 'installer-step 'abort)))
-                           (cons "Report"
-                                 (lambda ()
-                                   (raise
-                                    (condition
-                                     ((@@ (guix build utils)
-                                          &invoke-error)
-                                      (program (car args))
-                                      (arguments (cdr args))
-                                      (exit-status exit-val)
-                                      (term-signal term-sig)
-                                      (stop-signal stop-sig)))))))))))
+  (newt-finish)
+  (clear-screen))
 
 (define (final-page result prev-steps)
   (run-final-page result prev-steps))
@@ -225,7 +142,4 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address)
    (services-page services-page)
    (welcome-page welcome-page)
    (parameters-menu parameters-menu)
-   (parameters-page parameters-page)
-   (dump-page dump-page)
-   (run-command newt-run-command)
-   (report-page report-page)))
+   (parameters-page parameters-page)))

gnu/installer/newt/ethernet.scm

@@ -65,7 +65,9 @@ connection is pending."
      (run-error-page
       (G_ "No ethernet service available, please try again.")
       (G_ "No service"))
-     (abort-to-prompt 'installer-step 'abort))
+     (raise
+      (condition
+       (&installer-step-abort))))
     ((service)
      ;; Only one service is available so return it directly.
      service)
@@ -79,5 +81,7 @@ connection is pending."
       #:button-text (G_ "Exit")
       #:button-callback-procedure
       (lambda _
-        (abort-to-prompt 'installer-step 'abort))
+        (raise
+         (condition
+          (&installer-step-abort))))
       #:listbox-callback-procedure connect-ethernet-service))))

gnu/installer/newt/final.scm

@@ -59,7 +59,9 @@ This will take a few minutes.")
      #:file-textbox-height height
      #:exit-button-callback-procedure
      (lambda ()
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-install-success-page)
   (match (current-clients)
@@ -86,7 +88,9 @@ press the button to reboot.")))
              (G_ "Restart the installer")
              (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))
+       (1 (raise
+           (condition
+            (&installer-step-abort))))
        (2
         ;; Keep going, the installer will be restarted later on.
         #t)))
@@ -105,7 +109,7 @@ a specific step, or restart the installer."))
 (define (run-final-page result prev-steps)
   (define (wait-for-clients)
     (unless (null? (current-clients))
-      (installer-log-line "waiting with clients before starting final step")
+      (syslog "waiting with clients before starting final step~%")
       (send-to-clients '(starting-final-step))
       (match (select (current-clients) '() '())
         (((port _ ...) _ _)
@@ -115,7 +119,7 @@ a specific step, or restart the installer."))
   ;; things such as changing the swap partition label.
   (wait-for-clients)
 
-  (installer-log-line "proceeding with final step")
+  (syslog "proceeding with final step~%")
   (let* ((configuration   (format-configuration prev-steps result))
          (user-partitions (result-step result 'partition))
          (locale          (result-step result 'locale))

gnu/installer/newt/keymap.scm

@@ -59,7 +59,9 @@ different layout at any time from the parameters menu.")))
        ((param) (const #f))
        (else
         (lambda _
-          (abort-to-prompt 'installer-step 'abort)))))))
+          (raise
+           (condition
+            (&installer-step-abort)))))))))
 
 (define (run-variant-page variants variant->text)
   (let ((title (G_ "Variant")))
@@ -72,7 +74,9 @@ different layout at any time from the parameters menu.")))
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (sort-layouts layouts)
   "Sort LAYOUTS list by putting the US layout ahead and return it."

gnu/installer/newt/locale.scm

@@ -43,7 +43,9 @@ installation process and for the installed system.")
      #:button-text (G_ "Exit")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort))))
+       (raise
+        (condition
+         (&installer-step-abort))))))
 
   ;; Immediately install the chosen language so that the territory page that
   ;; comes after (optionally) is displayed in the chosen language.
@@ -61,7 +63,9 @@ installation process and for the installed system.")
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-codeset-page codesets)
   (let ((title (G_ "Locale codeset")))
@@ -74,7 +78,9 @@ installation process and for the installed system.")
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-modifier-page modifiers modifier->text)
   (let ((title (G_ "Locale modifier")))
@@ -88,7 +94,9 @@ symbol.")
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define* (run-locale-page #:key
                           supported-locales
@@ -102,10 +110,11 @@ associating a territory code with a territory name. The formatted locale, under
 glibc format is returned."
 
   (define (break-on-locale-found locales)
-    "Break to the installer step if LOCALES contains exactly one
+    "Raise the &installer-step-break condition if LOCALES contains exactly one
 element."
     (and (= (length locales) 1)
-         (abort-to-prompt 'installer-step 'break)))
+         (raise
+          (condition (&installer-step-break)))))
 
   (define (filter-locales locales result)
     "Filter the list of locale records LOCALES using the RESULT returned by
@@ -209,8 +218,8 @@ glibc locale string and return it."
 
   ;; If run-installer-steps returns locally, it means that the user had to go
   ;; through all steps (language, territory, codeset and modifier) to select a
-  ;; locale. In that case, like if we exited by breaking to the installer
-  ;; step, turn the result into a glibc locale string and return it.
+  ;; locale. In that case, like if we exited by raising &installer-step-break
+  ;; condition, turn the result into a glibc locale string and return it.
   (result->locale-string
    supported-locales
    (run-installer-steps #:steps locale-steps)))

gnu/installer/newt/network.scm

@@ -30,8 +30,6 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
-  #:use-module (web client)
-  #:use-module (web response)
   #:use-module (newt)
   #:export (run-network-page))
 
@@ -65,8 +63,12 @@ Internet and return the selected technology. For now, only technologies with
             (G_ "Exit")
             (G_ "The install process requires Internet access but no \
 network devices were found. Do you want to continue anyway?"))
-       ((1) (abort-to-prompt 'installer-step 'break))
-       ((2) (abort-to-prompt 'installer-step 'abort))))
+       ((1) (raise
+             (condition
+              (&installer-step-break))))
+       ((2) (raise
+             (condition
+              (&installer-step-abort))))))
     ((technology)
      ;; Since there's only one technology available, skip the selection
      ;; screen.
@@ -82,7 +84,9 @@ network devices were found. Do you want to continue anyway?"))
       #:button-text (G_ "Exit")
       #:button-callback-procedure
       (lambda _
-        (abort-to-prompt 'installer-step 'abort))))))
+        (raise
+         (condition
+          (&installer-step-abort))))))))
 
 (define (find-technology-by-type technologies type)
   "Find and return a technology with the given TYPE in TECHNOLOGIES list."
@@ -115,23 +119,8 @@ 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 (ci-available?)
-    (dynamic-wind
-      (lambda ()
-        (sigaction SIGALRM
-          (lambda _ #f))
-        (alarm 3))
-      (lambda ()
-        (false-if-exception
-         (= (response-code
-             (http-request "https://ci.guix.gnu.org"))
-            200)))
-      (lambda ()
-        (alarm 0))))
-
   (define (online?)
-    (or (and (connman-online?)
-             (ci-available?))
+    (or (connman-online?)
         (file-exists? "/tmp/installer-assume-online")))
 
   (let* ((full-value 5))
@@ -148,9 +137,11 @@ FULL-VALUE tentatives, spaced by 1 second."
     (unless (online?)
       (run-error-page
        (G_ "The selected network does not provide access to the \
-Internet and the Guix substitute server, please try again.")
+Internet, please try again.")
        (G_ "Connection error"))
-      (abort-to-prompt 'installer-step 'abort))))
+      (raise
+       (condition
+        (&installer-step-abort))))))
 
 (define (run-network-page)
   "Run a page to allow the user to configure connman so that it can access the

gnu/installer/newt/page.scm

@@ -22,7 +22,6 @@
   #:use-module (gnu installer steps)
   #:use-module (gnu installer utils)
   #:use-module (gnu installer newt utils)
-  #:use-module (guix build utils)
   #:use-module (guix i18n)
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 match)
@@ -44,10 +43,6 @@
             run-scale-page
             run-checkbox-tree-page
             run-file-textbox-page
-            %ok-button
-            %exit-button
-            run-textbox-page
-            run-dump-page
 
             run-form-with-clients))
 
@@ -98,9 +93,9 @@ disconnect.
 Like 'run-form', return two values: the exit reason, and an \"argument\"."
   (define* (discard-client! port #:optional errno)
     (if errno
-        (installer-log-line "removing client ~d due to ~s"
+        (syslog "removing client ~d due to ~s~%"
                 (fileno port) (strerror errno))
-        (installer-log-line "removing client ~d due to EOF"
+        (syslog "removing client ~d due to EOF~%"
                 (fileno port)))
 
     ;; XXX: Watch out!  There's no 'form-unwatch-fd' procedure in Newt so we
@@ -129,7 +124,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
   (send-to-clients exp)
 
   (let loop ()
-    (installer-log-line "running form ~s (~s) with ~d clients"
+    (syslog "running form ~s (~s) with ~d clients~%"
             form title (length (current-clients)))
 
     ;; Call 'watch-clients!' within the loop because there might be new
@@ -151,7 +146,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
                        (discard-client! port)
                        (loop))
                       (obj
-                       (installer-log-line "form ~s (~s): client ~d replied ~s"
+                       (syslog "form ~s (~s): client ~d replied ~s~%"
                                form title (fileno port) obj)
                        (values 'exit-fd-ready obj))))
                   (lambda args
@@ -161,9 +156,8 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
                 ;; Accept a new client and send it EXP.
                 (match (accept port)
                   ((client . _)
-                   (installer-log-line
-                    "accepting new client ~d while on form ~s"
-                    (fileno client) form)
+                   (syslog "accepting new client ~d while on form ~s~%"
+                           (fileno client) form)
                    (catch 'system-error
                      (lambda ()
                        (write exp client)
@@ -492,7 +486,7 @@ the current listbox item has to be selected by key."
                         (string=? str (listbox-item->text item))))
                      keys)
           ((key . item) item)
-          (#f (abort-to-prompt 'installer-step 'abort))))
+          (#f (raise (condition (&installer-step-abort))))))
 
       ;; On every listbox element change, check if we need to skip it. If yes,
       ;; depending on the 'last-listbox-key', jump forward or backward. If no,
@@ -694,7 +688,7 @@ ITEMS when 'Ok' is pressed."
                         (string=? str (item->text item))))
                      keys)
           ((key . item) item)
-          (#f (abort-to-prompt 'installer-step 'abort))))
+          (#f (raise (condition (&installer-step-abort))))))
 
       (add-form-to-grid grid form #t)
       (make-wrapped-grid-window grid title)
@@ -732,7 +726,8 @@ ITEMS when 'Ok' is pressed."
   (newt-suspend)
   ;; Use Nano because it syntax-highlights Scheme by default.
   ;; TODO: Add a menu to choose an editor?
-  (invoke "nano" file)
+  (run-command (list "/run/current-system/profile/bin/nano" file)
+               #:locale locale)
   (newt-resume))
 
 (define* (run-file-textbox-page #:key
@@ -816,151 +811,6 @@ ITEMS when 'Ok' is pressed."
               (destroy-form-and-pop form))))
 
         (if (and (eq? exit-reason 'exit-component)
-                 edit-button
                  (components=? argument edit-button))
             (loop)                                ;recurse in tail position
             result)))))
-
-(define %ok-button
-  (cons (G_ "Ok")  (lambda () #t)))
-
-(define %exit-button
-  (cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort))))
-
-(define %default-buttons
-  (list %ok-button %exit-button))
-
-(define (make-newt-buttons buttons-spec)
-  (map
-   (match-lambda ((title . proc)
-                  (cons (make-button -1 -1 title) proc)))
-   buttons-spec))
-
-(define* (run-textbox-page #:key
-                           title
-                           info-text
-                           content
-                           (buttons-spec %default-buttons))
-  "Run a page to display INFO-TEXT followed by CONTENT to the user, who has to
-choose an action among the buttons specified by BUTTONS-SPEC.
-
-BUTTONS-SPEC is an association list with button labels as keys, and callback
-procedures as values.
-
-This procedure returns the result of the callback procedure of the button
-chosen by the user."
-  (define info-textbox
-    (make-reflowed-textbox -1 -1 info-text
-                           50
-                           #:flags FLAG-BORDER))
-  (define content-textbox
-    (make-textbox -1 -1
-                  50
-                  30
-                  (logior FLAG-SCROLL FLAG-BORDER)))
-  (define buttons
-    (make-newt-buttons buttons-spec))
-  (define grid
-    (vertically-stacked-grid
-     GRID-ELEMENT-COMPONENT info-textbox
-     GRID-ELEMENT-COMPONENT content-textbox
-     GRID-ELEMENT-SUBGRID
-     (apply
-      horizontal-stacked-grid
-      (append-map (match-lambda ((button . proc)
-                                 (list GRID-ELEMENT-COMPONENT button)))
-                  buttons))))
-  (define form (make-form #:flags FLAG-NOF12))
-  (add-form-to-grid grid form #t)
-  (make-wrapped-grid-window grid title)
-  (set-textbox-text content-textbox
-                    (receive (_w _h text)
-                        (reflow-text content
-                                     50
-                                     0 0)
-                      text))
-
-  (receive (exit-reason argument)
-      (run-form-with-clients form
-                             `(contents-dialog (title ,title)
-                                               (text ,info-text)
-                                               (content ,content)))
-    (destroy-form-and-pop form)
-    (match exit-reason
-      ('exit-component
-       (let ((proc (assq-ref buttons argument)))
-         (if proc
-             (proc)
-             (raise
-              (condition
-               (&serious)
-               (&message
-                (message (format #f "Unable to find corresponding PROC for \
-component ~a." argument))))))))
-      ;; TODO
-      ('exit-fd-ready
-       (raise (condition (&serious)))))))
-
-(define* (run-dump-page base-dir file-choices)
-  (define info-textbox
-    (make-reflowed-textbox -1 -1 "Please select files you wish to include in \
-the dump."
-                           50
-                           #:flags FLAG-BORDER))
-  (define components
-    (map (match-lambda ((file . enabled)
-                        (list
-                         (make-compact-button -1 -1 "Edit")
-                         (make-checkbox -1 -1 file (if enabled #\x #\ ) " x")
-                         file)))
-         file-choices))
-
-  (define sub-grid (make-grid 2 (length components)))
-
-  (for-each
-   (match-lambda* (((button checkbox _) index)
-                   (set-grid-field sub-grid 0 index
-                                   GRID-ELEMENT-COMPONENT checkbox
-                                   #:anchor ANCHOR-LEFT)
-                   (set-grid-field sub-grid 1 index
-                                   GRID-ELEMENT-COMPONENT button
-                                   #:anchor ANCHOR-LEFT)))
-   components (iota (length components)))
-
-  (define grid
-    (vertically-stacked-grid
-     GRID-ELEMENT-COMPONENT info-textbox
-     GRID-ELEMENT-SUBGRID sub-grid
-     GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create")))
-
-  (define form (make-form #:flags FLAG-NOF12))
-
-  (add-form-to-grid grid form #t)
-  (make-wrapped-grid-window grid "Installer dump")
-
-  (define prompt-tag (make-prompt-tag))
-
-  (let loop ()
-    (call-with-prompt prompt-tag
-      (lambda ()
-        (receive (exit-reason argument)
-            (run-form-with-clients form
-                                   `(dump-page))
-          (match exit-reason
-            ('exit-component
-             (let ((result
-                    (map (match-lambda
-                           ((edit checkbox filename)
-                            (if (components=? edit argument)
-                                (abort-to-prompt prompt-tag filename)
-                                (cons filename (eq? #\x
-                                                    (checkbox-value checkbox))))))
-                         components)))
-               (destroy-form-and-pop form)
-               result))
-            ;; TODO
-            ('exit-fd-ready
-             (raise (condition (&serious)))))))
-      (lambda (k file)
-        (edit-file (string-append base-dir "/" file))
-        (loop)))))

gnu/installer/newt/partition.scm

@@ -36,8 +36,10 @@
   #:export (run-partitioning-page))
 
 (define (button-exit-action)
-  "Abort the installer step."
-  (abort-to-prompt 'installer-step 'abort))
+  "Raise the &installer-step-abort condition."
+  (raise
+   (condition
+    (&installer-step-abort))))
 
 (define (run-scheme-page)
   "Run a page asking the user for a partitioning scheme."
@@ -81,8 +83,7 @@ DEVICES list."
          devices))
 
   (let* ((result (run-listbox-selection-page
-                  #:info-text (G_ "Please select a \
-disk.  The installation device as well as the small devices are filtered.")
+                  #:info-text (G_ "Please select a disk.")
                   #:title (G_ "Disk")
                   #:listbox-items (device-items)
                   #:listbox-item->text cdr
@@ -130,11 +131,7 @@ Be careful, all data on the disk will be lost.")
   (run-listbox-selection-page
    #:info-text (G_ "Please select the file-system type for this partition.")
    #:title (G_ "File-system type")
-   #:listbox-items '(btrfs ext4 jfs xfs
-                           swap
-                           ;; These lack basic Unix features.  Their only use
-                           ;; on GNU is for interoperation, e.g., with UEFI.
-                           fat32 fat16 ntfs)
+   #:listbox-items '(ext4 btrfs fat16 fat32 jfs ntfs swap)
    #:listbox-item->text user-fs-type-name
    #:sort-listbox-items? #f
    #:button-text (G_ "Exit")
@@ -646,10 +643,8 @@ edit it."
              default-result))))
        ((partition? item)
         (if (freespace-partition? item)
-            (begin
-              (run-error-page (G_ "You cannot delete a free space area.")
-                              (G_ "Delete partition"))
-              default-result)
+            (run-error-page (G_ "You cannot delete a free space area.")
+                            (G_ "Delete partition"))
             (let* ((disk (partition-disk item))
                    (number-str (partition-print-number item))
                    (info-text
@@ -714,13 +709,6 @@ by pressing the Exit button.~%~%")))
                        (run-error-page
                         (G_ "No root mount point found.")
                         (G_ "Missing mount point"))
-                       #f)
-                      ((cannot-read-uuid? c)
-                       (run-error-page
-                        (format #f (G_ "Cannot read the ~a partition UUID.\
- You may need to format it.")
-                                (cannot-read-uuid-partition c))
-                        (G_ "Wrong partition format"))
                        #f))
                  (check-user-partitions user-partitions))))
           (if user-partitions-ok?
@@ -791,17 +779,16 @@ by pressing the Exit button.~%~%")))
            result-user-partitions)))))
 
   (init-parted)
-  (let* ((eligible-devices (eligible-devices))
-         (user-partitions (run-page eligible-devices))
+  (let* ((non-install-devices (non-install-devices))
+         (user-partitions (run-page non-install-devices))
          (user-partitions-with-pass (prompt-luks-passwords
                                      user-partitions))
          (form (draw-formatting-page user-partitions)))
     ;; Make sure the disks are not in use before proceeding to formatting.
-    (free-parted eligible-devices)
+    (free-parted non-install-devices)
     (format-user-partitions user-partitions-with-pass)
-    (installer-log-line "formatted ~a user partitions"
+    (syslog "formatted ~a user partitions~%"
             (length user-partitions-with-pass))
-    (installer-log-line "user-partitions: ~a" user-partitions)
 
     (destroy-form-and-pop form)
     user-partitions))

gnu/installer/newt/services.scm

@@ -3,7 +3,6 @@
 ;;; Copyright © 2019, 2020 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -46,7 +45,9 @@ to choose from them later when you log in.")
      #:checkbox-tree-height 9
      #:exit-button-callback-procedure
      (lambda ()
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-networking-cbt-page)
   "Run a page allowing the user to select networking services."
@@ -63,46 +64,9 @@ system.")
      #:checkbox-tree-height 5
      #:exit-button-callback-procedure
      (lambda ()
-       (abort-to-prompt 'installer-step 'abort)))))
-
-(define (run-printing-services-cbt-page)
-  "Run a page allowing the user to select document services such as CUPS."
-  (let ((items (filter (lambda (service)
-                         (eq? 'document
-                              (system-service-type service)))
-                       %system-services)))
-    (run-checkbox-tree-page
-     #:info-text (G_ "You can now select the CUPS printing service to run on your \
-system.")
-     #:title (G_ "Printing and document services")
-     #:items items
-     #:selection (map system-service-recommended? items)
-     #:item->text (compose G_ system-service-name)
-     #:checkbox-tree-height 9
-     #:exit-button-callback-procedure
-     (lambda ()
-       (abort-to-prompt 'installer-step 'abort)))))
-
-(define (run-console-services-cbt-page)
-  "Run a page to select various system adminstration services for non-graphical
-systems."
-  (let ((items (filter (lambda (service)
-                         (eq? 'administration
-                              (system-service-type service)))
-                       %system-services)))
-    (run-checkbox-tree-page
-      #:title (G_ "Console services")
-      #:info-text (G_ "Select miscellaneous services to run on your \
-non-graphical system.")
-      #:items items
-      #:selection (map system-service-recommended? items)
-      #:item->text (compose G_ system-service-name)
-      #:checkbox-tree-height 5
-      #:exit-button-callback-procedure
-      (lambda ()
-        (raise
-          (condition
-            (&installer-step-abort)))))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-network-management-page)
   "Run a page to select among several network management methods."
@@ -124,7 +88,9 @@ client may be enough for a server.")
      #:button-text (G_ "Exit")
      #:button-callback-procedure
      (lambda _
-       (abort-to-prompt 'installer-step 'abort)))))
+       (raise
+        (condition
+         (&installer-step-abort)))))))
 
 (define (run-services-page)
   (let ((desktop (run-desktop-environments-cbt-page)))
@@ -133,7 +99,5 @@ client may be enough for a server.")
     (append desktop
             (run-networking-cbt-page)
             (if (null? desktop)
-                (cons (run-network-management-page)
-                      (run-console-services-cbt-page))
-                '())
-            (run-printing-services-cbt-page))))
+                (list (run-network-management-page))
+                '()))))

gnu/installer/newt/timezone.scm

@@ -65,7 +65,9 @@ returned."
          #:button-callback-procedure
          (if (null? path)
              (lambda _
-               (abort-to-prompt 'installer-step 'abort))
+               (raise
+                (condition
+                 (&installer-step-abort))))
              (lambda _
                (loop (all-but-last path))))
          #:listbox-callback-procedure

gnu/installer/newt/user.scm

@@ -20,6 +20,7 @@
 
 (define-module (gnu installer newt user)
   #:use-module (gnu installer user)
+  #:use-module ((gnu installer steps) #:select (&installer-step-abort))
   #:use-module (gnu installer newt page)
   #:use-module (gnu installer newt utils)
   #:use-module (gnu installer utils)
@@ -143,7 +144,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
                              (name name)
                              (real-name real-name)
                              (home-directory home-directory)
-                             (password (make-secret password)))
+                             (password password))
                             (run-user-add-page #:name name
                                                #:real-name real-name
                                                #:home-directory
@@ -256,7 +257,9 @@ administrator (\"root\").")
                    (run users))
                  (reverse users))
                 ((components=? argument exit-button)
-                 (abort-to-prompt 'installer-step 'abort))))
+                 (raise
+                  (condition
+                   (&installer-step-abort))))))
               ('exit-fd-ready
                ;; Read the complete user list at once.
                (match argument
@@ -266,7 +269,7 @@ administrator (\"root\").")
                   (map (lambda (name real-name home password)
                          (user (name name) (real-name real-name)
                                (home-directory home)
-                               (password (make-secret password))))
+                               (password password)))
                        names real-names homes passwords))))))
           (lambda ()
             (destroy-form-and-pop form))))))
@@ -274,5 +277,5 @@ administrator (\"root\").")
   ;; Add a "root" user simply to convey the root password.
   (cons (user (name "root")
               (home-directory "/root")
-              (password (make-secret (run-root-password-page))))
+              (password (run-root-password-page)))
         (run '())))

gnu/installer/newt/welcome.scm

@@ -84,7 +84,7 @@ we want this page to occupy all the screen space available."
                       (string=? str (listbox-item->text item))))
                    keys)
         ((key . item) item)
-        (#f (abort-to-prompt 'installer-step 'abort))))
+        (#f (raise (condition (&installer-step-abort))))))
 
     (set-textbox-text logo-textbox (read-all logo))
 

gnu/installer/newt/wifi.scm

@@ -237,7 +237,9 @@ force a wifi scan."
               (run-wifi-scan-page)
               (run-wifi-page))
              ((components=? argument exit-button)
-              (abort-to-prompt 'installer-step 'abort))
+              (raise
+               (condition
+                (&installer-step-abort))))
              ((components=? argument listbox)
               (let ((result (connect-wifi-service listbox service-items)))
                 (unless result

gnu/installer/parted.scm

@@ -24,14 +24,8 @@
   #:use-module (gnu installer newt page)
   #:use-module (gnu system uuid)
   #:use-module ((gnu build file-systems)
-                #:select (canonicalize-device-spec
-                          find-partition-by-label
-                          find-partition-by-uuid
-                          read-partition-uuid
+                #:select (read-partition-uuid
                           read-luks-partition-uuid))
-  #:use-module ((gnu build linux-boot)
-                #:select (linux-command-line
-                          find-long-option))
   #:use-module ((gnu build linux-modules)
                 #:select (missing-modules))
   #:use-module ((gnu system linux-initrd)
@@ -81,7 +75,7 @@
 
             with-delay-device-in-use?
             force-device-sync
-            eligible-devices
+            non-install-devices
             partition-user-type
             user-fs-type-name
             partition-filesystem-user-type
@@ -113,9 +107,6 @@
 
             &no-root-mount-point
             no-root-mount-point?
-            &cannot-read-uuid
-            cannot-read-uuid?
-            cannot-read-uuid-partition
 
             check-user-partitions
             set-user-partitions-file-name
@@ -232,7 +223,6 @@ inferior to MAX-SIZE, #f otherwise."
     ((fat32) "fat32")
     ((jfs)   "jfs")
     ((ntfs)  "ntfs")
-    ((xfs)   "xfs")
     ((swap)  "linux-swap")))
 
 (define (user-fs-type->mount-type fs-type)
@@ -240,11 +230,10 @@ inferior to MAX-SIZE, #f otherwise."
   (case fs-type
     ((ext4)  "ext4")
     ((btrfs) "btrfs")
-    ((fat16) "vfat")
+    ((fat16) "fat")
     ((fat32) "vfat")
     ((jfs)   "jfs")
-    ((ntfs)  "ntfs")
-    ((xfs)   "xfs")))
+    ((ntfs)  "ntfs")))
 
 (define (partition-filesystem-user-type partition)
   "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field
@@ -259,7 +248,6 @@ of <user-partition> record."
             ((string=? name "fat32") 'fat32)
             ((string=? name "jfs") 'jfs)
             ((string=? name "ntfs") 'ntfs)
-            ((string=? name "xfs") 'xfs)
             ((or (string=? name "swsusp")
                  (string=? name "linux-swap(v0)")
                  (string=? name "linux-swap(v1)"))
@@ -343,63 +331,19 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation."
 
 (define (remove-logical-devices)
   "Remove all active logical devices."
-   ((run-command-in-installer) "dmsetup" "remove_all"))
+  (with-null-output-ports
+   (invoke "dmsetup" "remove_all")))
 
-(define (installer-root-partition-path)
-  "Return the root partition path, or #f if it could not be detected."
-  (let* ((cmdline (linux-command-line))
-         (root (find-long-option "root" cmdline)))
-    (and root
-         (or (and (access? root F_OK) root)
-             (find-partition-by-label root)
-             (and=> (uuid root)
-                    find-partition-by-uuid)))))
-
-;; Minimal installation device size.
-(define %min-device-size
-  (* 2 GIBIBYTE-SIZE)) ;2GiB
-
-(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
-    (installer-root-partition-path))
-
-  (define (small-device? device)
-    (let ((length (device-length device))
-          (sector-size (device-sector-size device)))
-      (and (< (* length sector-size) %min-device-size)
-           (installer-log-line "~a is not eligible because it is smaller than \
-~a."
-                   (device-path device)
-                   (unit-format-custom-byte device
-                                            %min-device-size
-                                            UNIT-GIGABYTE)))))
-
-  ;; Read partition table of device and compare each path to the one
-  ;; we're booting from to determine if it is the installation
-  ;; device.
-  (define (installation-device? device)
-    ;; When using CDROM based installation, the root partition path may be the
-    ;; device path.
-    (and (or (string=? the-installer-root-partition-path
-                       (device-path device))
-             (let ((disk (disk-new device)))
-               (and disk
-                    (any (lambda (partition)
-                           (string=? the-installer-root-partition-path
-                                     (partition-get-path partition)))
-                         (disk-partitions disk)))))
-         (installer-log-line "~a is not eligible because it is the \
-installation device."
-                 (device-path device))))
-
-  (remove
-   (lambda (device)
-     (or (installation-device? device)
-         (small-device? device)))
-   (devices)))
+(define (non-install-devices)
+  "Return all the available devices, except the busy one, allegedly the
+install device. DEVICE-IS-BUSY? is a parted call, checking if the device is
+mounted."
+  ;; FIXME: The install image uses an overlayfs so the install device does not
+  ;; appear as mounted and won't be considered as busy.
+  (remove (lambda (device)
+            (let ((file-name (device-path device)))
+              (device-is-busy? device)))
+          (devices)))
 
 
 ;;
@@ -635,14 +579,8 @@ determined by MAX-LENGTH-COLUMN procedure."
 (define (mklabel device type-name)
   "Create a partition table on DEVICE. TYPE-NAME is the type of the partition
 table, \"msdos\" or \"gpt\"."
-  (let* ((type (disk-type-get type-name))
-         (disk (disk-new-fresh device type)))
-    (or disk
-        (raise
-         (condition
-          (&error)
-          (&message (message (format #f "Cannot create partition table of type
-~a on device ~a." type-name (device-path device)))))))))
+  (let ((type (disk-type-get type-name)))
+    (disk-new-fresh device type)))
 
 
 ;;
@@ -824,22 +762,24 @@ cause them to cross."
                    (disk-add-partition disk partition no-constraint)))
               (partition-ok?
                (or partition-constraint-ok? partition-no-contraint-ok?)))
-         (installer-log-line "Creating partition:")
-         (installer-log-line "~/type: ~a" partition-type)
-         (installer-log-line "~/filesystem-type: ~a"
-                             (filesystem-type-name filesystem-type))
-         (installer-log-line "~/start: ~a" start-sector*)
-         (installer-log-line "~/end: ~a" end-sector)
-         (installer-log-line "~/start-range: [~a, ~a]"
-                             (geometry-start start-range)
-                             (geometry-end start-range))
-         (installer-log-line "~/end-range: [~a, ~a]"
-                             (geometry-start end-range)
-                             (geometry-end end-range))
-         (installer-log-line "~/constraint: ~a"
-                             partition-constraint-ok?)
-         (installer-log-line "~/no-constraint: ~a"
-                             partition-no-contraint-ok?)
+         (syslog "Creating partition:
+~/type: ~a
+~/filesystem-type: ~a
+~/start: ~a
+~/end: ~a
+~/start-range: [~a, ~a]
+~/end-range: [~a, ~a]
+~/constraint: ~a
+~/no-constraint: ~a
+"
+                 partition-type
+                 (filesystem-type-name filesystem-type)
+                 start-sector*
+                 end-sector
+                 (geometry-start start-range) (geometry-end start-range)
+                 (geometry-start end-range) (geometry-end end-range)
+                 partition-constraint-ok?
+                 partition-no-contraint-ok?)
          ;; Set the partition name if supported.
          (when (and partition-ok? has-name? name)
            (partition-set-name partition name))
@@ -928,7 +868,7 @@ partition."
                 (format #f "Unable to create partition ~a~%" name)))))))))
 
 (define (force-user-partitions-formatting user-partitions)
-  "Set the NEED-FORMATTING? fields to #t on all <user-partition> records of
+  "Set the NEED-FORMATING? fields to #t on all <user-partition> records of
 USER-PARTITIONS list and return the updated list."
   (map (lambda (p)
          (user-partition
@@ -1066,48 +1006,15 @@ exists."
 (define-condition-type &no-root-mount-point &condition
   no-root-mount-point?)
 
-;; Cannot not read the partition UUID.
-(define-condition-type &cannot-read-uuid &condition
-  cannot-read-uuid?
-  (partition cannot-read-uuid-partition))
-
 (define (check-user-partitions user-partitions)
-  "Check the following statements:
-
-The USER-PARTITIONS list contains one <user-partition> record with a
-mount-point set to '/'.  Raise &no-root-mount-point condition otherwise.
-
-All the USER-PARTITIONS with a mount point and that will not be formatted have
-a valid UUID.  Raise a &cannot-read-uuid condition specifying the faulty
-partition otherwise.
-
-Return #t if all the statements are valid."
-  (define (check-root)
-    (let ((mount-points
-           (map user-partition-mount-point user-partitions)))
-      (or (member "/" mount-points)
-          (raise
-           (condition (&no-root-mount-point))))))
-
-  (define (check-uuid)
-    (let ((mount-partitions
-           (filter user-partition-mount-point user-partitions)))
-      (every
-       (lambda (user-partition)
-         (let ((file-name (user-partition-file-name user-partition))
-               (need-formatting?
-                (user-partition-need-formatting? user-partition)))
-           (or need-formatting?
-               (read-partition-uuid file-name)
-               (raise
-                (condition
-                 (&cannot-read-uuid
-                  (partition file-name)))))))
-       mount-partitions)))
-
-  (and (check-root)
-       (check-uuid)
-       #t))
+  "Return #t if the USER-PARTITIONS lists contains one <user-partition> record
+with a mount-point set to '/', raise &no-root-mount-point condition
+otherwise."
+  (let ((mount-points
+         (map user-partition-mount-point user-partitions)))
+    (or (member "/" mount-points)
+        (raise
+         (condition (&no-root-mount-point))))))
 
 (define (set-user-partitions-file-name user-partitions)
   "Set the partition file-name of <user-partition> records in USER-PARTITIONS
@@ -1120,37 +1027,48 @@ list and return the updated list."
             (file-name file-name))))
        user-partitions))
 
+(define-syntax-rule (with-null-output-ports exp ...)
+  "Evaluate EXP with both the output port and the error port pointing to the
+bit bucket."
+  (with-output-to-port (%make-void-port "w")
+    (lambda ()
+      (with-error-to-port (%make-void-port "w")
+        (lambda () exp ...)))))
+
 (define (create-btrfs-file-system partition)
   "Create a btrfs file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.btrfs" "-f" partition))
+  (with-null-output-ports
+   (invoke "mkfs.btrfs" "-f" partition)))
 
 (define (create-ext4-file-system partition)
   "Create an ext4 file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.ext4" "-F" partition))
+  (with-null-output-ports
+   (invoke "mkfs.ext4" "-F" partition)))
 
 (define (create-fat16-file-system partition)
   "Create a fat16 file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.fat" "-F16" partition))
+  (with-null-output-ports
+   (invoke "mkfs.fat" "-F16" partition)))
 
 (define (create-fat32-file-system partition)
   "Create a fat32 file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.fat" "-F32" partition))
+  (with-null-output-ports
+   (invoke "mkfs.fat" "-F32" partition)))
 
 (define (create-jfs-file-system partition)
   "Create a JFS file-system for PARTITION file-name."
-   ((run-command-in-installer) "jfs_mkfs" "-f" partition))
+  (with-null-output-ports
+   (invoke "jfs_mkfs" "-f" partition)))
 
 (define (create-ntfs-file-system partition)
   "Create a JFS file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition))
-
-(define (create-xfs-file-system partition)
-  "Create an XFS file-system for PARTITION file-name."
-   ((run-command-in-installer) "mkfs.xfs" "-f" partition))
+  (with-null-output-ports
+   (invoke "mkfs.ntfs" "-F" "-f" partition)))
 
 (define (create-swap-partition partition)
   "Set up swap area on PARTITION file-name."
-   ((run-command-in-installer) "mkswap" "-f" partition))
+  (with-null-output-ports
+   (invoke "mkswap" "-f" partition)))
 
 (define (call-with-luks-key-file password proc)
   "Write PASSWORD in a temporary file and pass it to PROC as argument."
@@ -1177,22 +1095,21 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise."
     (call-with-luks-key-file
      password
      (lambda (key-file)
-       (installer-log-line "formatting and opening LUKS entry ~s at ~s"
+       (syslog "formatting and opening LUKS entry ~s at ~s~%"
                label file-name)
-       ((run-command-in-installer) "cryptsetup" "-q" "luksFormat"
-        file-name key-file)
-       ((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
-        "--key-file" key-file file-name label)))))
+       (system* "cryptsetup" "-q" "luksFormat" file-name key-file)
+       (system* "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)))
-    (installer-log-line "closing LUKS entry ~s" label)
-    ((run-command-in-installer) "cryptsetup" "close" label)))
+    (syslog "closing LUKS entry ~s~%" label)
+    (system* "cryptsetup" "close" label)))
 
 (define (format-user-partitions user-partitions)
   "Format the <user-partition> records in USER-PARTITIONS list with
-NEED-FORMATTING? field set to #t."
+NEED-FORMATING? field set to #t."
   (for-each
    (lambda (user-partition)
      (let* ((need-formatting?
@@ -1229,10 +1146,6 @@ NEED-FORMATTING? field set to #t."
           (and need-formatting?
                (not (eq? type 'extended))
                (create-ntfs-file-system file-name)))
-         ((xfs)
-          (and need-formatting?
-               (not (eq? type 'extended))
-               (create-xfs-file-system file-name)))
          ((swap)
           (create-swap-partition file-name))
          (else
@@ -1269,7 +1182,7 @@ respective mount-points."
                        (file-name
                         (user-partition-upper-file-name user-partition)))
                   (mkdir-p target)
-                  (installer-log-line "mounting ~s on ~s" file-name target)
+                  (syslog "mounting ~s on ~s~%" file-name target)
                   (mount file-name target mount-type)))
               sorted-partitions)))
 
@@ -1285,7 +1198,7 @@ respective mount-points."
                        (target
                         (string-append (%installer-target-dir)
                                        mount-point)))
-                  (installer-log-line "unmounting ~s" target)
+                  (syslog "unmounting ~s~%" target)
                   (umount target)
                   (when crypt-label
                     (luks-close user-partition))))
@@ -1383,9 +1296,9 @@ from (gnu system mapped-devices) and return it."
     `((bootloader-configuration
        ,@(if (efi-installation?)
              `((bootloader grub-efi-bootloader)
-               (targets (list ,(default-esp-mount-point))))
+               (target ,(default-esp-mount-point)))
              `((bootloader grub-bootloader)
-               (targets (list ,root-partition-disk))))
+               (target ,root-partition-disk)))
 
        ;; XXX: Assume we defined the 'keyboard-layout' field of
        ;; <operating-system> right above.
@@ -1429,11 +1342,9 @@ USER-PARTITIONS, or return nothing."
             (let* ((uuids (map (lambda (file)
                                  (uuid->string (read-partition-uuid file)))
                                swap-devices)))
-              `((swap-devices
-                 (list ,@(map (lambda (uuid)
-                                `(swap-space
-                                  (target (uuid ,uuid))))
-                              uuids))))))
+              `((swap-devices (list ,@(map (lambda (uuid)
+                                             `(uuid ,uuid))
+                                           uuids))))))
       ,@(if (null? encrypted-partitions)
             '()
             `((mapped-devices
@@ -1476,6 +1387,6 @@ the devices not to be used before returning."
                       (error
                        (format #f (G_ "Device ~a is still in use.")
                                file-name))
-                      (installer-log-line "Syncing ~a took ~a seconds."
+                      (syslog "Syncing ~a took ~a seconds.~%"
                               file-name (time-second time)))))
               device-file-names)))

gnu/installer/record.scm

@@ -41,10 +41,7 @@
             installer-services-page
             installer-welcome-page
             installer-parameters-menu
-            installer-parameters-page
-            installer-dump-page
-            installer-run-command
-            installer-report-page))
+            installer-parameters-page))
 
 
 ;;;
@@ -64,7 +61,7 @@
   (init installer-init)
   ;; procedure: void -> void
   (exit installer-exit)
-  ;; procedure (key arguments) -> (action)
+  ;; procedure (key arguments) -> void
   (exit-error installer-exit-error)
   ;; procedure void -> void
   (final-page installer-final-page)
@@ -94,10 +91,4 @@
   ;; procedure (menu-proc) -> void
   (parameters-menu installer-parameters-menu)
   ;; procedure (keyboard-layout-selection) -> void
-  (parameters-page installer-parameters-page)
-  ;; procedure (dump) -> void
-  (dump-page installer-dump-page)
-  ;; procedure command -> bool
-  (run-command installer-run-command)
-  ;; procedure (report) -> void
-  (report-page installer-report-page))
+  (parameters-page installer-parameters-page))

gnu/installer/services.scm

@@ -2,8 +2,6 @@
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,6 +29,7 @@
             system-service-packages
 
             desktop-system-service?
+            networking-system-service?
 
             %system-services
             system-services->configuration))
@@ -39,7 +38,7 @@
   system-service make-system-service
   system-service?
   (name            system-service-name)           ;string
-  (type            system-service-type)           ;'desktop|'networking|…
+  (type            system-service-type)           ;'desktop | 'networking
   (recommended?    system-service-recommended?    ;Boolean
                    (default #f))
   (snippet         system-service-snippet         ;list of sexps
@@ -47,6 +46,7 @@
   (packages        system-service-packages        ;list of sexps
                    (default '())))
 
+;; This is the list of desktop environments supported as services.
 (define %system-services
   (let-syntax ((desktop-environment (syntax-rules ()
                                       ((_ fields ...)
@@ -56,7 +56,6 @@
                (G_ (syntax-rules ()               ;for xgettext
                      ((_ str) str))))
     (list
-     ;; This is the list of desktop environments supported as services.
      (desktop-environment
       (name "GNOME")
       (snippet '((service gnome-desktop-service-type))))
@@ -105,17 +104,6 @@
       (packages '((specification->package "nss-certs")))
       (recommended? #t))
 
-     ;; Miscellaneous system administration services.
-     (system-service
-       (name (G_ "Network time service (NTP), to set the clock automatically"))
-       (type 'administration)
-       (recommended? #t)
-       (snippet '((service ntp-service-type))))
-     (system-service
-       (name (G_ "GPM mouse daemon, to use the mouse on the console"))
-       (type 'administration)
-       (snippet '((service gpm-service-type))))
-
      ;; Network connectivity management.
      (system-service
       (name (G_ "NetworkManager network connection manager"))
@@ -130,18 +118,16 @@
      (system-service
       (name (G_ "DHCP client (dynamic IP address assignment)"))
       (type 'network-management)
-      (snippet '((service dhcp-client-service-type))))
-
-     ;; Dealing with documents.
-     (system-service
-      (name (G_ "CUPS printing system (no Web interface by default)"))
-      (type 'document)
-      (snippet '((service cups-service-type)))))))
+      (snippet '((service dhcp-client-service-type)))))))
 
 (define (desktop-system-service? service)
   "Return true if SERVICE is a desktop environment service."
   (eq? 'desktop (system-service-type service)))
 
+(define (networking-system-service? service)
+  "Return true if SERVICE is a desktop environment service."
+  (eq? 'networking (system-service-type service)))
+
 (define (system-services->configuration services)
   "Return the configuration field for SERVICES."
   (let* ((snippets (append-map system-service-snippet services))

gnu/installer/steps.scm

@@ -28,7 +28,13 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (rnrs io ports)
-  #:export (<installer-step>
+  #:export (&installer-step-abort
+            installer-step-abort?
+
+            &installer-step-break
+            installer-step-break?
+
+            <installer-step>
             installer-step
             make-installer-step
             installer-step?
@@ -46,13 +52,15 @@
             %installer-configuration-file
             %installer-target-dir
             format-configuration
-            configuration->file
+            configuration->file))
 
-            %current-result))
+;; This condition may be raised to abort the current step.
+(define-condition-type &installer-step-abort &condition
+  installer-step-abort?)
 
-;; Hash table storing the step results. Use it only for logging and debug
-;; purposes.
-(define %current-result (make-hash-table))
+;; This condition may be raised to break out from the steps execution.
+(define-condition-type &installer-step-break &condition
+  installer-step-break?)
 
 ;; An installer-step record is basically an id associated to a compute
 ;; procedure. The COMPUTE procedure takes exactly one argument, an association
@@ -80,10 +88,8 @@
                               (rewind-strategy 'previous)
                               (menu-proc (const #f)))
   "Run the COMPUTE procedure of all <installer-step> records in STEPS
-sequentially, inside a the 'installer-step prompt.  When aborted to with a
-parameter of 'abort, fallback to a previous install-step, accordingly to the
-specified REWIND-STRATEGY.  When aborted to with a parameter of 'break, stop
-the computation and return the accumalated result so far.
+sequentially.  If the &installer-step-abort condition is raised, fallback to a
+previous install-step, accordingly to the specified REWIND-STRATEGY.
 
 REWIND-STRATEGY possible values are 'previous, 'menu and 'start.  If 'previous
 is selected, the execution will resume at the previous installer-step. If
@@ -100,7 +106,10 @@ the form:
 where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
 result of the associated COMPUTE procedure. This result association list is
 passed as argument of every COMPUTE procedure. It is finally returned when the
-computation is over."
+computation is over.
+
+If the &installer-step-break condition is raised, stop the computation and
+return the accumalated result so far."
   (define (pop-result list)
     (cdr list))
 
@@ -134,61 +143,62 @@ computation is over."
     (match todo-steps
       (() (reverse result))
       ((step . rest-steps)
-       (call-with-prompt 'installer-step
-         (lambda ()
-           (installer-log-line "running step '~a'" (installer-step-id step))
-           (let* ((id (installer-step-id step))
-                  (compute (installer-step-compute step))
-                  (res (compute result done-steps)))
-             (hash-set! %current-result id res)
-             (run (alist-cons id res result)
-                  #:todo-steps rest-steps
-                  #:done-steps (append done-steps (list step)))))
-         (lambda (k action)
-           (match action
-             ('abort
-              (case rewind-strategy
-                ((previous)
-                 (match done-steps
-                   (()
-                    ;; We cannot go previous the first step. Abort again to
-                    ;; 'installer-step prompt. It might be useful in the case
-                    ;; of nested run-installer-steps.
-                    (abort-to-prompt 'installer-step action))
-                   ((prev-done ... last-done)
-                    (run (pop-result result)
-                         #:todo-steps (cons last-done todo-steps)
-                         #:done-steps prev-done))))
-                ((menu)
-                 (let ((goto-step (menu-proc
-                                   (append done-steps (list step)))))
-                   (if (eq? goto-step step)
-                       (run result
-                            #:todo-steps todo-steps
-                            #:done-steps done-steps)
-                       (skip-to-step goto-step result
-                                     #:todo-steps todo-steps
-                                     #:done-steps done-steps))))
-                ((start)
-                 (if (null? done-steps)
-                     ;; Same as above, it makes no sense to jump to start
-                     ;; when we are at the first installer-step. Abort to
-                     ;; 'installer-step prompt again.
-                     (abort-to-prompt 'installer-step action)
-                     (run '()
-                          #:todo-steps steps
-                          #:done-steps '())))))
-             ('break
-              (reverse result))))))))
+       (guard (c ((installer-step-abort? c)
+                  (case rewind-strategy
+                    ((previous)
+                     (match done-steps
+                       (()
+                        ;; We cannot go previous the first step. So re-raise
+                        ;; the exception. It might be useful in the case of
+                        ;; nested run-installer-steps. Abort to 'raise-above
+                        ;; prompt to prevent the condition from being catched
+                        ;; by one of the previously installed guard.
+                        (abort-to-prompt 'raise-above c))
+                       ((prev-done ... last-done)
+                        (run (pop-result result)
+                             #:todo-steps (cons last-done todo-steps)
+                             #:done-steps prev-done))))
+                    ((menu)
+                     (let ((goto-step (menu-proc
+                                       (append done-steps (list step)))))
+                       (if (eq? goto-step step)
+                           (run result
+                                #:todo-steps todo-steps
+                                #:done-steps done-steps)
+                           (skip-to-step goto-step result
+                                         #:todo-steps todo-steps
+                                         #:done-steps done-steps))))
+                    ((start)
+                     (if (null? done-steps)
+                         ;; Same as above, it makes no sense to jump to start
+                         ;; when we are at the first installer-step. Abort to
+                         ;; 'raise-above prompt to re-raise the condition.
+                         (abort-to-prompt 'raise-above c)
+                         (run '()
+                              #:todo-steps steps
+                              #:done-steps '())))))
+                 ((installer-step-break? c)
+                  (reverse result)))
+         (syslog "running step '~a'~%" (installer-step-id step))
+         (let* ((id (installer-step-id step))
+                (compute (installer-step-compute step))
+                (res (compute result done-steps)))
+           (run (alist-cons id res result)
+                #:todo-steps rest-steps
+                #:done-steps (append done-steps (list step))))))))
 
   ;; Ignore SIGPIPE so that we don't die if a client closes the connection
   ;; prematurely.
   (sigaction SIGPIPE SIG_IGN)
 
   (with-server-socket
-    (run '()
-         #:todo-steps steps
-         #:done-steps '())))
+    (call-with-prompt 'raise-above
+      (lambda ()
+        (run '()
+             #:todo-steps steps
+             #:done-steps '()))
+      (lambda (k condition)
+        (raise condition)))))
 
 (define (find-step-by-id steps id)
   "Find and return the step in STEPS whose id is equal to ID."
@@ -225,7 +235,7 @@ found in RESULTS."
                   '())))
           steps))
         (modules '((use-modules (gnu))
-                   (use-service-modules cups desktop networking ssh xorg))))
+                   (use-service-modules desktop networking ssh xorg))))
     `(,@modules
       ()
       (operating-system ,@configuration))))

gnu/installer/tests.scm

@@ -37,8 +37,7 @@
             enter-host-name+passwords
             choose-services
             choose-partitioning
-            start-installation
-            complete-installation
+            conclude-installation
 
             edit-configuration-file))
 
@@ -220,13 +219,8 @@ ROOT-PASSWORD, and USERS."
                                  (string-contains service "NSS"))))
                           (choose-network-management-tool?
                            (lambda (service)
-                             (string-contains service "DHCP")))
-                          (choose-misc-service?
-                           (lambda (service)
-                             (string-contains service "NTP")))
-                          (choose-other-service? (const #f)))
-
-  "Converse over PORT to choose services."
+                             (string-contains service "DHCP"))))
+  "Converse over PORT to choose networking services."
   (define desktop-environments '())
 
   (converse port
@@ -245,16 +239,7 @@ ROOT-PASSWORD, and USERS."
                      (multiple-choices? #f)
                      (items ,services))
      (null? desktop-environments)
-     (find choose-network-management-tool? services))
-
-    ((checkbox-list (title "Console services") (text _)
-                    (items ,services))
-     (null? desktop-environments)
-     (filter choose-misc-service? services))
-
-    ((checkbox-list (title "Printing and document services") (text _)
-                    (items ,services))
-     (filter choose-other-service? services))))
+     (find choose-network-management-tool? services))))
 
 (define (edit-configuration-file file)
   "Edit FILE, an operating system configuration file generated by the
@@ -296,19 +281,14 @@ instrumented for further testing."
 (define* (choose-partitioning port
                               #:key
                               (encrypted? #t)
-                              (uefi-support? #f)
                               (passphrase "thepassphrase")
                               (edit-configuration-file
                                edit-configuration-file))
   "Converse over PORT to choose the partitioning method.  When ENCRYPTED? is
 true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase.
-
-When UEFI-SUPPORT? is true, assume that we are running the installation tests
-on an UEFI capable machine.
-
 This conversation stops when the user partitions have been formatted, right
 before the installer generates the configuration file and shows it in a dialog
-box. "
+box."
   (converse port
     ((list-selection (title "Partitioning method")
                      (multiple-choices? #f)
@@ -326,15 +306,11 @@ box. "
            disks))
 
     ;; The "Partition table" dialog pops up only if there's not already a
-    ;; partition table and if the system does not support UEFI.
+    ;; partition table.
     ((list-selection (title "Partition table")
                      (multiple-choices? #f)
                      (items _))
-     ;; When UEFI is supported, the partition is forced to GPT by the
-     ;; installer.
-     (not uefi-support?)
      "gpt")
-
     ((list-selection (title "Partition scheme")
                      (multiple-choices? #f)
                      (items (,one-partition _ ...)))
@@ -362,10 +338,10 @@ box. "
      ;; UUIDs before it generates the configuration file.
      (values))))
 
-(define (start-installation port)
-  "Start the installation by checking over PORT that we get the generated
+(define (conclude-installation port)
+  "Conclude the installation by checking over PORT that we get the generated
 configuration file, accepting it and starting the installation, and then
-receiving the pause message once the 'guix system init' process has
+receiving the final messages once the 'guix system init' process has
 completed."
   ;; Assume the previous message received was 'starting-final-step'; here we
   ;; send the reply to that message, which lets the installer continue.
@@ -379,19 +355,8 @@ completed."
                   (file ,configuration-file))
      (edit-configuration-file configuration-file))
     ((pause)                                      ;"Press Enter to continue."
-     (values))))
-
-(define (complete-installation port)
-  "Complete the installation by replying to the installer pause message and
-waiting for the installation-complete message."
-  ;; Assume the previous message received was 'pause'; here we send the reply
-  ;; to that message, which lets the installer continue.
-  (write #t port)
-  (newline port)
-  (force-output port)
-
-  (converse port
-    ((installation-complete)
+     #t)
+    ((installation-complete)                      ;congratulations!
      (values))))
 
 ;;; Local Variables:

gnu/installer/user.scm

@@ -19,14 +19,7 @@
 (define-module (gnu installer user)
   #:use-module (guix records)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu)
-  #:export (<secret>
-            secret?
-            make-secret
-            secret-content
-
-            <user>
+  #:export (<user>
             user
             make-user
             user-name
@@ -37,16 +30,6 @@
 
             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?

gnu/installer/utils.scm

@@ -25,10 +25,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
-  #:use-module (ice-9 control)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -37,17 +34,10 @@
             read-all
             nearest-exact-integer
             read-percentage
-            run-external-command-with-handler
-            run-external-command-with-line-hooks
             run-command
-            run-command-in-installer
 
             syslog-port
-            %syslog-line-hook
-            installer-log-port
-            %installer-log-line-hook
-            %default-installer-line-hooks
-            installer-log-line
+            syslog
             call-with-time
             let/time
 
@@ -84,99 +74,49 @@ number. If no percentage is found, return #f"
     (and result
          (string->number (match:substring result 1)))))
 
-(define* (run-external-command-with-handler handler command)
-  "Run command specified by the list COMMAND in a child 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."
-  (match-let (((input . output) (pipe)))
-    ;; Hack to work around Guile bug 52835
-    (define dup-output (duplicate-port output "w"))
-    ;; Void pipe, but holds the pid for close-pipe.
-    (define dummy-pipe
-      (with-input-from-file "/dev/null"
-        (lambda ()
-          (with-output-to-port output
-            (lambda ()
-              (with-error-to-port dup-output
-                (lambda ()
-                  (apply open-pipe* (cons "" command)))))))))
-    (close-port output)
-    (close-port dup-output)
-    (handler input)
-    (close-port input)
-    (close-pipe dummy-pipe)))
+(define* (run-command command #:key locale)
+  "Run COMMAND, a list of strings, in the given LOCALE.  Return true if
+COMMAND exited successfully, #f otherwise."
+  (define env (environ))
 
-(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.  Returns the integer status
-value of the child process as returned by waitpid."
-  (define (handler input)
-    (and
-     (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))
-                         #t))))
-     (handler input)))
-  (run-external-command-with-handler handler command))
-
-(define* (run-command command)
-  "Run COMMAND, a list of strings.  Return true if COMMAND exited
-successfully, #f otherwise."
   (define (pause)
     (format #t (G_ "Press Enter to continue.~%"))
     (send-to-clients '(pause))
+    (environ env)                               ;restore environment variables
     (match (select (cons (current-input-port) (current-clients))
              '() '())
       (((port _ ...) _ _)
        (read-line port))))
 
-  (installer-log-line "running command ~s" command)
-  (define result (run-external-command-with-line-hooks
-                  (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))
-  (define succeeded?
-    (cond
-     ((and exit-val (not (zero? exit-val)))
-      (installer-log-line "command ~s exited with value ~a"
-                          command exit-val)
-      (format #t (G_ "Command ~s exited with value ~a")
-              command exit-val)
-      #f)
-     (term-sig
-      (installer-log-line "command ~s killed by signal ~a"
-                          command term-sig)
-      (format #t (G_ "Command ~s killed by signal ~a")
-              command term-sig)
-      #f)
-     (stop-sig
-      (installer-log-line "command ~s stopped by signal ~a"
-                          command stop-sig)
-      (format #t (G_ "Command ~s stopped by signal ~a")
-              command stop-sig)
-      #f)
-     (else
-      (installer-log-line "command ~s succeeded" command)
-      (format #t (G_ "Command ~s succeeded") command)
-      #t)))
-  (newline)
-  (pause)
-  succeeded?)
+  (setenv "PATH" "/run/current-system/profile/bin")
 
-(define run-command-in-installer
-  (make-parameter
-   (lambda (. args)
-     (raise
-      (condition
-       (&serious)
-       (&message (message "run-command-in-installer not set")))))))
+  (when locale
+    (let ((supported? (false-if-exception
+                       (setlocale LC_ALL locale))))
+      ;; If LOCALE is not supported, then set LANGUAGE, which might at
+      ;; least give us translated messages.
+      (if supported?
+          (setenv "LC_ALL" locale)
+          (setenv "LANGUAGE"
+                  (string-take locale
+                               (or (string-index locale #\_)
+                                   (string-length locale)))))))
+
+  (guard (c ((invoke-error? c)
+             (newline)
+             (format (current-error-port)
+                     (G_ "Command failed with exit code ~a.~%")
+                     (invoke-error-exit-status c))
+             (syslog "command ~s failed with exit code ~a"
+                     command (invoke-error-exit-status c))
+             (pause)
+             #f))
+    (syslog "running command ~s~%" command)
+    (apply invoke command)
+    (syslog "command ~s succeeded~%" command)
+    (newline)
+    (pause)
+    #t))
 
 
 ;;;
@@ -214,9 +154,6 @@ values."
         (set! port (open-syslog-port)))
       (or port (%make-void-port "w")))))
 
-(define (%syslog-line-hook line)
-  (format (syslog-port) "installer[~d]: ~a~%" (getpid) line))
-
 (define-syntax syslog
   (lambda (s)
     "Like 'format', but write to syslog."
@@ -227,43 +164,6 @@ values."
                                          (syntax->datum #'fmt))))
          #'(format (syslog-port) fmt (getpid) args ...))))))
 
-(define (open-new-log-port)
-  (define now (localtime (time-second (current-time))))
-  (define filename
-    (format #f "/tmp/installer.~a.log"
-            (strftime "%F.%T" now)))
-  (open filename (logior O_RDWR
-                         O_CREAT)))
-
-(define installer-log-port
-  (let ((port #f))
-    (lambda ()
-      "Return an input and output port to the installer log."
-      (unless port
-        (set! port (open-new-log-port)))
-      port)))
-
-(define (%installer-log-line-hook line)
-  (format (installer-log-port) "~a~%" line))
-
-(define (%display-line-hook line)
-  (display line)
-  (newline))
-
-(define %default-installer-line-hooks
-  (list %syslog-line-hook
-        %installer-log-line-hook))
-
-(define-syntax installer-log-line
-  (lambda (s)
-    "Like 'format', but uses the default line hooks, and only formats one line."
-    (syntax-case s ()
-      ((_ fmt args ...)
-       (string? (syntax->datum #'fmt))
-       #'(let ((formatted (format #f fmt args ...)))
-               (for-each (lambda (f) (f formatted))
-                         %default-installer-line-hooks))))))
-
 
 ;;;
 ;;; Client protocol.
@@ -326,9 +226,8 @@ accepting socket."
                 (let ((errno (system-error-errno args)))
                   (if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
                       (begin
-                        (installer-log-line
-                         "removing client ~s due to ~s while replying"
-                         (fileno client) (strerror errno))
+                        (syslog "removing client ~s due to ~s while replying~%"
+                                (fileno client) (strerror errno))
                         (false-if-exception (close-port client))
                         remainder)
                       (cons client remainder))))))