ci: Update to the last version.

* gnu/ci.scm: Update to the master version.
nls: Mention Libera Chat in the translations.
2021-06-14 08:58:41 +02:00 · 2021-05-20 16:57:35 -04:00 · 2021-05-20 16:57:28 -04:00 · 2021-05-12 15:00:06 -04:00
1942 changed files with 627506 additions and 1205784 deletions
@@ -6,29 +6,15 @@
     (sentence-end-double-space . t)

     ;; For use with 'bug-reference-prog-mode'.
+     (bug-reference-url-format . "http://bugs.gnu.org/%s")
     (bug-reference-bug-regexp
-      . "\\(<https?://\\bugs\\.gnu\\.org/\\([0-9]+\\)>\\)")
-     (bug-reference-url-format . "https://bugs.gnu.org/%s")
-
-     (eval . (add-to-list 'completion-ignored-extensions ".go"))
+      . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")

     ;; Emacs-Guix
     (eval . (setq-local guix-directory
                         (locate-dominating-file default-directory
                                                 ".dir-locals.el")))

-     ;; YASnippet
-     (eval . (with-eval-after-load
-                 'yasnippet
-               (let ((guix-yasnippets
-                      (expand-file-name
-                       "etc/snippets/yas"
-                       (locate-dominating-file default-directory
-                                               ".dir-locals.el"))))
-                 (unless (member guix-yasnippets yas-snippet-dirs)
-                   (add-to-list 'yas-snippet-dirs guix-yasnippets)
-                   (yas-reload-all)))))
-
     ;; Geiser
     ;; This allows automatically setting the `geiser-guile-load-path'
     ;; variable when using various Guix checkouts (e.g., via git worktrees).
@@ -66,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))
@@ -94,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))
@@ -132,16 +112,13 @@
   (eval . (put 'munless 'scheme-indent-function 1))
   (eval . (put 'mlet* 'scheme-indent-function 2))
   (eval . (put 'mlet 'scheme-indent-function 2))
-   (eval . (put 'mparameterize 'scheme-indent-function 2))
   (eval . (put 'run-with-store 'scheme-indent-function 1))
   (eval . (put 'run-with-state 'scheme-indent-function 1))
   (eval . (put 'wrap-program 'scheme-indent-function 1))
-   (eval . (put 'wrap-script 'scheme-indent-function 1))
   (eval . (put 'with-imported-modules 'scheme-indent-function 1))
   (eval . (put 'with-extensions 'scheme-indent-function 1))
   (eval . (put 'with-parameters 'scheme-indent-function 1))
   (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))
@@ -163,39 +140,11 @@

   (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 ?~ "'"))
   (eval . (modify-syntax-entry ?$ "'"))
-   (eval . (modify-syntax-entry ?+ "'"))
-
-   ;; Emacs 28 changed the behavior of 'lisp-fill-paragraph', which causes the
-   ;; first line of package descriptions to extrude past 'fill-column', and
-   ;; somehow that is deemed more correct upstream (see:
-   ;; https://issues.guix.gnu.org/56197).
-   (eval . (progn
-             (require 'lisp-mode)
-             (defun emacs27-lisp-fill-paragraph (&optional justify)
-               (interactive "P")
-               (or (fill-comment-paragraph justify)
-                   (let ((paragraph-start
-                          (concat paragraph-start
-                                  "\\|\\s-*\\([(;\"]\\|\\s-:\\|`(\\|#'(\\)"))
-                         (paragraph-separate
-                          (concat paragraph-separate "\\|\\s-*\".*[,\\.]$"))
-                         (fill-column (if (and (integerp emacs-lisp-docstring-fill-column)
-                                               (derived-mode-p 'emacs-lisp-mode))
-                                          emacs-lisp-docstring-fill-column
-                                        fill-column)))
-                     (fill-paragraph justify))
-                   ;; Never return nil.
-                   t))
-             (setq-local fill-paragraph-function #'emacs27-lisp-fill-paragraph)))))
-
+   (eval . (modify-syntax-entry ?+ "'"))))
 (emacs-lisp-mode . ((indent-tabs-mode . nil)))
 (texinfo-mode    . ((indent-tabs-mode . nil)
                     (fill-column . 72))))
@@ -1,16 +0,0 @@
-root = true
-
-[*.{c,h,cpp,hpp,el,scm,ac,am,m4,po}{,.in}]
-end_of_line = lf
-insert_final_newline = true
-charset = utf-8
-trim_trailing_whitespace = true
-
-[*.{c,h,cpp,hpp,ac,am,m4,el,scm}{,.in}]
-max_line_length = 85
-
-[*.{c,h,cpp,hpp,ac,m4,el,scm}{,.in}]
-indent_style = space
-
-[*.{c,h,cpp,hpp}{,.in}]
-indent_size = 4
@@ -1,3 +0,0 @@
-*.scm       diff=scheme
-*.scm.in    diff=scheme
-*.texi      diff=texinfo
@@ -68,14 +68,12 @@
 /doc/version.texi
 /doc/version-*.texi
 /etc/committer.scm
-/etc/teams.scm
 /etc/gnu-store.mount
 /etc/guix-daemon.cil
 /etc/guix-daemon.conf
 /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-*
@@ -134,7 +132,6 @@
 /pre-inst-env
 /release-*
 /scripts/guix
-/t-*/
 /test-env
 /test-tmp
 /tests/*.trs
@@ -146,7 +143,6 @@ Makefile
 Makefile.in
 config.cache
 stamp-h[0-9]
-.am[0-9]*/
 .dirstamp
 .deps
 tmp
@@ -158,4 +154,3 @@ tmp
 /gnu/packages/bootstrap
 /gnu/packages/aux-files/guile-guile-launcher.o
 /guile
-.DS_Store
@@ -4,22 +4,33 @@
 (authorizations
 (version 0)

- (;; primary: "D963 A5A3 8A80 3D52 4461  F914 7483 0A27 6C32 8EC2"
-  ("2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"
-   (name "abcdw"))
+ (("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
+   (name "andreas"))
+  ("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"
   (name "ambrevar"))
-  ("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
-   (name "andreas"))
  ("27D5 86A4 F890 0854 329F  F09F 1260 E464 82E6 3562"
   (name "apteryx"))
  ("7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3"
   (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"))
@@ -35,8 +46,12 @@
  (;; primary: "295A F991 6F46 F8A1 34B0  29DA 8086 3842 F0FE D83B"
   "76CE C6B1 7274 B465 C02D  B3D9 E71A 3554 2C30 BAA5"
   (name "dannym"))
-  ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807"
-   (name "dthompson"))
+  ("B3C0 DB4D AD73 BA5D 285E  19AE 5143 0234 CEFD 87C3"
+   (name "davexunit"))
+  ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807" ;FIXME: to be confirmed!
+   (name "davexunit (2nd)"))
+  ("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"
@@ -46,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"))
@@ -56,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"
@@ -90,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).
@@ -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>
@@ -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
@@ -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				\
@@ -99,7 +97,6 @@ MODULES =					\
  guix/bzr-download.scm            		\
  guix/git-download.scm				\
  guix/hg-download.scm				\
-  guix/hash.scm					\
  guix/swh.scm					\
  guix/monads.scm				\
  guix/monad-repl.scm				\
@@ -129,32 +126,21 @@ MODULES =					\
  guix/cache.scm				\
  guix/cve.scm					\
  guix/workers.scm				\
-  guix/least-authority.scm			\
-  guix/read-print.scm				\
  guix/ipfs.scm					\
-  guix/platform.scm                             \
-  guix/platforms/arm.scm                        \
-  guix/platforms/mips.scm                       \
-  guix/platforms/powerpc.scm                    \
-  guix/platforms/riscv.scm                      \
-  guix/platforms/x86.scm                        \
  guix/build-system.scm				\
  guix/build-system/android-ndk.scm		\
  guix/build-system/ant.scm			\
  guix/build-system/cargo.scm			\
-  guix/build-system/channel.scm			\
  guix/build-system/chicken.scm			\
  guix/build-system/clojure.scm			\
  guix/build-system/cmake.scm			\
  guix/build-system/dub.scm			\
  guix/build-system/dune.scm			\
-  guix/build-system/elm.scm			\
  guix/build-system/emacs.scm			\
  guix/build-system/font.scm			\
  guix/build-system/go.scm			\
  guix/build-system/meson.scm			\
  guix/build-system/minify.scm			\
-  guix/build-system/minetest.scm		\
  guix/build-system/asdf.scm			\
  guix/build-system/copy.scm			\
  guix/build-system/glib-or-gtk.scm		\
@@ -166,7 +152,6 @@ MODULES =					\
  guix/build-system/maven.scm			\
  guix/build-system/node.scm			\
  guix/build-system/perl.scm			\
-  guix/build-system/pyproject.scm		\
  guix/build-system/python.scm			\
  guix/build-system/renpy.scm			\
  guix/build-system/ocaml.scm			\
@@ -174,7 +159,6 @@ MODULES =					\
  guix/build-system/waf.scm			\
  guix/build-system/r.scm			\
  guix/build-system/rakudo.scm			\
-  guix/build-system/rebar.scm			\
  guix/build-system/ruby.scm			\
  guix/build-system/scons.scm			\
  guix/build-system/texlive.scm			\
@@ -202,7 +186,6 @@ MODULES =					\
  guix/build/cmake-build-system.scm		\
  guix/build/dub-build-system.scm		\
  guix/build/dune-build-system.scm		\
-  guix/build/elm-build-system.scm		\
  guix/build/emacs-build-system.scm		\
  guix/build/meson-build-system.scm		\
  guix/build/minify-build-system.scm		\
@@ -220,17 +203,14 @@ 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/pyproject-build-system.scm		\
  guix/build/python-build-system.scm		\
  guix/build/ocaml-build-system.scm		\
  guix/build/qt-build-system.scm		\
  guix/build/r-build-system.scm			\
  guix/build/renpy-build-system.scm			\
  guix/build/rakudo-build-system.scm		\
-  guix/build/rebar-build-system.scm		\
  guix/build/ruby-build-system.scm		\
  guix/build/scons-build-system.scm		\
  guix/build/texlive-build-system.scm		\
@@ -240,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                       \
@@ -255,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			\
@@ -269,21 +248,16 @@ MODULES =					\
  guix/import/cpan.scm				\
  guix/import/cran.scm				\
  guix/import/crate.scm				\
-  guix/import/egg.scm   			\
-  guix/import/elm.scm				\
  guix/import/elpa.scm   			\
  guix/import/gem.scm				\
-  guix/import/git.scm                           \
  guix/import/github.scm   			\
  guix/import/gnome.scm				\
  guix/import/gnu.scm				\
  guix/import/go.scm				\
  guix/import/hackage.scm			\
-  guix/import/hexpm.scm				\
  guix/import/json.scm				\
  guix/import/kde.scm				\
  guix/import/launchpad.scm   			\
-  guix/import/minetest.scm   			\
  guix/import/opam.scm				\
  guix/import/print.scm				\
  guix/import/pypi.scm				\
@@ -312,34 +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/edit.scm			\
-  guix/scripts/system/reconfigure.scm		\
  guix/scripts/system/search.scm		\
-  guix/scripts/home.scm			\
-  guix/scripts/home/edit.scm			\
-  guix/scripts/home/import.scm			\
+  guix/scripts/system/reconfigure.scm		\
  guix/scripts/lint.scm				\
  guix/scripts/challenge.scm			\
  guix/scripts/import/crate.scm			\
  guix/scripts/import/cran.scm			\
-  guix/scripts/import/egg.scm   		\
-  guix/scripts/import/elm.scm			\
  guix/scripts/import/elpa.scm  		\
  guix/scripts/import/gem.scm			\
  guix/scripts/import/gnu.scm			\
  guix/scripts/import/go.scm			\
  guix/scripts/import/hackage.scm		\
-  guix/scripts/import/hexpm.scm			\
  guix/scripts/import/json.scm  		\
-  guix/scripts/import/minetest.scm  		\
  guix/scripts/import/opam.scm			\
  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				\
@@ -399,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/6.0-arm.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-arm64.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-i686.conf	\
-  gnu/packages/aux-files/linux-libre/6.0-x86_64.conf	\
-  gnu/packages/aux-files/linux-libre/5.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	\
@@ -424,11 +384,9 @@ AUX_FILES =						\
  gnu/packages/aux-files/linux-libre/4.14-x86_64.conf	\
  gnu/packages/aux-files/linux-libre/4.9-i686.conf	\
  gnu/packages/aux-files/linux-libre/4.9-x86_64.conf	\
+  gnu/packages/aux-files/linux-libre/4.4-i686.conf	\
+  gnu/packages/aux-files/linux-libre/4.4-x86_64.conf	\
  gnu/packages/aux-files/pack-audit.c			\
-  gnu/packages/aux-files/python/sanity-check.py		\
-  gnu/packages/aux-files/python/sanity-check-next.py	\
-  gnu/packages/aux-files/python/sitecustomize.py	\
-  gnu/packages/aux-files/renpy/renpy.in	\
  gnu/packages/aux-files/run-in-namespace.c

 # Templates, examples.
@@ -477,7 +435,6 @@ SCM_TESTS =					\
  tests/boot-parameters.scm			\
  tests/bournish.scm				\
  tests/builders.scm				\
-  tests/build-emacs-utils.scm			\
  tests/build-utils.scm			\
  tests/cache.scm				\
  tests/challenge.scm				\
@@ -492,8 +449,6 @@ SCM_TESTS =					\
  tests/debug-link.scm				\
  tests/derivations.scm			\
  tests/discovery.scm				\
-  tests/egg.scm				\
-  tests/elm.scm				\
  tests/elpa.scm				\
  tests/file-systems.scm			\
  tests/gem.scm				\
@@ -502,19 +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/home-services.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				\
@@ -529,16 +479,12 @@ SCM_TESTS =					\
  tests/profiles.scm				\
  tests/publish.scm				\
  tests/pypi.scm				\
-  tests/read-print.scm				\
  tests/records.scm				\
  tests/scripts.scm				\
  tests/search-paths.scm			\
  tests/services.scm				\
  tests/services/file-sharing.scm		\
-  tests/services/configuration.scm		\
-  tests/services/lightdm.scm			\
  tests/services/linux.scm			\
-  tests/services/telephony.scm			\
  tests/sets.scm				\
  tests/size.scm				\
  tests/status.scm				\
@@ -550,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					\
@@ -560,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
@@ -585,15 +524,11 @@ SH_TESTS =					\
  tests/guix-package.sh				\
  tests/guix-package-aliases.sh			\
  tests/guix-package-net.sh			\
-  tests/guix-style.sh				\
  tests/guix-system.sh				\
-  tests/guix-home.sh				\
  tests/guix-archive.sh				\
  tests/guix-authenticate.sh			\
  tests/guix-environment.sh			\
  tests/guix-environment-container.sh		\
-  tests/guix-shell.sh				\
-  tests/guix-shell-export-manifest.sh		\
  tests/guix-graph.sh				\
  tests/guix-describe.sh			\
  tests/guix-repl.sh     			\
@@ -644,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	\
@@ -661,49 +595,43 @@ dist_fishcompletion_DATA = etc/completion/fish/guix.fish
 nodist_selinux_policy_DATA = etc/guix-daemon.cil

 EXTRA_DIST +=						\
-  .dir-locals.el					\
-  .guix-authorizations					\
-  .guix-channel						\
-  CODE-OF-CONDUCT					\
  HACKING						\
  ROADMAP						\
  TODO							\
-  bootstrap						\
-  build-aux/build-self.scm				\
-  build-aux/check-channel-news.scm			\
-  build-aux/check-final-inputs-self-contained.scm	\
-  build-aux/compile-all.scm				\
-  build-aux/compile-as-derivation.scm			\
-  build-aux/config.rpath				\
-  build-aux/convert-xref.scm			\
-  build-aux/cuirass/hurd-manifest.scm			\
-  build-aux/generate-authors.scm			\
-  build-aux/test-driver.scm				\
-  build-aux/update-NEWS.scm				\
-  build-aux/update-guix-package.scm			\
-  doc/build.scm						\
-  etc/disarchive-manifest.scm				\
+  CODE-OF-CONDUCT					\
+  .dir-locals.el					\
+  .guix-authorizations					\
+  .guix-channel						\
+  scripts/guix.in					\
  etc/guix-install.sh					\
-  etc/historical-authorizations				\
  etc/news.scm						\
  etc/release-manifest.scm				\
-  etc/source-manifest.scm				\
  etc/system-tests.scm					\
-  etc/time-travel-manifest.scm				\
-  scripts/guix.in					\
-  tests/cve-sample.json					\
-  tests/keys/civodul.pub				\
-  tests/keys/dsa.pub					\
-  tests/keys/ed25519-2.pub				\
-  tests/keys/ed25519-2.sec				\
-  tests/keys/ed25519-3.pub				\
-  tests/keys/ed25519-3.sec				\
-  tests/keys/ed25519.pub				\
-  tests/keys/ed25519.sec				\
-  tests/keys/rsa.pub					\
-  tests/keys/signing-key.pub				\
-  tests/keys/signing-key.sec				\
+  etc/historical-authorizations				\
+  build-aux/build-self.scm				\
+  build-aux/compile-all.scm				\
+  build-aux/cuirass/hurd-manifest.scm			\
+  build-aux/check-final-inputs-self-contained.scm	\
+  build-aux/check-channel-news.scm			\
+  build-aux/compile-as-derivation.scm			\
+  build-aux/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/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						\
  $(TESTS)

 if !BUILD_DAEMON_OFFLOAD
@@ -727,75 +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.
-
-first_half :=								\
-  gnu/packages/a% gnu/packages/b% gnu/packages/c% gnu/packages/d%	\
-  gnu/packages/e% gnu/packages/f% gnu/packages/g% gnu/packages/h%	\
-  gnu/packages/i% gnu/packages/j% gnu/packages/k% gnu/packages/l%
-
-MODULES_CORE      := guix.scm $(filter-out guix/scripts/%,$(filter guix/%,$(MODULES)))
-MODULES_PACKAGES1 := $(filter $(first_half),$(MODULES))
-MODULES_PACKAGES2 := $(filter-out $(first_half),$(filter gnu/packages/%,$(MODULES)))
-MODULES_PACKAGES  := $(MODULES_PACKAGES1) $(MODULES_PACKAGES2)
-MODULES_SYSTEM    := gnu.scm $(filter-out gnu/packages/%,$(filter gnu/%,$(MODULES)))
-MODULES_CLI       := $(filter guix/scripts/%,$(MODULES))
-MODULES_PO        := guix/build/po.scm
-
-$(eval $(call guile-compilation-rule,make-core-go,	\
-  $(MODULES_CORE) guix/config.scm $(dist_noinst_DATA),	\
-  0))
-.PHONY: make-core-go
-
-$(eval $(call guile-compilation-rule,make-packages1-go,	\
-  $(MODULES_PACKAGES1) make-core-go,			\
-  $(words $(MODULES_CORE))))
-.PHONY: make-packages1-go
-
-$(eval $(call guile-compilation-rule,make-packages2-go,	\
-  $(MODULES_PACKAGES2) make-core-go make-packages1-go,	\
-  $(words $(MODULES_CORE) $(MODULES_PACKAGES1))))
-.PHONY: make-packages2-go
-
-make-packages-go: make-packages1-go make-packages2-go
-.PHONY: make-packages-go
-
-$(eval $(call guile-compilation-rule,make-system-go,	\
-  $(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

@@ -996,21 +864,25 @@ release: dist-with-updated-version all
 	  mv "guix-binary.$$system.tar.xz"					\
 	      "$(releasedir)/guix-binary-$(PACKAGE_VERSION).$$system.tar.xz" ;	\
 	done
-# Build 'current-guix' to speed things up for the next step.
-	$(top_builddir)/pre-inst-env guix build				\
-	      -e '((@ (gnu packages package-management) current-guix))'	\
+# Bump the Guix package version and build it (again).
+	GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT=yes \
+	$(top_builddir)/pre-inst-env "$(GUILE)"	\
+		$(top_srcdir)/build-aux/update-guix-package.scm	\
+		"`git rev-parse HEAD`"
+	git add $(top_srcdir)/gnu/packages/package-management.scm
+	git commit -m "gnu: guix: Update to `git rev-parse HEAD | cut -c1-7`."
+	$(top_builddir)/pre-inst-env guix build guix			\
 	      $(call system_flags,$(GUIX_SYSTEM_SUPPORTED_SYSTEMS))	\
 	      -v1 --no-grafts --fallback
 # Generate the ISO installation images.
 	for system in $(GUIX_SYSTEM_SUPPORTED_SYSTEMS) ; do				\
-	  GUIX_DISPLAYED_VERSION="`git describe --match=v* | sed -'es/^v//'`" ;		\
 	  image=`$(top_builddir)/pre-inst-env						\
-	    guix system image -t iso9660						\
+	    guix system image -t iso9660                                           	\
 	    --label="GUIX_$${system}_$(VERSION)"					\
            --system=$$system --fallback						\
 	    gnu/system/install.scm` ;							\
 	  if [ ! -f "$$image" ] ; then							\
-	    echo "failed to produce Guix installation image for $$system" >&2 ;		\
+	    echo "failed to produced Guix installation image for $$system" >&2 ;	\
 	    exit 1 ;									\
 	  fi ;										\
 	  cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" ;	\
@@ -1019,14 +891,13 @@ release: dist-with-updated-version all
 	done
 # Generate the VM images.
 	for system in $(GUIX_SYSTEM_VM_SYSTEMS) ; do					\
-	  GUIX_DISPLAYED_VERSION="`git describe --match=v* | sed -'es/^v//'`" ;		\
 	  image=`$(top_builddir)/pre-inst-env						\
 	    guix system image -t qcow2 $(GUIX_SYSTEM_VM_IMAGE_FLAGS)			\
 	    --save-provenance								\
 	    --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";	\
@@ -1066,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.
@@ -1107,35 +976,21 @@ WEBLATE_REPO = https://framagit.org/tyreunom/guix-translations
 # form.
 download-po:
 	dir=$$(mktemp -d); \
-	git clone --depth 1 "$(WEBLATE_REPO)" "$$dir/translations" && \
+	git clone --depth 1 "$(WEBLATE_REPO)" "$$dir/translations"; \
 	for domain in po/doc po/guix po/packages; do \
 	    for po in "$$dir/translations/$$domain"/*.po; do \
 	        translated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | cut -f1 -d' '); \
-	        untranslated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | rev | cut -f3 -d' ' | rev); \
-	        untranslated=$${untranslated:-0}; \
-	        total=$$(($$translated+$$untranslated)); \
 	        target=$$(basename "$$po"); \
 	        target="$$domain/$$target"; \
-	        msgfmt -c "$$po"; \
-	        if msgfmt -c "$$po" && [ "$$translated" != "0" ] && ([ "$$domain" != "po/doc" ] || [ "$$translated" -gt $$(($$total/10)) ] || [ -f $$target ]); then \
+	        if msgfmt -c "$$po" && [ "$$translated" != "0" ]; then \
 	            msgfilter --no-wrap -i "$$po" cat > "$$po".tmp; \
 	            mv "$$po".tmp "$$target"; \
 	            echo "copied $$target."; \
 	        else \
-	            echo "WARN: $$target ($$translated translated messages ($$((translated/total*100))%)) was not added/updated."; \
+	            echo "WARN: $$target ($$translated translated messages) was not added/updated."; \
 	        fi; \
 	    done; \
 	done; \
-	for po in po/doc/*.po; do \
-	    translated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | cut -f1 -d' '); \
-	    untranslated=$$(LANG=en_US.UTF-8 msgfmt --statistics "$$po" 2>&1 | rev | cut -f3 -d' ' | rev); \
-	    untranslated=$${untranslated:-0}; \
-	    total=$$(($$translated + $$untranslated)); \
-	    if [ "$$translated" -lt "$$(($$total/20))" ]; then \
-	        echo "WARN: $$po was removed because it is below the 5% threshold: $$((translated/total*100))%"; \
-	        rm $$po; \
-	    fi; \
-	done; \
 	rm -rf "$$dir"
 .PHONY: download-po

@@ -2,10 +2,8 @@
 #+TITLE: Guix NEWS – history of user-visible changes
 #+STARTUP: content hidestars

-Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
+Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
-Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>

  Copying and distribution of this file, with or without modification,
  are permitted in any medium without royalty provided the copyright
@@ -13,174 +11,10 @@ Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>

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

@@ -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])
@@ -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
@@ -274,7 +275,6 @@ AC_CONFIG_FILES([Makefile
                 guix/config.scm])

 AC_CONFIG_FILES([etc/committer.scm], [chmod +x etc/committer.scm])
-AC_CONFIG_FILES([etc/teams.scm], [chmod +x etc/teams.scm])
 AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env])
 AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
  [chmod +x pre-inst-env])
@@ -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))))
@@ -1,25 +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 (list (plain-file "bash-profile" "\
-export HISTFILE=$XDG_CACHE_HOME/.bash_history")))))
-
-   (simple-service 'test-config
-                   home-xdg-configuration-files-service-type
-                   (list `("test.conf"
-                           ,(plain-file "tmp-file.txt"
-                                        "the content of
-                                          ~/.config/test.conf")))))))
-
@@ -1,9 +1,9 @@
 # htmlxref.cnf - reference file for free Texinfo manuals on the web.
 # Modified by Ludovic Courtès <ludo@gnu.org> for the GNU Guix manual.

-htmlxrefversion=2026-01-19.09; # UTC
+htmlxrefversion=2020-01-11.22; # UTC

-# Copyright 2010-2020, 2022 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++/
 #
@@ -291,6 +279,8 @@ gdbm		chapter	${GDBM}/html_chapter/
 gdbm		section ${GDBM}/html_section/
 gdbm		node	${GDBM}/html_node/

+# XXX: These are actually pages created by texi2html, so no quite following
+# the expected naming scheme.
 geiser		chapter	http://geiser.nongnu.org/

 gettext		mono	${GS}/gettext/manual/gettext.html
@@ -298,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/
@@ -350,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/
@@ -409,37 +394,21 @@ GUILE_GNOME = ${GS}/guile-gnome/docs

 guile-gtk	node	${GS}/guile-gtk/docs/guile-gtk/

-guile-netlink	mono	https://git.lepiller.eu/guile-netlink/manual/manual.html
-
 guile-rpc	mono	${GS}/guile-rpc/manual/guile-rpc.html
 guile-rpc	node	${GS}/guile-rpc/manual/html_node/

-GUIX_ROOT = https://guix.gnu.org
-GUIX = ${GUIX_ROOT}/manual/1.4.0
- guix.de	mono	${GUIX}/de/guix.de.html
- guix.de	node	${GUIX}/de/html_node/
- guix.es	mono	${GUIX}/es/guix.es.html
- guix.es	node	${GUIX}/es/html_node/
- guix.fr	mono	${GUIX}/fr/guix.fr.html
- guix.fr	node	${GUIX}/fr/html_node/
- guix.pt_BR	mono	${GUIX}/pt-br/guix.pt_BR.html
- guix.pt_BR	node	${GUIX}/pt-br/html_node/
- guix.ru	mono	${GUIX}/ru/guix.ru.html
- guix.ru	node	${GUIX}/ru/html_node/
- guix.zh_CN	mono	${GUIX}/zh-cn/guix.zh_CN.html
- guix.zh_CN	node	${GUIX}/zh-cn/html_node/
- guix		mono	${GUIX}/en/guix.html
- guix		node	${GUIX}/en/html_node/
-
-GUIX_COOKBOOK = ${GUIX_ROOT}/cookbook
- guix-cookbook.de	mono	${GUIX_COOKBOOK}/de/guix-cookbook.de.html
- guix-cookbook.de	node    ${GUIX_COOKBOOK}/de/html_node/
- guix-cookbook.fr	mono    ${GUIX_COOKBOOK}/fr/guix-cookbook.fr.html
- guix-cookbook.fr	node    ${GUIX_COOKBOOK}/fr/html_node/
- guix-cookbook.sk	mono    ${GUIX_COOKBOOK}/sk/guix-cookbook.sk.html
- guix-cookbook.sk	node    ${GUIX_COOKBOOK}/sk/html_node/
- guix-cookbook		mono    ${GUIX_COOKBOOK}/en/guix-cookbook.html
- guix-cookbook		node	${GUIX_COOKBOOK}/en/html_node/
+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/
@@ -534,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

@@ -606,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
@@ -663,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/
@@ -671,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/
@@ -22,8 +22,8 @@
 # along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

 # If adding a language, update the following variables, and info_TEXINFOS.
-MANUAL_LANGUAGES = de es fr pt_BR ru zh_CN
-COOKBOOK_LANGUAGES = de fr ko sk
+MANUAL_LANGUAGES = de es fa 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.
@@ -34,15 +34,20 @@ lang_to_texinfo = $(foreach lang,$(1),%D%/$(2).$(lang).texi)
 info_TEXINFOS = %D%/guix.texi			\
  %D%/guix.de.texi				\
  %D%/guix.es.texi				\
+  %D%/guix.fa.texi				\
  %D%/guix.fr.texi				\
+  %D%/guix.it.texi				\
+  %D%/guix.ko.texi				\
  %D%/guix.pt_BR.texi				\
  %D%/guix.ru.texi				\
+  %D%/guix.sk.texi				\
  %D%/guix.zh_CN.texi				\
  %D%/guix-cookbook.texi			\
  %D%/guix-cookbook.de.texi			\
+  %D%/guix-cookbook.fa.texi			\
  %D%/guix-cookbook.fr.texi			\
  %D%/guix-cookbook.ko.texi			\
-  %D%/guix-cookbook.sk.texi
+  %D%/guix-cookbook.zh_Hans.texi

 %C%_guix_TEXINFOS = \
  %D%/contributing.texi \
@@ -73,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)		\
@@ -91,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
@@ -179,31 +198,19 @@ sub_commands_mans =				\
  $(srcdir)/%D%/guix-archive.1			\
  $(srcdir)/%D%/guix-build.1			\
  $(srcdir)/%D%/guix-challenge.1		\
-  $(srcdir)/%D%/guix-container.1		\
-  $(srcdir)/%D%/guix-copy.1			\
  $(srcdir)/%D%/guix-deploy.1			\
-  $(srcdir)/%D%/guix-describe.1			\
  $(srcdir)/%D%/guix-download.1			\
  $(srcdir)/%D%/guix-edit.1			\
  $(srcdir)/%D%/guix-environment.1		\
  $(srcdir)/%D%/guix-gc.1			\
-  $(srcdir)/%D%/guix-git.1			\
-  $(srcdir)/%D%/guix-graph.1			\
  $(srcdir)/%D%/guix-hash.1			\
-  $(srcdir)/%D%/guix-home.1			\
  $(srcdir)/%D%/guix-import.1			\
  $(srcdir)/%D%/guix-lint.1			\
-  $(srcdir)/%D%/guix-offload.1			\
-  $(srcdir)/%D%/guix-pack.1			\
  $(srcdir)/%D%/guix-package.1			\
-  $(srcdir)/%D%/guix-processes.1		\
  $(srcdir)/%D%/guix-publish.1			\
  $(srcdir)/%D%/guix-pull.1			\
  $(srcdir)/%D%/guix-refresh.1			\
-  $(srcdir)/%D%/guix-repl.1			\
-  $(srcdir)/%D%/guix-shell.1			\
  $(srcdir)/%D%/guix-size.1			\
-  $(srcdir)/%D%/guix-style.1			\
  $(srcdir)/%D%/guix-system.1			\
  $(srcdir)/%D%/guix-time-machine.1		\
  $(srcdir)/%D%/guix-weather.1
@@ -4,9 +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>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,53 +26,17 @@

 ;;; Code:

-(use-modules ((sxml xpath) #:prefix xpath:)
-             (srfi srfi-1)
-             (srfi srfi-2)
-             (srfi srfi-9)
-             (srfi srfi-11)
-             (srfi srfi-26)
-             (ice-9 format)
-             (ice-9 popen)
-             (ice-9 match)
-             (ice-9 rdelim)
-             (ice-9 regex)
-             (ice-9 textual-ports)
-             (guix gexp))
-
-(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"))
+(import (sxml xpath)
+        (srfi srfi-1)
+        (srfi srfi-2)
+        (srfi srfi-9)
+        (srfi srfi-11)
+        (srfi srfi-26)
+        (ice-9 format)
+        (ice-9 popen)
+        (ice-9 match)
+        (ice-9 rdelim)
+        (ice-9 textual-ports))

 (define (read-excursion port)
  "Read an expression from PORT and reset the port position before returning
@@ -101,16 +62,12 @@ LINE-NO in PORT."
           (read-line port)
           (loop (1- i) last-top-level-sexp))))))

-;;; Whether the hunk contains a newly added package (definition), a removed
-;;; package (removal) or something else (#false).
-(define hunk-types '(addition removal #false))
-
 (define-record-type <hunk>
  (make-hunk file-name
             old-line-number
             new-line-number
             diff-lines
-             type)
+             definition?)
  hunk?
  (file-name       hunk-file-name)
  ;; Line number before the change
@@ -119,8 +76,8 @@ LINE-NO in PORT."
  (new-line-number hunk-new-line-number)
  ;; The full diff to be used with "git apply --cached"
  (diff-lines hunk-diff-lines)
-  ;; Does this hunk add or remove a package?
-  (type hunk-type))                     ;one of 'hunk-types'
+  ;; Does this hunk add a definition?
+  (definition? hunk-definition?))

 (define* (hunk->patch hunk #:optional (port (current-output-port)))
  (let ((file-name (hunk-file-name hunk)))
@@ -138,30 +95,25 @@ LINE-NO in PORT."
                          ;; new definitions with changes to existing
                          ;; definitions.
                          "--unified=1"
-                          "--" "gnu")))
+                          "gnu")))
    (define (extract-line-number line-tag)
      (abs (string->number
            (car (string-split line-tag #\,)))))
    (define (read-hunk)
      (let loop ((lines '())
-                 (type #false))
+                 (definition? #false))
        (let ((line (read-line port 'concat)))
          (cond
           ((eof-object? line)
-            (values (reverse lines) type))
+            (values (reverse lines) definition?))
           ((or (string-prefix? "@@ " line)
                (string-prefix? "diff --git" line))
            (unget-string port line)
-            (values (reverse lines) type))
+            (values (reverse lines) definition?))
           (else
            (loop (cons line lines)
-                  (or type
-                      (cond
-                       ((string-prefix? "+(define" line)
-                        'addition)
-                       ((string-prefix? "-(define" line)
-                        'removal)
-                       (else #false)))))))))
+                  (or definition?
+                      (string-prefix? "+(define" line))))))))
    (define info
      (let loop ((acc '())
                 (file-name #f))
@@ -176,13 +128,13 @@ LINE-NO in PORT."
            (match (string-split line #\space)
              ((_ old-start new-start . _)
               (let-values
-                   (((diff-lines type) (read-hunk)))
+                   (((diff-lines definition?) (read-hunk)))
                 (loop (cons (make-hunk file-name
                                        (extract-line-number old-start)
                                        (extract-line-number new-start)
                                        (cons (string-append line "\n")
                                              diff-lines)
-                                        type) acc)
+                                        definition?) acc)
                       file-name)))))
           (else (loop acc file-name))))))
    (close-pipe port)
@@ -224,13 +176,8 @@ corresponding to the top-level definition containing the staged changes."
 (define* (change-commit-message file-name old new #:optional (port (current-output-port)))
  "Print ChangeLog commit message for changes between OLD and NEW."
  (define (get-values expr field)
-    (match ((xpath:sxpath `(// ,field quasiquote *)) expr)
-      (()
-       ;; New-style plain lists
-       (match ((xpath:sxpath `(// ,field list *)) expr)
-         ((inner) inner)
-         (_ '())))
-      ;; Old-style labelled inputs
+    (match ((sxpath `(// ,field quasiquote *)) expr)
+      (() '())
      ((first . rest)
       (map cadadr first))))
  (define (listify items)
@@ -244,7 +191,7 @@ corresponding to the top-level definition containing the staged changes."
  (define variable-name
    (second old))
  (define version
-    (and=> ((xpath:sxpath '(// version *any*)) new)
+    (and=> ((sxpath '(// version *any*)) new)
           first))
  (format port
          "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
@@ -257,70 +204,26 @@ 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)))
-  "Print ChangeLog commit message for a change to FILE-NAME adding a
-definition."
-  (format port "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
+(define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
+  "Print ChangeLog commit message for a change to FILE-NAME adding a definition."
+  (format port
+          "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
          variable-name file-name variable-name))

-(define* (remove-commit-message file-name variable-name
-                                #:optional (port (current-output-port)))
-  "Print ChangeLog commit message for a change to FILE-NAME removing a
-definition."
-  (format port "gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%"
-          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."
@@ -349,80 +252,63 @@ 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)))
    (hunks
-     (let-values (((definitions changes) (partition hunk-type hunks)))
-       ;; Additions/removals.
-       (for-each
-        (lambda (hunk)
-          (and-let* ((define-line (find (cut string-match "(\\+|-)\\(define" <>)
-                                        (hunk-diff-lines hunk)))
-                     (variable-name (and=> (string-tokenize define-line)
-                                           second))
-                     (commit-message-proc (match (hunk-type hunk)
-                                            ('addition add-commit-message)
-                                            ('removal remove-commit-message))))
-            (commit-message-proc (hunk-file-name hunk) variable-name)
-            (let ((port (open-pipe* OPEN_WRITE
-                                    "git" "apply"
-                                    "--cached"
-                                    "--unidiff-zero")))
-              (hunk->patch hunk port)
-              (unless (eqv? 0 (status:exit-val (close-pipe port)))
-                (error "Cannot apply")))
+     (let-values
+         (((definitions changes)
+           (partition hunk-definition? hunks)))

-            (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
-              (commit-message-proc (hunk-file-name hunk) variable-name port)
-              (usleep %delay)
-              (unless (eqv? 0 (status:exit-val (close-pipe port)))
-                (error "Cannot commit"))))
-          (usleep %delay))
-        definitions))
-
-     ;; Changes.
-     (for-each
-      (match-lambda
-        ((new old . hunks)
-         (for-each (lambda (hunk)
-                     (let ((port (open-pipe* OPEN_WRITE
-                                             "git" "apply"
-                                             "--cached"
-                                             "--unidiff-zero")))
-                       (hunk->patch hunk port)
-                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
+       ;; Additions.
+       (for-each (lambda (hunk)
+                   (and-let*
+                       ((define-line (find (cut string-prefix? "+(define" <>)
+                                           (hunk-diff-lines hunk)))
+                        (variable-name (and=> (string-tokenize define-line) second)))
+                     (add-commit-message (hunk-file-name hunk) variable-name)
+                     (let ((port (open-pipe* OPEN_WRITE                   
+                                             "git" "apply"                
+                                             "--cached"                   
+                                             "--unidiff-zero")))          
+                       (hunk->patch hunk port)                            
+                       (unless (eqv? 0 (status:exit-val (close-pipe port))) 
                         (error "Cannot apply")))
-                     (usleep %delay))
-                   hunks)
-         (define copyright-line
-           (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
-                                      (const line)))
-                (hunk-diff-lines (first hunks))))
-         (cond
-          (copyright-line
-           (add-copyright-line copyright-line))
-          (else
-           (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new)
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new
-                                     port)
-             (usleep %delay)
-             (unless (eqv? 0 (status:exit-val (close-pipe port)))
-               (error "Cannot commit")))))))
-      ;; XXX: we recompute the hunks here because previous
-      ;; insertions lead to offsets.
-      (new+old+hunks (diff-info))))))

-(apply main (cdr (command-line)))
+                     (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
+                       (add-commit-message (hunk-file-name hunk)
+                                           variable-name port)
+                       (usleep %delay)
+                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                         (error "Cannot commit"))))
+                   (usleep %delay))
+                 definitions)
+
+       ;; Changes.
+       (for-each (match-lambda
+                   ((new old . hunks)
+                    (for-each (lambda (hunk)
+                                (let ((port (open-pipe* OPEN_WRITE
+                                                        "git" "apply"
+                                                        "--cached"
+                                                        "--unidiff-zero")))
+                                  (hunk->patch hunk port)
+                                  (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                                    (error "Cannot apply")))
+                                (usleep %delay))
+                              hunks)
+                    (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")))))
+                 ;; XXX: we recompute the hunks here because previous
+                 ;; insertions lead to offsets.
+                 (new+old+hunks (diff-info)))))))
+
+(main)
@@ -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 ()
@@ -117,59 +111,58 @@ _guix_is_removing ()
    $result
 }

-_guix_is_short_option ()
-{
-    case "${COMP_WORDS[$COMP_CWORD - 1]}" in
-	--*)	false;;
-	-*$1)	true ;;
-	*)	false ;;
-    esac
-}
-
-_guix_is_long_option ()
-{
-    # Don't handle (non-GNU?) ‘--long-option VALUE’, as Guix doesn't either.
-    case "${COMP_WORDS[$COMP_CWORD]}" in
-	--$1=*)	true ;;
-	*)	false ;;
-    esac
-}
-
 _guix_is_dash_f ()
 {
-    _guix_is_short_option f ||
-    _guix_is_long_option file ||
-    _guix_is_long_option install-from-file
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-f" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --file=*|--install-from-file=*) true;;
+		 *)                              false;;
+	     esac }
 }

 _guix_is_dash_l ()
 {
-    _guix_is_short_option l ||
-    _guix_is_long_option load
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-l" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --load=*) true;;
+		 *)        false;;
+	     esac }
 }

 _guix_is_dash_L ()
 {
-    _guix_is_short_option L ||
-    _guix_is_long_option load-path
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-L" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --load-path=*) true;;
+		 *)             false;;
+	     esac }
 }

 _guix_is_dash_m ()
 {
-    _guix_is_short_option m ||
-    _guix_is_long_option manifest
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-m" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --manifest=*) true;;
+		 *)            false;;
+	     esac }
 }

 _guix_is_dash_C ()
 {
-    _guix_is_short_option C ||
-    _guix_is_long_option channels
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-C" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --channels=*)  true;;
+		 *)             false;;
+	     esac }
 }

 _guix_is_dash_p ()
 {
-    _guix_is_short_option p ||
-    _guix_is_long_option profile
+    [ "${COMP_WORDS[$COMP_CWORD - 1]}" = "-p" ] \
+	|| { case "${COMP_WORDS[$COMP_CWORD]}" in
+		 --profile=*)   true;;
+		 *)             false;;
+	     esac }
 }

 _guix_complete_file ()
@@ -179,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 ()
@@ -202,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
@@ -250,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
@@ -258,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
@@ -266,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
@@ -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
@@ -1,127 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; This file returns a manifest 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.4.0, Disarchive can only deal with raw tarballs,
-     ;; gzip-compressed tarballs, and xz-compressed tarballs.
-     (and (origin-hash origin)
-          (or (string-suffix? ".tar.gz" file)
-              (string-suffix? ".tgz" file)
-              (string-suffix? ".tar.xz" file)
-              (string-suffix? ".tar" file))))))
-
-(define (origin->disarchive origin)
-  "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)
-
-                                      ;; Dismiss origins with (sha256 #f) such
-                                      ;; as that of IceCat.
-                                      (and=> (origin-hash origin)
-                                             content-hash-value)
-
-                                      ;; FIXME: Exclude the Chromium tarball
-                                      ;; because it's huge and "disarchive
-                                      ;; disassemble" exceeds the max-silent
-                                      ;; timeout.
-                                      (not (string-prefix?
-                                            "chromium-"
-                                            (origin-actual-file-name origin)))
-
-                                      (origin->disarchive origin)))
-                               origins)
-                   #:copy? #t))
-
-
-;; 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))))))
@@ -1,5 +0,0 @@
-[diff "scheme"]
-	xfuncname = "^(\\(define.*)$"
-
-[diff "texinfo"]
-	xfuncname = "^@node[[:space:]]+([^,]+).*$"
@@ -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
@@ -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
@@ -6,19 +6,12 @@
 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
 StandardError=syslog

-# Work around a nasty systemd ‘feature’ that kills the entire process tree
-# (including the daemon!) if any child, such as cc1plus, runs out of memory.
-OOMPolicy=continue
-
-# Despite the name, this is rate-limited: a broken daemon will eventually fail.
-Restart=always
-
 # See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
 # Some package builds (for example, go@1.8.1) may require even more than
 # 1024 tasks.
@@ -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
@@ -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
@@ -3,14 +3,13 @@
 # Copyright © 2017 sharlatan <sharlatanus@gmail.com>
 # Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 # Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
-# Copyright © 2019–2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+# Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 # Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
 # Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 # Copyright © 2020 Daniel Brooks <db48x@db48x.net>
 # Copyright © 2021 Jakub Kądziołka <kuba@kadziolka.net>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
-# Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-# Copyright © 2022 Prafulla Giri <prafulla.giri@protonmail.com>
+# Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 #
 # This file is part of GNU Guix.
 #
@@ -34,7 +33,7 @@ then
    exec bash "$0" "$@"
 fi

-set -eo pipefail
+set -e

 [ "$UID" -eq 0 ] || { echo "This script must be run as root."; exit 1; }

@@ -93,20 +92,17 @@ _debug()
    fi
 }

-die()
-{
-    _err "${ERR}$*"
-    exit 1
-}
-
-# Return true if user answered yes, false otherwise.  The prompt is
-# yes-biased, that is, when the user simply enter newline, it is equivalent to
-# answering "yes".
+# Return true if user answered yes, false otherwise.
 # $1: The prompt question.
 prompt_yes_no() {
-    local -l yn
-    read -rp "$1 [Y/n]" yn
-    [[ ! $yn || $yn = y || $yn = yes ]] || return 1
+    while true; do
+        read -rp "$1" yn
+        case $yn in
+            [Yy]*) return 0;;
+            [Nn]*) return 1;;
+            *) _msg "Please answer yes or no."
+        esac
+    done
 }

 chk_require()
@@ -138,27 +134,21 @@ chk_gpg_keyring()
        gpg_key_id=${GPG_SIGNING_KEYS[$user_id]}
        # Without --dry-run this command will create a ~/.gnupg owned by root on
        # systems where gpg has never been used, causing errors and confusion.
-        if gpg --dry-run --list-keys "$gpg_key_id" >/dev/null 2>&1; then
-            continue
-        fi
-        if prompt_yes_no "${INF}The following OpenPGP public key is \
+        if ! gpg --dry-run --list-keys "$gpg_key_id" >/dev/null 2>&1; then
+            if prompt_yes_no "${INF}The following OpenPGP public key is \
 required to verify the Guix binary signature: $gpg_key_id.
-Would you like me to fetch it for you?"; then
-            # Use a reasonable time-out here so users don't report silent
-            # ‘freezes’ when Savannah goes out to lunch, as has happened.
-            if wget "https://sv.gnu.org/people/viewgpg.php?user_id=$user_id" \
-                    --timeout=30 --no-verbose -O- | gpg --import -; then
-                continue
-            fi
-        fi
-	# If we reach this point, the key is (still) missing.  Report further
-	# missing keys, if any, but then abort the installation.
-        _err "${ERR}Missing OpenPGP public key ($gpg_key_id).
+Would you like me to fetch it for you? (yes/no)"; then
+                wget "https://sv.gnu.org/people/viewgpg.php?user_id=$user_id" \
+                     -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
+                exit_flag=yes
+            fi
+        fi
    done
    if [ "$exit_flag" = yes ]; then
        exit 1
@@ -230,7 +220,8 @@ chk_sys_arch()
            local arch=powerpc64le
            ;;
        *)
-            die "Unsupported CPU type: ${arch}"
+            _err "${ERR}Unsupported CPU type: ${arch}"
+            exit 1
    esac

    case "$os" in
@@ -238,7 +229,8 @@ chk_sys_arch()
            local os=linux
            ;;
        *)
-            die "Your operation system (${os}) is not supported."
+            _err "${ERR}Your operation system (${os}) is not supported."
+            exit 1
    esac

    ARCH_OS="${arch}-${os}"
@@ -257,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?"; then
-        sed -i 's/--discover=no/--discover=yes/' "$1"
-    fi
-}
-
 # ------------------------------------------------------------------------------
 #+MAIN

@@ -280,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)")

@@ -293,7 +275,8 @@ guix_get_bin_list()
    if [[ "${#bin_ver_ls}" -ne "0" ]]; then
        _msg "${PAS}Release for your system: ${default_ver}"
    else
-        die "Could not obtain list of Guix releases."
+        _err "${ERR}Could not obtain list of Guix releases."
+        exit 1
    fi

    # Use default to download according to the list and local ARCH_OS.
@@ -312,13 +295,14 @@ 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
        _msg "${PAS}download completed."
    else
-        die "could not download ${url}/${bin_ver}.tar.xz."
+        _err "${ERR}could not download ${url}/${bin_ver}.tar.xz."
+        exit 1
    fi

    pushd "${dl_path}" >/dev/null
@@ -326,7 +310,8 @@ guix_get_bin()
        _msg "${PAS}Signature is valid."
        popd >/dev/null
    else
-        die "could not verify the signature."
+        _err "${ERR}could not verify the signature."
+        exit 1
    fi
 }

@@ -338,7 +323,8 @@ sys_create_store()
    _debug "--- [ ${FUNCNAME[0]} ] ---"

    if [[ -e "/var/guix" || -e "/gnu" ]]; then
-        die "A previous Guix installation was found.  Refusing to overwrite."
+        _err "${ERR}A previous Guix installation was found.  Refusing to overwrite."
+        exit 1
    fi

    cd "$tmp_path"
@@ -349,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}"
@@ -373,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
@@ -409,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"
            ;;
@@ -419,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;

@@ -441,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; } &&
@@ -451,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; } &&
@@ -464,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"
@@ -492,22 +470,14 @@ sys_enable_guix_daemon()
 }

 sys_authorize_build_farms()
-{ # authorize the public key(s) of the build farm(s)
-    local hosts=(
-	ci.guix.gnu.org
-	bordeaux.guix.gnu.org
-    )
-
+{ # authorize the public key of the build farm
    if prompt_yes_no "Permit downloading pre-built package binaries from the \
-project's build farms?"; then
-	for host in "${hosts[@]}"; do
-	    local key=~root/.config/guix/current/share/guix/$host.pub
-	    [ -f "$key" ] \
-		&& guix archive --authorize < "$key" \
-		&& _msg "${PAS}Authorized public key for $host"
-	done
-    else
-        _msg "${INF}Skipped authorizing build farm public keys"
+project's build farm? (yes/no) "; then
+        guix archive --authorize \
+             < "~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub" \
+            && _msg "${PAS}Authorized public key for ci.guix.gnu.org"
+        else
+            _msg "${INF}Skipped authorizing build farm public keys"
    fi
 }

@@ -515,17 +485,7 @@ sys_create_init_profile()
 { # Define for better desktop integration
  # This will not take effect until the next shell or desktop session!
    [ -d "/etc/profile.d" ] || mkdir /etc/profile.d # Just in case
-    cat <<"EOF" > /etc/profile.d/zzz-guix.sh
-# Explicitly initialize XDG base directory variables to ease compatibility
-# with Guix System: see <https://issues.guix.gnu.org/56050#3>.
-export XDG_DATA_HOME="${XDG_DATA_HOME:-$HOME/.local/share}"
-export XDG_CONFIG_HOME="${XDG_CONFIG_HOME:-$HOME/.config}"
-export XDG_STATE_HOME="${XDG_STATE_HOME:-$HOME/.local/state}"
-export XDG_DATA_DIRS="${XDG_DATA_DIRS:-/usr/local/share/:/usr/share/}"
-export XDG_CONFIG_DIRS="${XDG_CONFIG_DIRS:-/etc/xdg}"
-export XDG_CACHE_HOME="${XDG_CACHE_HOME:-$HOME/.cache}"
-# no default for XDG_RUNTIME_DIR (depends on foreign distro for semantics)
-
+    cat <<"EOF" > /etc/profile.d/guix.sh
 # _GUIX_PROFILE: `guix pull` profile
 _GUIX_PROFILE="$HOME/.config/guix/current"
 export PATH="$_GUIX_PROFILE/bin${PATH:+:}$PATH"
@@ -536,14 +496,15 @@ export PATH="$_GUIX_PROFILE/bin${PATH:+:}$PATH"
 export INFOPATH="$_GUIX_PROFILE/share/info:$INFOPATH"

 # GUIX_PROFILE: User's default profile
-# Prefer the one from 'guix home' if it exists.
-GUIX_PROFILE="$HOME/.guix-home/profile"
-[ -L $GUIX_PROFILE ] || GUIX_PROFILE="$HOME/.guix-profile"
+GUIX_PROFILE="$HOME/.guix-profile"
 [ -L $GUIX_PROFILE ] || return
 GUIX_LOCPATH="$GUIX_PROFILE/lib/locale"
-export GUIX_LOCPATH
+export GUIX_PROFILE GUIX_LOCPATH

 [ -f "$GUIX_PROFILE/etc/profile" ] && . "$GUIX_PROFILE/etc/profile"
+
+# set XDG_DATA_DIRS to include Guix installations
+export XDG_DATA_DIRS="$GUIX_PROFILE/share:${XDG_DATA_DIRS:-/usr/local/share/:/usr/share/}"
 EOF
 }

@@ -566,28 +527,9 @@ sys_create_shell_completion()
        _msg "${PAS}installed shell completion"
 }

-sys_customize_bashrc()
-{
-    prompt_yes_no "Customize users Bash shell prompt for Guix?" || return
-    for bashrc in /home/*/.bashrc /root/.bashrc; do
-        test -f "$bashrc" || continue
-        grep -Fq '$GUIX_ENVIRONMENT' "$bashrc" && continue
-        cp "${bashrc}" "${bashrc}.bak"
-        echo '
-# Automatically added by the Guix install script.
-if [ -n "$GUIX_ENVIRONMENT" ]; then
-    if [[ $PS1 =~ (.*)"\\$" ]]; then
-        PS1="${BASH_REMATCH[1]} [env]\\\$ "
-    fi
-fi
-' >> "$bashrc"
-    done
-    _msg "${PAS}Bash shell prompt successfully customized for Guix"
-}

 welcome()
 {
-    local char
    cat<<"EOF"
    ░░░                                     ░░░
    ░░▒▒░░░░░░░░░               ░░░░░░░░░▒▒░░
@@ -613,15 +555,8 @@ This script installs GNU Guix on your system

 https://www.gnu.org/software/guix/
 EOF
-    # Don't use ‘read -p’ here!  It won't display when run non-interactively.
-    echo -n "Press return to continue..."$'\r'
-    read -r char
-    if [ "$char" ]; then
-	echo
-	echo "...that ($char) was not a return!"
-	_msg "${WAR}Use newlines to automate installation, e.g.: yes '' | ${0##*/}"
-	_msg "${WAR}Any other method is unsupported and likely to break in future."
-    fi
+    echo -n "Press return to continue..."
+    read -r
 }

 main()
@@ -641,7 +576,7 @@ main()
    _msg "${INF}system is ${ARCH_OS}"

    umask 0022
-    tmp_path="$(mktemp -t -d guix.XXXXXX)"
+    tmp_path="$(mktemp -t -d guix.XXX)"

    if [ -z "${GUIX_BINARY_FILE_NAME}" ]; then
        guix_get_bin_list "${GNU_URL}"
@@ -661,7 +596,6 @@ main()
    sys_authorize_build_farms
    sys_create_init_profile
    sys_create_shell_completion
-    sys_customize_bashrc

    _msg "${INF}cleaning up ${tmp_path}"
    rm -r "${tmp_path}"
@@ -11,12 +11,10 @@ After=guix-daemon.service
 [Service]
 ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix publish --user=nobody --port=8181
 Environment='GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale' LC_ALL=en_US.utf8
+RemainAfterExit=yes
 StandardOutput=syslog
 StandardError=syslog

-# Despite the name, this is rate-limited: a broken daemon will eventually fail.
-Restart=always
-
 # See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
 TasksMax=1024

@@ -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
@@ -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)
@@ -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"

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -23,10 +23,9 @@
 (use-modules (gnu packages)
             (guix packages)
             (guix profiles)
-             ((guix platform) #:select (targets))
+             ((gnu ci) #:select (%cross-targets))
             ((gnu services xorg) #:select (%default-xorg-modules))
             (guix utils)
-             (guix gexp)
             (srfi srfi-1)
             (srfi srfi-26))

@@ -51,17 +50,18 @@ TARGET."
         "openssh" "emacs" "vim" "python" "guile" "guix")))

 (define %base-packages/armhf
-  ;; The guix package doesn't build natively on armhf due to Guile memory
-  ;; issues compiling the package modules
-  (remove (lambda (package)
-            (string=? (package-name package) "guix"))
-          %base-packages))
+  ;; XXX: Relax requirements for armhf-linux for lack of enough build power.
+  (map (lambda (package)
+         (if (string=? (package-name package) "emacs")
+             (specification->package "emacs-no-x")
+             package))
+       %base-packages))

 (define %base-packages/hurd
  ;; XXX: For now we are less demanding of "i586-gnu".
  (map specification->package
       '("coreutils" "grep" "findutils" "gawk" "make"
-         #;"gcc-toolchain" "tar" "xz")))
+         "gcc-toolchain" "tar" "xz")))

 (define %system-packages
  ;; Key packages proposed by the Guix System installer.
@@ -111,6 +111,8 @@ TARGET."
                      (cond ((string=? system "i586-gnu")
                             %base-packages/hurd)
                            ((string=? system "armhf-linux")
+                             ;; FIXME: Drop special case when ci.guix.gnu.org
+                             ;; has more ARMv7 build power.
                             %base-packages/armhf)
                            ((string=? system "powerpc64le-linux")
                             ;; FIXME: Drop 'bootstrap-tarballs' until
@@ -123,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
@@ -140,16 +137,9 @@ TARGET."
                      (if (target-mingw? target)
                          %packages-to-cross-build-for-mingw
                          %packages-to-cross-build)))
-               (fold delete (targets)
-                     '(;; Like in (gnu ci), dismiss cross-compilation to x86:
-                       ;; it's pointless.
-                       "x86_64-linux-gnu"
-                       "i686-linux-gnu"
-
-                       ;; XXX: Important bits like libsigsegv and libffi don't
-                       ;; support RISCV at the moment, so don't require RISCV
-                       ;; support.
-                       "riscv64-linux-gnu")))))
+               ;; XXX: Important bits like libsigsegv and libffi don't support
+               ;; RISCV at the moment, so don't require RISCV support.
+               (delete "riscv64-linux-gnu" %cross-targets))))

 (define %cross-bootstrap-manifest
  (manifest
@@ -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
@@ -11,7 +11,6 @@
                                          "ant-build-system"
                                          "asdf-build-system"
                                          "cargo-build-system"
-                                          "chicken-build-system"
                                          "clojure-build-system"
                                          "cmake-build-system"
                                          "copy-build-system"
@@ -28,7 +27,6 @@
                                          "linux-module-build-system"
                                          "maven-build-system"
                                          "meson-build-system"
-                                          "minetest-build-system"
                                          "minify-build-system"
                                          "node-build-system"
                                          "ocaml-build-system"
@@ -37,8 +35,6 @@
                                          "qt-build-system"
                                          "r-build-system"
                                          "rakudo-build-system"
-                                          "rebar-build-system"
-                                          "renpy-build-system"
                                          "ruby-build-system"
                                          "scons-build-system"
                                          "texlive-build-system"
@@ -1,89 +0,0 @@
-*- mode: lisp-data -*-
-
-scheme-mode
-
-(package...
- "(define-public " (s name)
- n> "(package"
- n  > "(name \"" (s name) "\")"
- n  > "(version \"" p "\")"
- n  > "(source origin...)"
- n  > "(build-system " (p "gnu") "-build-system)"
- n  > "(home-page \"" p "\")"
- n  > "(synopsis \"" p "\")"
- n  > "(description \"" p "\")"
- n  > "(license license:" (p "unknown") ")))" n)
-
-(origin...
- "(origin"
- n> "(method " (p "url-fetch" method) ")"
- n> "(uri " (cl-case (and method (intern method))
-              ('git-fetch "git-reference...")
-              ('svn-fetch "svn-reference...")
-              ('hg-fetch  "hg-reference...")
-              ('cvs-fetch "cvs-reference...")
-              ('bzr-fetch "bzr-reference...")
-              (t          "\"https://...\""))
- ")"
- n>
- (cl-case (and method (intern method))
-   ('git-fetch
-    (insert "(file-name (git-file-name name version))")
-    (newline)
-    (indent-according-to-mode))
-   ('hg-fetch
-    (insert "(file-name (hg-file-name name version))")
-    (newline)
-    (indent-according-to-mode))
-   ('svn-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   ('cvs-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   ('bzr-fetch
-    (insert "(file-name (string-append name \"-\" version \"-checkout\"))")
-    (newline)
-    (indent-according-to-mode))
-   (t          ""))
- > "(sha256"
- n > "(base32 \""
- ;; hash of an empty directory
- (p "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") "\")))")
-
-(git-reference...
- "(git-reference"
- n> "(url \"" p "\")"
- n> "(commit \"" p "\"))")
-
-(svn-reference...
- "(svn-reference"
- n> "(url \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(cvs-reference...
- "(cvs-reference"
- n> "(root-directory \"" p "\")"
- n> "(module \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(hg-reference...
- "(hg-reference"
- n> "(url \"" p "\")"
- n> "(changeset \"" p "\"))")
-
-(bzr-reference...
- "(bzr-reference"
- n> "(url \"" p "\")"
- n> "(revision \"" p "\"))")
-
-(:phases\ "#:phases (modify-phases %standard-phases"
-          n> p ")")
-
-(add-before\ "(add-before '" p " '" p
-             n > p ")")
-(add-after\ "(add-after '" p " '" p
-            n > p ")")
-(replace\ "(replace '" p " " p")")
@@ -1,158 +0,0 @@
-*- mode: lisp-data -*-
-
-text-mode :when (and (fboundp 'git-commit-mode) (git-commit-mode))
-
-(add\ "gnu: Add "
-      (p (with-temp-buffer
-           (magit-git-wash #'magit-diff-wash-diffs
-             "diff" "--staged")
-           (goto-char (point-min))
-           (when (re-search-forward "\\+(define-public \\(\\S-+\\)"
-                                    nil 'noerror)
-             (match-string-no-properties 1)))
-         var)
-      "." n n
-      "* " (p (or (car (magit-staged-files)) ""))
-      " (" (s var ) "): New variable.")
-
-(remove\ "gnu: Remove "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (when (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                       nil 'noerror)
-                (match-string-no-properties 1)))
-            var)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) ""))
-         " (" (s var) "): Delete variable.")
-
-(rename\ "gnu: "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (beginning-of-buffer)
-              (when (search-forward "-(define-public " nil 'noerror)
-                (thing-at-point 'sexp 'no-properties)))
-            prev-var)
-         ": Rename package to "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (beginning-of-buffer)
-              (when (search-forward "+(define-public " nil 'noerror)
-                (thing-at-point 'sexp 'no-properties)))
-            new-var)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) "")) " (" (s prev-var) "): "
-         "Define in terms of" n
-         "'deprecated-package'." n
-         "(" (s new-var) "): New variable, formerly known as \""
-         (s prev-var) "\".")
-
-(update\ "gnu: "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)"
-                                       nil 'noerror)
-                (match-string-no-properties 1)))
-            var)
-         ": Update to "
-         (p (with-temp-buffer
-              (magit-git-wash #'magit-diff-wash-diffs
-                "diff" "--staged")
-              (goto-char (point-min))
-              (search-forward "name" nil 'noerror)
-              (search-forward "+" nil 'noerror)   ; first change
-              (when (and (search-forward "version " nil 'noerror)
-                         (looking-at-p "\""))
-                (let ((end (save-excursion (search-forward "\")"
-                                                           nil 'noerror))))
-                  (when end
-                    (forward-char)
-                    (buffer-substring-no-properties (point) (- end 2))))))
-            version)
-         "." n n
-         "* " (p (or (car (magit-staged-files)) "")) " (" (s var) "): "
-         "Update to " (s version) "." n
-         (mapconcat (lambda (file) (concat "* " file))
-                    (cdr (magit-staged-files))
-                    "\n"))
-
-(addcl\ "gnu: Add cl-"
-        (p (replace-regexp-in-string
-            "^cl-" "" (with-temp-buffer
-                        (magit-git-wash #'magit-diff-wash-diffs
-                          "diff" "--staged")
-                        (beginning-of-buffer)
-                        (when (search-forward "+(define-public " nil 'noerror)
-                          (replace-regexp-in-string
-                           "^sbcl-" ""
-                           (thing-at-point 'sexp 'no-properties)))))
-           var)
-        "." n n
-        "* " (p (or (car (magit-staged-files)) ""))
-        " (cl-" (s var)
-        ", ecl-" (s var)
-        ", sbcl-" (s var) "): New variables.")
-
-(https\ "gnu: "
-        (p (with-temp-buffer
-             (magit-git-wash #'magit-diff-wash-diffs
-               "diff" "--staged")
-             (goto-char (point-min))
-             (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)"
-                                      nil 'noerror)
-               (match-string-no-properties 1)))
-           var)
-        ": Use HTTPS home page." n n
-        "* " (p (or (car (magit-staged-files)) ""))
-        " (" (s var) ")[home-page]: Use HTTPS."
-        n
-        (mapconcat (lambda (file) (concat "* " file))
-                   (cdr (magit-staged-files))
-                   "\n"))
-
-(move\ "gnu: "
-       (p (with-temp-buffer
-            (magit-git-wash #'magit-diff-wash-diffs
-              "diff" "--staged")
-            (goto-char (point-min))
-            (when (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                     nil 'noerror)
-              (match-string-no-properties 1)))
-          var)
-       ": Move to ("
-       (p (with-temp-buffer
-            (magit-git-wash #'magit-diff-wash-diffs
-              "diff" "--staged")
-            (goto-char (point-min))
-            (when (and
-                   (re-search-forward "\\+(define-public \\(\\S-+\\)"
-                                      nil 'noerror)
-                   (re-search-backward "modified[ ]*\\(\\S-+\\)"
-                                       nil 'noerror))
-              (string-replace
-               "\.scm" ""
-               (string-replace "/" " "
-                               (match-string-no-properties 1)))))
-          new-module)
-       ")." n
-       n
-       "* " (p (with-temp-buffer
-                  (magit-git-wash #'magit-diff-wash-diffs
-                    "diff" "--staged")
-                  (goto-char (point-min))
-                  (when (and
-                         (re-search-forward "\\-(define-public \\(\\S-+\\)"
-                                            nil 'noerror)
-                         (re-search-backward "modified[ ]*\\(\\S-+\\)"
-                                             nil 'noerror))
-                    (match-string-no-properties 1)))
-                source)
-       " (" (s var) "): Move from here…" n
-       "* " (concat (string-replace " " "/" new-module) ".scm")
-       " (" (s var) "): …to here.")
@@ -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")
@@ -1,13 +0,0 @@
-# -*- mode: snippet -*-
-# name: guix-commit-message-remove-package
-# key: remove
-# condition: git-commit-mode
-# --
-gnu: Remove ${1:`(with-temp-buffer
-                   (magit-git-wash #'magit-diff-wash-diffs
-                     "diff" "--staged")
-                   (goto-char (point-min))
-                   (when (re-search-forward "\\-(define-public \\(\\S-+\\)" nil 'noerror)
-                     (match-string-no-properties 1)))`}.
-
-* `(car (magit-staged-files))` ($1): Delete variable.
@@ -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)))
@@ -1,6 +0,0 @@
-(public-key
- (ecc
-  (curve Ed25519)
-  (q #7D602902D3A2DBB83F8A0FB98602A754C5493B0B778C8D1DD4E0F41DE14DE34F#)
-  )
- )
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018-2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,8 +18,7 @@

 (use-modules (gnu tests)
             (gnu packages package-management)
-             (guix monads)
-             (guix store)
+             ((gnu ci) #:select (channel-source->package))
             ((guix git-download) #:select (git-predicate))
             ((guix utils) #:select (current-source-directory))
             (git)
@@ -49,19 +48,15 @@ instance."
  ;; of tests to run in the usual way:
  ;;
  ;;   make check-system TESTS=installed-os
-  (let ((guix (channel-source->package source #:commit commit)))
-    (map (lambda (test)
-           (system-test
-            (inherit test)
-            (value (mparameterize %store-monad ((current-guix-package guix))
-                     (system-test-value test)))))
-         (match (getenv "TESTS")
-           (#f
-            (all-system-tests))
-           ((= string-tokenize (tests ...))
-            (filter (lambda (test)
-                      (member (system-test-name test) tests))
-                    (all-system-tests)))))))
+  (parameterize ((current-guix-package
+                  (channel-source->package source #:commit commit)))
+    (match (getenv "TESTS")
+      (#f
+       (all-system-tests))
+      ((= string-tokenize (tests ...))
+       (filter (lambda (test)
+                 (member (system-test-name test) tests))
+               (all-system-tests))))))

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

 (define %artwork-repository
-  (let ((commit "4c7f2ce6428a63e202cd2a9474a06f68a946934d"))
+  (let ((commit "2f2fe74c1078be605a6a93c2193fd6c715cebbb0"))
    (origin
      (method git-fetch)
      (uri (git-reference
@@ -39,6 +39,6 @@
                                "-checkout"))
      (sha256
       (base32
-        "1rl569759q9wm1dxn7nkq3873d2k92giic7aa6jwzwr3n16prc7y")))))
+        "0c8r0phvm3wgf914n2kw1461cwdjl2zbzqvzq9x7d9pwkgv7xmq7")))))

 ;;; artwork.scm ends here
@@ -1,11 +1,9 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 David Craven <david@craven.ch>
-;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
-;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
-;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,19 +21,12 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

 (define-module (gnu bootloader)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system uuid)
  #:use-module (guix discovery)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #: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 (srfi srfi-34)
-  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
@@ -48,7 +39,6 @@
            menu-entry-multiboot-kernel
            menu-entry-multiboot-arguments
            menu-entry-multiboot-modules
-            menu-entry-chain-loader

            menu-entry->sexp
            sexp->menu-entry
@@ -65,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
@@ -76,7 +65,7 @@
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
-            bootloader-configuration-device-tree-support?
+            bootloader-configuration-additional-configuration

            %bootloaders
            lookup-bootloader-by-name
@@ -107,77 +96,34 @@
  (multiboot-arguments menu-entry-multiboot-arguments
                       (default '()))      ; list of string-valued gexps
  (multiboot-modules menu-entry-multiboot-modules
-                     (default '()))        ; list of multiboot commands, where
+                     (default '())))       ; list of multiboot commands, where
                                           ; a command is a list of <string>
-  (chain-loader     menu-entry-chain-loader
-                    (default #f)))         ; string, path of efi file
-
-(define (report-menu-entry-error menu-entry)
-  (raise
-   (condition
-    (&message
-     (message
-      (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
-    (&fix-hint
-     (hint
-      (G_ "Please chose only one of:
-@enumerate
-@item direct boot by specifying fields @code{linux},
-@code{linux-arguments} and @code{linux-modules},
-@item multiboot by specifying fields @code{multiboot-kernel},
-@code{multiboot-arguments} and @code{multiboot-modules},
-@item chain-loader by specifying field @code{chain-loader}.
-@end enumerate"))))))

 (define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
-  (define (device->sexp device)
-    (match device
-      ((? uuid? uuid)
-       `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
-      ((? file-system-label? label)
-       `(label ,(file-system-label->string label)))
-      (_ device)))
  (match entry
-    (($ <menu-entry> label device mount-point
-                     (? identity linux) linux-arguments (? identity initrd)
-                     #f () () #f)
+    (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
+                     ())
     `(menu-entry (version 0)
                  (label ,label)
-                  (device ,(device->sexp device))
+                  (device ,device)
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))
    (($ <menu-entry> label device mount-point #f () #f
-                     (? identity multiboot-kernel) multiboot-arguments
-                     multiboot-modules #f)
+                     multiboot-kernel multiboot-arguments multiboot-modules)
     `(menu-entry (version 0)
                  (label ,label)
-                  (device ,(device->sexp device))
+                  (device ,device)
                  (device-mount-point ,mount-point)
                  (multiboot-kernel ,multiboot-kernel)
                  (multiboot-arguments ,multiboot-arguments)
-                  (multiboot-modules ,multiboot-modules)))
-    (($ <menu-entry> label device mount-point #f () #f #f () ()
-                     (? identity chain-loader))
-     `(menu-entry (version 0)
-                  (label ,label)
-                  (device ,(device->sexp device))
-                  (device-mount-point ,mount-point)
-                  (chain-loader ,chain-loader)))
-    (_ (report-menu-entry-error entry))))
+                  (multiboot-modules ,multiboot-modules)))))

 (define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
 record."
-  (define (sexp->device device-sexp)
-    (match device-sexp
-      (('uuid type uuid-string)
-       (uuid uuid-string type))
-      (('label label)
-       (file-system-label label))
-      (_ device-sexp)))
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
@@ -186,7 +132,7 @@ record."
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
-      (device (sexp->device device))
+      (device device)
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
@@ -199,20 +145,11 @@ record."
                  ('multiboot-modules multiboot-modules) _ ...)
     (menu-entry
      (label label)
-      (device (sexp->device device))
+      (device device)
      (device-mount-point mount-point)
      (multiboot-kernel multiboot-kernel)
      (multiboot-arguments multiboot-arguments)
-      (multiboot-modules multiboot-modules)))
-    (('menu-entry ('version 0)
-                  ('label label) ('device device)
-                  ('device-mount-point mount-point)
-                  ('chain-loader chain-loader) _ ...)
-     (menu-entry
-      (label label)
-      (device (sexp->device device))
-      (device-mount-point mount-point)
-      (chain-loader chain-loader)))))
+      (multiboot-modules multiboot-modules)))))


 ;;;
@@ -242,57 +179,30 @@ 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
-                         (default #f))     ;list of strings
-  (target                %bootloader-configuration-target ;deprecated
-                         (default #f)
-                         (sanitize warn-target-field-deprecation))
-  (menu-entries          bootloader-configuration-menu-entries
-                         (default '()))   ;list of <menu-entry>
-  (default-entry         bootloader-configuration-default-entry
-                         (default 0))     ;integer
-  (timeout               bootloader-configuration-timeout
-                         (default 5))     ;seconds as integer
-  (keyboard-layout       bootloader-configuration-keyboard-layout
-                         (default #f))    ;<keyboard-layout> | #f
-  (theme                 bootloader-configuration-theme
-                         (default #f))    ;bootloader-specific theme
-  (terminal-outputs      bootloader-configuration-terminal-outputs
-                         (default '(gfxterm)))   ;list of symbols
-  (terminal-inputs       bootloader-configuration-terminal-inputs
-                         (default '()))   ;list of symbols
-  (serial-unit           bootloader-configuration-serial-unit
-                         (default #f))    ;integer | #f
-  (serial-speed          bootloader-configuration-serial-speed
-                         (default #f))    ;integer | #f
-  (device-tree-support?  bootloader-configuration-device-tree-support?
-                         (default #t)))   ;boolean
-
-(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)))
+  (bootloader         bootloader-configuration-bootloader) ;<bootloader>
+  (target             bootloader-configuration-target      ;string
+                      (default #f))
+  (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
+                      (default '()))
+  (default-entry      bootloader-configuration-default-entry ;integer
+                      (default 0))
+  (timeout            bootloader-configuration-timeout ;seconds as integer
+                      (default 5))
+  (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
+                      (default #f))
+  (theme              bootloader-configuration-theme ;bootloader-specific theme
+                      (default #f))
+  (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
+                      (default '(gfxterm)))
+  (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
+                      (default '()))
+  (serial-unit        bootloader-configuration-serial-unit ;integer | #f
+                      (default #f))
+  (serial-speed       bootloader-configuration-serial-speed ;integer | #f
+                      (default #f)))


 ;;;
@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,9 +38,6 @@ corresponding to old generations of the system."
  (define all-entries
    (append entries (bootloader-configuration-menu-entries config)))

-  (define with-fdtdir?
-    (bootloader-configuration-device-tree-support? config))
-
  (define (menu-entry->gexp entry)
    (let ((label (menu-entry-label entry))
          (kernel (menu-entry-linux entry))
@@ -50,16 +46,12 @@ corresponding to old generations of the system."
      #~(format port "LABEL ~a
  MENU LABEL ~a
  KERNEL ~a
-  ~a
+  FDTDIR ~a/lib/dtbs
  INITRD ~a
  APPEND ~a
 ~%"
                #$label #$label
-                #$kernel
-                (if #$with-fdtdir?
-                    (string-append "FDTDIR " (dirname #$kernel) "/lib/dtbs")
-                    "")
-                #$initrd
+                #$kernel (dirname #$kernel) #$initrd
                (string-join (list #$@kernel-arguments)))))

  (define builder
@@ -7,8 +7,6 @@
 ;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
-;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,13 +50,10 @@
            grub-theme-color-highlight
            grub-theme-gfxmode

-            install-grub-efi-removable
            install-grub-efi-netboot

            grub-bootloader
            grub-efi-bootloader
-            grub-efi-removable-bootloader
-            grub-efi32-bootloader
            grub-efi-netboot-bootloader
            grub-mkrescue-bootloader
            grub-minimal-bootloader
@@ -269,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)
@@ -374,57 +367,44 @@ when booting a root file system on a Btrfs subvolume."
    (let ((label (menu-entry-label entry))
          (linux (menu-entry-linux entry))
          (device (menu-entry-device entry))
-          (device-mount-point (menu-entry-device-mount-point entry))
-          (multiboot-kernel (menu-entry-multiboot-kernel entry))
-          (chain-loader (menu-entry-chain-loader entry)))
-      (cond
-       (linux
-        (let ((arguments (menu-entry-linux-arguments entry))
-              (linux (normalize-file linux
-                                     device-mount-point
-                                     store-directory-prefix))
-              (initrd (normalize-file (menu-entry-initrd entry)
-                                      device-mount-point
-                                      store-directory-prefix)))
-          ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-          ;; Use the right file names for LINUX and INITRD in case
-          ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
-          ;; separate partition.
+          (device-mount-point (menu-entry-device-mount-point entry)))
+      (if linux
+          (let ((arguments (menu-entry-linux-arguments entry))
+                (linux (normalize-file linux
+                                       device-mount-point
+                                       store-directory-prefix))
+                (initrd (normalize-file (menu-entry-initrd entry)
+                                        device-mount-point
+                                        store-directory-prefix)))
+         ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+         ;; Use the right file names for LINUX and INITRD in case
+         ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+         ;; separate partition.

-          ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
-          ;; initrd paths, to allow booting from a Btrfs subvolume.
-          #~(format port "menuentry ~s {
+         ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
+         ;; initrd paths, to allow booting from a Btrfs subvolume.
+         #~(format port "menuentry ~s {
  ~a
  linux ~a ~a
  initrd ~a
 }~%"
-                    #$label
-                    #$(grub-root-search device linux)
-                    #$linux (string-join (list #$@arguments))
-                    #$initrd)))
-       (multiboot-kernel
-        (let ((kernel (menu-entry-multiboot-kernel entry))
-              (arguments (menu-entry-multiboot-arguments entry))
-              (modules (menu-entry-multiboot-modules entry))
-              (root-index 1))            ; XXX EFI will need root-index 2
-          #~(format port "
+                   #$label
+                   #$(grub-root-search device linux)
+                   #$linux (string-join (list #$@arguments))
+                   #$initrd))
+          (let ((kernel (menu-entry-multiboot-kernel entry))
+                (arguments (menu-entry-multiboot-arguments entry))
+                (modules (menu-entry-multiboot-modules entry))
+                (root-index 1))            ; XXX EFI will need root-index 2
+        #~(format port "
 menuentry ~s {
  multiboot ~a root=device:hd0s~a~a~a
-}~%"
-                    #$label
-                    #$kernel
-                    #$root-index (string-join (list #$@arguments) " " 'prefix)
-                    (string-join (map string-join '#$modules)
-                                 "\n  module " 'prefix))))
-       (chain-loader
-        #~(format port "
-menuentry ~s {
-  ~a
-  chainloader ~a
 }~%"
                  #$label
-                  #$(grub-root-search device chain-loader)
-                  #$chain-loader)))))
+                  #$kernel
+                  #$root-index (string-join (list #$@arguments) " " 'prefix)
+                  (string-join (map string-join '#$modules)
+                               "\n  module " 'prefix))))))

  (define (crypto-devices)
    (define (crypto-device->cryptomount dev)
@@ -435,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))))
@@ -626,54 +607,6 @@ fi~%"))))
                        "--bootloader-id=Guix"
                        "--efi-directory" target-esp)))))

-(define install-grub-efi-removable
-  #~(lambda (bootloader efi-dir mount-point)
-      ;; NOTE: mount-point is /mnt in guix system init /etc/config.scm /mnt/point
-      ;; NOTE: efi-dir comes from target list of booloader configuration
-      ;; There is nothing useful to do when called in the context of a disk
-      ;; image generation.
-      (when efi-dir
-        ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
-        ;; system whose root is mounted at MOUNT-POINT.
-        (let ((grub-install (string-append bootloader "/sbin/grub-install"))
-              (install-dir (string-append mount-point "/boot"))
-              ;; When installing Guix, it's common to mount EFI-DIR below
-              ;; MOUNT-POINT rather than /boot/efi on the live image.
-              (target-esp (if (file-exists? (string-append mount-point efi-dir))
-                              (string-append mount-point efi-dir)
-                              efi-dir)))
-          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
-          ;; root partition.
-          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-          (invoke/quiet grub-install "--boot-directory" install-dir
-                        "--removable"
-                        ;; "--no-nvram"
-                        "--bootloader-id=Guix"
-                        "--efi-directory" target-esp)))))
-
-(define install-grub-efi32
-  #~(lambda (bootloader efi-dir mount-point)
-      ;; There is nothing useful to do when called in the context of a disk
-      ;; image generation.
-      (when efi-dir
-        ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
-        ;; system whose root is mounted at MOUNT-POINT.
-        (let ((grub-install (string-append bootloader "/sbin/grub-install"))
-              (install-dir (string-append mount-point "/boot"))
-              ;; When installing Guix, it's common to mount EFI-DIR below
-              ;; MOUNT-POINT rather than /boot/efi on the live image.
-              (target-esp (if (file-exists? (string-append mount-point efi-dir))
-                              (string-append mount-point efi-dir)
-                              efi-dir)))
-          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
-          ;; root partition.
-          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-          (invoke/quiet grub-install "--boot-directory" install-dir
-                        "--bootloader-id=Guix"
-			(cond ((target-x86?) "--target=i386-efi")
-                              ((target-arm?) "--target=arm-efi"))
-                        "--efi-directory" target-esp)))))
-
 (define (install-grub-efi-netboot subdir)
  "Define a grub-efi-netboot bootloader installer for installation in SUBDIR,
 which is usually efi/Guix or efi/boot."
@@ -714,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\")
              …))
 …)

@@ -800,19 +732,6 @@ considered for security aspects."
   (name 'grub-efi)
   (package grub-efi)))

-(define grub-efi-removable-bootloader
-  (bootloader
-   (inherit grub-efi-bootloader)
-   (name 'grub-efi-removable-bootloader)
-   (installer install-grub-efi-removable)))
-
-(define grub-efi32-bootloader
-  (bootloader
-   (inherit grub-efi-bootloader)
-   (installer install-grub-efi32)
-   (name 'grub-efi32)
-   (package grub-efi32)))
-
 (define grub-efi-netboot-bootloader
  (bootloader
   (inherit grub-efi-bootloader)
@@ -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)
@@ -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))

@@ -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))))

@@ -1,8 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
-;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,12 +54,8 @@
 ;;; EFI bootloader.
 ;;;

-(define* (install-efi grub grub-config esp #:key targets)
-  "Write a self-contained GRUB EFI loader to the mounted ESP using
-GRUB-CONFIG.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
+(define (install-efi grub grub-config esp)
+  "Write a self-contained GRUB EFI loader to the mounted ESP using GRUB-CONFIG."
  (let* ((system %host-type)
         ;; Hard code the output location to a well-known path recognized by
         ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
@@ -69,15 +63,14 @@ the output filename.  Otherwise, use defaults for the host platform."
         (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
         (efi-directory (string-append esp "/EFI/BOOT"))
         ;; Map grub target names to boot file names.
-         (efi-targets (or targets
-                          (cond ((string-prefix? "x86_64" system)
-                                 '("x86_64-efi" . "BOOTX64.EFI"))
-                                ((string-prefix? "i686" system)
-                                 '("i386-efi" . "BOOTIA32.EFI"))
-                                ((string-prefix? "armhf" system)
-                                 '("arm-efi" . "BOOTARM.EFI"))
-                                ((string-prefix? "aarch64" system)
-                                 '("arm64-efi" . "BOOTAA64.EFI"))))))
+         (efi-targets (cond ((string-prefix? "x86_64" system)
+                             '("x86_64-efi" . "BOOTX64.EFI"))
+                            ((string-prefix? "i686" system)
+                             '("i386-efi" . "BOOTIA32.EFI"))
+                            ((string-prefix? "armhf" system)
+                             '("arm-efi" . "BOOTARM.EFI"))
+                            ((string-prefix? "aarch64" system)
+                             '("arm64-efi" . "BOOTAA64.EFI")))))
    ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
    (setenv "TMPDIR" esp)

@@ -88,12 +81,9 @@ the output filename.  Otherwise, use defaults for the host platform."
            ;; Graft the configuration file onto the image.
            (string-append "boot/grub/grub.cfg=" grub-config))))

-(define* (install-efi-loader grub-efi esp #:key targets)
+(define (install-efi-loader grub-efi esp)
  "Install in ESP directory the given GRUB-EFI bootloader.  Configure it to
-load the Grub bootloader located in the 'Guix_image' root partition.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
+load the Grub bootloader located in the 'Guix_image' root partition."
  (let ((grub-config "grub.cfg"))
    (call-with-output-file grub-config
      (lambda (port)
@@ -104,9 +94,7 @@ the output filename.  Otherwise, use defaults for the host platform."
        ;; (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 #:targets targets)
+    (install-efi grub-efi grub-config esp)
    (delete-file grub-config)))
-
@@ -1,6 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 Marius Bakke <marius@gnu.org>
-;;; Copyright © 2022 Nicolas Graves <ngraves@ngraves.fr>
+;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,11 +17,17 @@
 ;;; 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)
-  #:use-module (gnu packages node-xyz)
+  #:use-module (gnu packages xorg)
  #:use-module (guix build-system trivial)
  #:export (make-chromium-extension))

@@ -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,22 +68,37 @@ 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
+         ;; lighter.  (TODO: where is the CRXv3 documentation..?)
         (use-modules (guix build utils))
-         (let ((crx3 #+(file-append node-crx3 "/bin/crx3"))
-               (packdir (string-append (getcwd) "/extension")))
-           (mkdir packdir)
-           (copy-recursively (ungexp package package-output) packdir
-                             ;; Ensure consistent file modification times.
-                             #:keep-mtime? #t)
-           (invoke crx3 "--keyPath" #$signing-key packdir)
-           (copy-file (string-append packdir ".crx") #$output))))
-   #:local-build? #t))
+         (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
+               (xvfb #$(file-append xorg-server "/bin/Xvfb"))
+               (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...
+           ;; 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)))

-(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."
@@ -109,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"))))))))
@@ -1,213 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; This module contains procedures to interact with D-Bus via the 'dbus-send'
-;;; command line utility.  Before using any public procedure
-;;;
-;;; Code:
-
-(define-module (gnu build dbus-service)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-19)
-  #:use-module (srfi srfi-26)
-  #:autoload (d-bus protocol connections) (d-bus-conn?
-                                           d-bus-conn-flush
-                                           d-bus-connect
-                                           d-bus-disconnect
-                                           d-bus-session-bus-address
-                                           d-bus-system-bus-address)
-  #:autoload (d-bus protocol messages) (MESSAGE_TYPE_METHOD_CALL
-                                        d-bus-headers-ref
-                                        d-bus-message-body
-                                        d-bus-message-headers
-                                        d-bus-read-message
-                                        d-bus-write-message
-                                        header-PATH
-                                        header-DESTINATION
-                                        header-INTERFACE
-                                        header-MEMBER
-                                        header-SIGNATURE
-                                        make-d-bus-message)
-  #:export (%dbus-query-timeout
-
-            initialize-dbus-connection!
-            %current-dbus-connection
-            send-dbus
-            call-dbus-method
-
-            dbus-available-services
-            dbus-service-available?
-
-            with-retries))
-
-(define %dbus-query-timeout 2)          ;in seconds
-
-;;; Use Fibers' sleep to enable cooperative scheduling in Shepherd >= 0.9.0,
-;;; which is required at least for the Jami service.
-(define sleep*
-  (lambda ()                            ;delay execution
-    (if (resolve-module '(fibers) #f)
-        (module-ref (resolve-interface '(fibers)) 'sleep)
-        (begin
-          (format #f "fibers not available -- blocking 'sleep' in use")
-          sleep))))
-
-;;;
-;;; Utilities.
-;;;
-
-(define-syntax-rule (with-retries n delay body ...)
-  "Retry the code in BODY up to N times until it doesn't raise an exception nor
-return #f, else raise an error.  A delay of DELAY seconds is inserted before
-each retry."
-  (let loop ((attempts 0))
-    (catch #t
-      (lambda ()
-        (let ((result (begin body ...)))
-          (if (not result)
-              (error "failed attempt" attempts)
-              result)))
-      (lambda args
-        (if (< attempts n)
-            (begin
-              ((sleep*) delay)            ;else wait and retry
-              (loop (+ 1 attempts)))
-            (error "maximum number of retry attempts reached"
-                   body ... args))))))
-
-
-;;;
-;;; Low level wrappers above AC/D-Bus.
-;;;
-
-;; The active D-Bus connection (a parameter) used by the other procedures.
-(define %current-dbus-connection (make-parameter #f))
-
-(define* (initialize-dbus-connection!
-          #:key (address (or (d-bus-session-bus-address)
-                             (d-bus-system-bus-address))))
-  "Initialize the D-Bus connection.  ADDRESS should be the address of the D-Bus
-session, e.g. \"unix:path=/var/run/dbus/system_bus_socket\", the default value
-if ADDRESS is not provided and DBUS_SESSION_BUS_ADDRESS is not set.  Return
-the initialized D-Bus connection."
-  ;; Clear current correction if already active.
-  (when (d-bus-conn? (%current-dbus-connection))
-    (d-bus-disconnect (%current-dbus-connection)))
-
-  (let ((connection (d-bus-connect address)))
-    (%current-dbus-connection connection) ;update connection parameter
-    (call-dbus-method "Hello"))           ;initial handshake
-
-  (%current-dbus-connection))
-
-(define* (send-dbus message #:key
-                    (connection (%current-dbus-connection))
-                    timeout)
-  "Send a D-Bus MESSAGE to CONNECTION and return the body of its reply.  Up to
-READ-RETRIES replies are read until a matching reply is found, else an error
-is raised.  MESSAGE is to be constructed with `make-d-bus-message'.  When the
-body contains a single element, it is returned directly, else the body
-elements are returned as a list.  TIMEOUT is a timeout value in seconds."
-  (let ((serial     (d-bus-write-message connection message))
-        (start-time (current-time time-monotonic))
-        (timeout* (or timeout %dbus-query-timeout)))
-    (d-bus-conn-flush connection)
-    (let retry ()
-      (when (> (time-second (time-difference (current-time time-monotonic)
-                                             start-time))
-               timeout*)
-        (error 'dbus "fail to get reply in timeout" timeout*))
-      (let* ((reply (d-bus-read-message connection))
-             (reply-headers (d-bus-message-headers reply))
-             (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL))
-             (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME))
-             (body (d-bus-message-body reply)))
-        ;; Validate the reply matches the message.
-        (when error-name
-          (error 'dbus "method failed with error" error-name body))
-        ;; Some replies do not include a serial header, such as the for the
-        ;; org.freedesktop.DBus NameAcquired one.
-        (if (and reply-serial (= serial reply-serial))
-            (match body
-              ((x x* ..1)               ;contains 2 ore more elements
-               body)
-              ((x)
-               x)                       ;single element; return it directly
-              (#f #f))
-            (retry))))))
-
-(define (argument->signature-type argument)
-  "Infer the D-Bus signature type from ARGUMENT."
-  ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match).
-  (match argument
-    ((? boolean?) "b")
-    ((? string?) "s")
-    (#((? string?) (? string?) ...) "as")
-    (#(((? string?) . (? string?))
-       ((? string?) . (? string?)) ...) "a{ss}")
-    (_ (error 'dbus "no rule to infer type from argument" argument))))
-
-(define* (call-dbus-method method
-                           #:key
-                           (path "/org/freedesktop/DBus")
-                           (destination "org.freedesktop.DBus")
-                           (interface "org.freedesktop.DBus")
-                           (connection (%current-dbus-connection))
-                           arguments
-                           timeout)
-  "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE.
-The currently active D-Bus CONNECTION is used unless explicitly provided.
-Method arguments may be provided via ARGUMENTS sent as the message body.
-TIMEOUT limit the maximum time to allow for the reply.  Return the body of the
-reply."
-  (let ((message (make-d-bus-message
-                  MESSAGE_TYPE_METHOD_CALL 0 #f '()
-                  `#(,(header-PATH        path)
-                     ,(header-DESTINATION destination)
-                     ,(header-INTERFACE   interface)
-                     ,(header-MEMBER      method)
-                     ,@(if arguments
-                           (list (header-SIGNATURE
-                                  (string-join
-                                   (map argument->signature-type arguments)
-                                   "")))
-                           '()))
-                  arguments)))
-    (send-dbus message #:connection connection #:timeout timeout)))
-
-
-;;;
-;;; Higher-level, D-Bus procedures.
-;;;
-
-(define (dbus-available-services)
-  "Return the list of available (acquired) D-Bus services."
-  (let ((names (vector->list (call-dbus-method "ListNames"))))
-    ;; Remove entries such as ":1.7".
-    (remove (cut string-prefix? ":" <>) names)))
-
-(define (dbus-service-available? service)
-  "Predicate to check for the D-Bus SERVICE availability."
-  (member service (dbus-available-services)))
-
-;; Local Variables:
-;; eval: (put 'with-retries 'scheme-indent-function 2)
-;; End:
@@ -1,12 +1,11 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
-;;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,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)
@@ -53,16 +50,11 @@
            read-partition-uuid
            read-luks-partition-uuid

-            cleanly-unmounted-ext2?
-
            bind-mount

-            system*/tty
            mount-flags->bit-mask
            check-file-system
-            mount-file-system
-
-            swap-space->flags-bit-mask))
+            mount-file-system))

 ;;; Commentary:
 ;;;
@@ -71,45 +63,6 @@
 ;;;
 ;;; Code:

-(define (system*/console program . args)
-  "Run PROGRAM with ARGS in a tty on top of /dev/console.  The return value is
-as for 'system*'."
-  (match (primitive-fork)
-    (0
-     (dynamic-wind
-       (const #t)
-       (lambda ()
-         (login-tty (open-fdes "/dev/console" O_RDWR))
-         (apply execlp program program args))
-       (lambda ()
-         (primitive-_exit 127))))
-    (pid
-     (cdr (waitpid pid)))))
-
-(define (system*/tty program . args)
-  "Run PROGRAM with ARGS, creating a tty if its standard input isn't one.
-The return value is as for 'system*'.
-
-This is necessary for commands such as 'cryptsetup open' or 'fsck' that may
-need to interact with the user but might be invoked from shepherd, where
-standard input is /dev/null."
-  (apply (if (isatty? (current-input-port))
-             system*
-             system*/console)
-         program args))
-
-(define (call-with-input-file file proc)
-  "Like 'call-with-input-file', but pass O_CLOEXEC."
-  (let ((port #f))
-    (dynamic-wind
-      (lambda ()
-        (set! port (open file (logior O_RDONLY O_CLOEXEC))))
-      (lambda ()
-        (proc port))
-      (lambda ()
-        (close-port port)
-        (set! port #f)))))
-
 (define (bind-mount source target)
  "Bind-mount SOURCE at TARGET."
  (mount source target "" MS_BIND))
@@ -208,55 +161,24 @@ NUL terminator, return the size of the bytevector."
 if DEVICE does not contain an ext2 file system."
  (read-superblock device 1024 264 ext2-superblock?))

-(define (ext2-superblock-cleanly-unmounted? sblock)
-  "Return true if SBLOCK denotes a file system that was cleanly unmounted,
-false otherwise."
-  (define EXT2_VALID_FS 1)                        ;cleanly unmounted
-  (define EXT2_ERROR_FS 2)                        ;errors detected
-
-  (define EXT3_FEATURE_INCOMPAT_RECOVER #x0004)   ;journal needs recovery
-
-  (let ((state (bytevector-u16-ref sblock 58 %ext2-endianness)))
-    (cond ((= state EXT2_VALID_FS)
-           (let ((incompatible-features
-                  (bytevector-u32-ref sblock 96 %ext2-endianness)))
-             (zero? (logand incompatible-features
-                            EXT3_FEATURE_INCOMPAT_RECOVER))))
-          ((= state EXT2_ERROR_FS) #f)
-          (else (error "invalid ext2 superblock state" state)))))
-
 (define (ext2-superblock-uuid sblock)
  "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 104 16))

 (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*/tty "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)
    (_ 'fatal-error)))

-(define (cleanly-unmounted-ext2? device)          ;convenience procedure
-  "Return true if DEVICE is an ext2 file system and if it was cleanly
-unmounted."
-  (ext2-superblock-cleanly-unmounted? (read-ext2-superblock device)))
-

 ;;;
 ;;; Linux swap.
@@ -296,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))
-


 ;;;
@@ -347,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)
@@ -364,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*/tty "bcachefs" "fsck" "-v"
-                 `(,@(if force? '("-f") '())
-                   ,@(match repair
-                       (#f '("-n"))
-                       (#t '("-y"))
-                       (_  '("-p")))
-                   ;; Make each multi-device member a separate argument.
-                   ,@(string-split device #\:))))))
-    (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))))
@@ -416,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*/tty "btrfs" "check" "--progress"
-                     ;; Btrfs's ‘--force’ is not relevant to us here.
-                     `(,@(match repair
-                           ;; Upstream considers ALL repairs dangerous
-                           ;; and will warn the user at run time.
-                           (#t '("--repair"))
-                           (_  '("--readonly"     ; a no-op for clarity
-                                 ;; A 466G file system with 180G used is
-                                 ;; enough to kill btrfs with 6G of RAM.
-                                 "--mode" "lowmem")))
-                       ,device)))
-        (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)))


 ;;;
@@ -466,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
-          (system*/tty "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)))
@@ -506,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))
@@ -567,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))
@@ -599,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*/tty
-                 `("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)
@@ -669,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*/tty "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)))

@@ -768,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
-          (system*/tty "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
-     (system*/tty "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.
@@ -899,10 +662,6 @@ caught and lead to a warning and #f as the result."
                 (format (current-error-port)
                         "warning: failed to read from device '~a'~%" device)
                 #f)
-                ((= EMEDIUMTYPE errno)            ;inaccessible, like DRBD secondaries
-                 (format (current-error-port)
-                         "warning: failed to open device '~a'~%" device)
-                 #f)
                (else
                 (apply throw args))))))))

@@ -940,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
@@ -964,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))
@@ -1060,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)
@@ -1077,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)))
@@ -1127,7 +869,7 @@ corresponds to the symbols listed in FLAGS."
      (('read-only rest ...)
       (logior MS_RDONLY (loop rest)))
      (('bind-mount rest ...)
-       (logior MS_REC (logior MS_BIND (loop rest))))
+       (logior MS_BIND (loop rest)))
      (('no-suid rest ...)
       (logior MS_NOSUID (loop rest)))
      (('no-dev rest ...)
@@ -1136,22 +878,14 @@ corresponds to the symbols listed in FLAGS."
       (logior MS_NOEXEC (loop rest)))
      (('no-atime rest ...)
       (logior MS_NOATIME (loop rest)))
-      (('no-diratime rest ...)
-       (logior MS_NODIRATIME (loop rest)))
      (('strict-atime rest ...)
       (logior MS_STRICTATIME (loop rest)))
      (('lazy-time rest ...)
       (logior MS_LAZYTIME (loop rest)))
-      (('shared rest ...)
-       (loop rest))
      (()
       0))))

-(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)
@@ -1189,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 ()
@@ -1201,16 +935,12 @@ corresponds to the symbols listed in FLAGS."
                 (not (file-is-directory? source)))
            (unless (file-exists? target)
              (mkdir-p (dirname target))
-              (close-fdes
-               (open-fdes target (logior O_WRONLY O_CREAT O_CLOEXEC))))
+              (call-with-output-file target (const #t)))
            (mkdir-p target))

        (cond
         ((string-prefix? "nfs" type)
          (mount-nfs source target type flags options))
-         ((memq 'shared (file-system-flags fs))
-          (mount source target type flags options)
-          (mount "none" target #f MS_SHARED))
         (else
          (mount source target type flags options)))

@@ -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))
@@ -1,12 +1,10 @@
 ;;; 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>
-;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
-;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,7 +26,6 @@
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (guix store database)
-  #:use-module (guix utils)
  #:use-module (gnu build bootloader)
  #:use-module (gnu build install)
  #:use-module (gnu build linux-boot)
@@ -43,7 +40,6 @@
            convert-disk-image
            genimage
            initialize-efi-partition
-            initialize-efi32-partition
            initialize-root-partition

            make-iso9660-image))
@@ -52,13 +48,12 @@
  "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
 <partition> record."
  (match sexp
-    ((size file-system file-system-options label uuid flags)
+    ((size file-system file-system-options label uuid)
     (partition (size size)
                (file-system file-system)
                (file-system-options file-system-options)
                (label label)
-                (uuid uuid)
-                (flags flags)))))
+                (uuid uuid)))))

 (define (size-in-kib size)
  "Convert SIZE expressed in bytes, to kilobytes and return it as a string."
@@ -66,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
@@ -86,10 +79,7 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
        (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
    (apply invoke
           `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
-             "-L" ,label
-             ,@(if uuid
-                   `("-U" ,(uuid->string uuid))
-                   '())
+             "-L" ,label "-U" ,(uuid->string uuid)
             "-E" ,(format #f "root_owner=~a:~a,~a"
                           owner-uid owner-gid journal-options)
             ,@fs-options
@@ -100,18 +90,16 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
                           (estimate-partition-size root)
                           size)))))))

-(define* (make-vfat-image partition target root fs-bits)
+(define* (make-vfat-image partition target root)
  "Handle the creation of VFAT partition images.  See 'make-partition-image'."
  (let ((size (partition-size partition))
-        (label (partition-label partition))
-        (flags (partition-flags partition)))
-    (apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
-                          "-F" (number->string fs-bits)
-                          (size-in-kib
-                           (if (eq? size 'guess)
-                               (estimate-partition-size root)
-                               size))
-                    (if (member 'esp flags) (list "-S" "1024") '()))
+        (label (partition-label partition)))
+    (invoke "fakeroot" "mkdosfs" "-n" label "-C" target
+            "-F" "16" "-S" "1024"
+            (size-in-kib
+             (if (eq? size 'guess)
+                 (estimate-partition-size root)
+                 size)))
    (for-each (lambda (file)
                (unless (member file '("." ".."))
                  (invoke "mcopy" "-bsp" "-i" target
@@ -127,10 +115,8 @@ ROOT directory to populate the image."
    (cond
     ((string-prefix? "ext" type)
      (make-ext-image partition target root))
-     ((or (string=? type "vfat") (string=? type "fat16"))
-      (make-vfat-image partition target root 16))
-     ((string=? type "fat32")
-      (make-vfat-image partition target root 32))
+     ((string=? type "vfat")
+      (make-vfat-image partition target root))
     (else
      (raise (condition
              (&message
@@ -174,24 +160,12 @@ produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
  "Install in ROOT directory, an EFI loader using GRUB-EFI."
  (install-efi-loader grub-efi root))

-(define* (initialize-efi32-partition root
-                                     #:key
-                                     grub-efi32
-                                     #:allow-other-keys)
-  "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
-  (install-efi-loader grub-efi32 root
-                      #:targets (cond ((target-x86?)
-                                       '("i386-efi" . "BOOTIA32.EFI"))
-                                      ((target-arm?)
-                                       '("arm-efi" . "BOOTARM.EFI")))))
-
 (define* (initialize-root-partition root
                                    #:key
                                    bootcfg
                                    bootcfg-location
                                    bootloader-package
                                    bootloader-installer
-                                    (copy-closures? #t)
                                    (deduplicate? #t)
                                    references-graphs
                                    (register-closures? #t)
@@ -202,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
@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,24 +56,19 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
 (define* (evaluate-populate-directive directive target
                                      #:key
                                      (default-gid 0)
-                                      (default-uid 0)
-                                      (error-on-dangling-symlink? #t))
+                                      (default-uid 0))
  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
 directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
 the context of the caller.  If the directive matches those defaults then,
-'chown' won't be run.  When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
-error when a dangling symlink would be created."
-  (define target* (if (string-suffix? "/" target)
-                      target
-                      (string-append target "/")))
+'chown' won't be run."
  (let loop ((directive directive))
    (catch 'system-error
      (lambda ()
        (match directive
          (('directory name)
-           (mkdir-p (string-append target* name)))
+           (mkdir-p (string-append target name)))
          (('directory name uid gid)
-           (let ((dir (string-append target* name)))
+           (let ((dir (string-append target name)))
             (mkdir-p dir)
             ;; If called from a context without "root" permissions, "chown"
             ;; to root will fail.  In that case, do not try to run "chown"
@@ -84,38 +78,27 @@ error when a dangling symlink would be created."
                 (chown dir uid gid))))
          (('directory name uid gid mode)
           (loop `(directory ,name ,uid ,gid))
-           (chmod (string-append target* name) mode))
+           (chmod (string-append target name) mode))
          (('file name)
-           (call-with-output-file (string-append target* name)
+           (call-with-output-file (string-append target name)
             (const #t)))
          (('file name (? string? content))
-           (call-with-output-file (string-append target* name)
+           (call-with-output-file (string-append target name)
             (lambda (port)
               (display content port))))
          ((new '-> old)
-           (let ((new* (string-append target* new)))
-             (let try ()
-               (catch 'system-error
-                 (lambda ()
-                   (when error-on-dangling-symlink?
-                     ;; When the symbolic link points to a relative path,
-                     ;; checking if its target exists must be done relatively
-                     ;; to the link location.
-                     (unless (if (string-prefix? "/" old)
-                                 (file-exists? old)
-                                 (with-directory-excursion (dirname new*)
-                                   (file-exists? old)))
-                       (error (format #f "symlink `~a' points to nonexistent \
-file `~a'" new* old))))
-                   (symlink old new*))
-                 (lambda args
-                   ;; When doing 'guix system init' on the current '/', some
-                   ;; symlinks may already exists.  Override them.
-                   (if (= EEXIST (system-error-errno args))
-                       (begin
-                         (delete-file new*)
-                         (try))
-                       (apply throw args)))))))))
+           (let try ()
+             (catch 'system-error
+               (lambda ()
+                 (symlink old (string-append target new)))
+               (lambda args
+                 ;; When doing 'guix system init' on the current '/', some
+                 ;; symlinks may already exists.  Override them.
+                 (if (= EEXIST (system-error-errno args))
+                     (begin
+                       (delete-file (string-append target new))
+                       (try))
+                     (apply throw args))))))))
      (lambda args
        ;; Usually we can only get here when installing to an existing root,
        ;; as with 'guix system init foo.scm /'.
@@ -159,10 +142,7 @@ STORE."
 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
 EXTRAS is a list of directives appended to the built-in directives to populate
 TARGET."
-  ;; It's expected that some symbolic link targets do not exist yet, so do not
-  ;; error on dangling links.
-  (for-each (cut evaluate-populate-directive <> target
-                 #:error-on-dangling-symlink? #f)
+  (for-each (cut evaluate-populate-directive <> target)
            (append (directives (%store-directory)) extras))

  ;; Add system generation 1.
@@ -282,31 +262,12 @@ disk."
    (mount "/.rw-store" (%store-directory) "" MS_MOVE)
    (rmdir "/.rw-store")))

-(define (umount* directory)
-  "Unmount DIRECTORY, but retry a few times upon EBUSY."
-  (let loop ((attempts 5))
-    (catch 'system-error
-      (lambda ()
-        (umount directory))
-      (lambda args
-        (if (and (= EBUSY (system-error-errno args))
-                 (> attempts 0))
-            (begin
-              (sleep 1)
-              (loop (- attempts 1)))
-            (apply throw args))))))
-
 (define (unmount-cow-store target backing-directory)
  "Unmount copy-on-write store."
  (let ((tmp-dir "/remove"))
    (mkdir-p tmp-dir)
    (mount (%store-directory) tmp-dir "" MS_MOVE)
-
-    ;; We might get EBUSY at this point, possibly because of lingering
-    ;; processes with open file descriptors.  Use 'umount*' to retry upon
-    ;; EBUSY, leaving a bit of time.  See <https://issues.guix.gnu.org/59884>.
-    (umount* tmp-dir)
-
+    (umount tmp-dir)
    (rmdir tmp-dir)
    (delete-file-recursively
     (string-append target backing-directory))))
@@ -1,328 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; This module contains helpers used as part of the jami-service-type
-;;; definition.
-;;;
-;;; Code:
-
-(define-module (gnu build jami-service)
-  #:use-module (gnu build dbus-service)
-  #:use-module (ice-9 format)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 regex)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:export (jami-service-available?
-
-            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))
-
-;;;
-;;; Utilities.
-;;;
-
-(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)))
-
-(define (validate-fingerprint fingerprint)
-  "Validate that fingerprint is 40 characters long."
-  (unless (account-fingerprint? fingerprint)
-    (error "Account fingerprint is not valid:" fingerprint)))
-
-(define (jami-service-available?)
-  "Whether the Jami D-Bus service was acquired by the D-Bus daemon."
-  (unless (%current-dbus-connection)
-    (initialize-dbus-connection!))
-  (dbus-service-available? "cx.ring.Ring"))
-
-
-;;;
-;;; Bindings for the Jami D-Bus API.
-;;;
-
-(define* (call-configuration-manager-method method #:optional arguments
-                                            #:key timeout)
-  "Query the Jami D-Bus ConfigurationManager interface with METHOD applied to
-ARGUMENTS.  TIMEOUT can optionally be provided as a value in seconds."
-  (unless (%current-dbus-connection)
-    (initialize-dbus-connection!))
-  (call-dbus-method method
-                    #:path "/cx/ring/Ring/ConfigurationManager"
-                    #:destination "cx.ring.Ring"
-                    #:interface "cx.ring.Ring.ConfigurationManager"
-                    #:arguments arguments
-                    #:timeout timeout))
-
-;;; 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."
-  (vector->list (call-configuration-manager-method "getAccountList")))
-
-(define (id->account-details id)
-  "Retrieve the account data associated with the given account ID."
-  (vector->list (call-configuration-manager-method "getAccountDetails"
-                                                   (list id))))
-
-(define (id->volatile-account-details id)
-  "Retrieve the account data associated with the given account ID."
-  (vector->list (call-configuration-manager-method "getVolatileAccountDetails"
-                                                   (list id))))
-
-(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 "no account ID for ~:[username~;fingerprint~]"
-                             (account-fingerprint? username))))
-        (error message username))))
-
-(define (account->username account)
-  "Return the public key fingerprint of ACCOUNT."
-  (assoc-ref account "Account.username"))
-
-(define (id->username id)
-  "Return the public key fingerprint corresponding to account with ID, 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 ((id (call-configuration-manager-method
-             "addAccount" (list `#(("Account.archivePath" . ,archive)
-                                   ("Account.type" . "RING"))))))
-    ;; The account information takes some time to be populated.
-    (with-retries 20 1
-      (let ((username (id->username id)))
-        (if (and=> username (negate string-null?))
-            username
-            #f)))))
-
-(define (remove-account username)
-  "Delete the Jami account associated with USERNAME, the account 40 characters
-fingerprint or a registered username."
-  (let ((id (username->id username)))
-    (call-configuration-manager-method "removeAccount" (list id)))
-  (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))
-         ;; The contacts are returned as "aa{ss}", that is, an array of arrays
-         ;; containing (string . string) pairs.
-         (contacts (map vector->list
-                        (vector->list (call-configuration-manager-method
-                                       "getContacts" (list id)))))
-         (banned? (lambda (contact)
-                    (and=> (assoc-ref contact "banned")
-                           (cut string=? "true" <>))))
-         (banned (filter banned? contacts))
-         (not-banned (filter (negate banned?) 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)))
-    (call-configuration-manager-method "removeContact" (list id contact ban?))))
-
-(define (add-contact contact username)
-  "Add CONTACT, the 40 characters public key fingerprint of a contact, to the
-account of USERNAME (either a fingerprint or a registered username)."
-  (validate-fingerprint contact)
-  (let ((id (username->id username)))
-    (call-configuration-manager-method "addContact" (list id contact))))
-
-(define* (set-account-details details username #:key timeout)
-  "Set DETAILS, an alist containing the key value pairs to set for the account
-of USERNAME, a registered username or account fingerprint.  The value of the
-parameters not provided are unchanged.  TIMEOUT is a value in milliseconds to
-pass to the `call-configuration-manager-method' procedure."
-  (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)))
-    (call-configuration-manager-method
-     "setAccountDetails" (list id (list->vector updated-details))
-     #:timeout timeout)))
-
-(define (set-all-moderators enabled? username)
-  "Set the 'AllModerators' property to enabled? for the account of USERNAME, a
-registered username or account fingerprint."
-  (let ((id (username->id username)))
-    (call-configuration-manager-method "setAllModerators" (list id enabled?))))
-
-(define (username->all-moderators? username)
-  "Return the 'AllModerators' property for the account of USERNAME, a
-registered username or account fingerprint."
-  (let ((id (username->id username)))
-    (call-configuration-manager-method "isAllModerators" (list id))))
-
-(define (username->moderators username)
-  "Return the moderators for the account of USERNAME, a registered username or
-account fingerprint."
-  (let* ((id (username->id username)))
-    (vector->list (call-configuration-manager-method "getDefaultModerators"
-                                                     (list id)))))
-
-(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)))
-    (call-configuration-manager-method "setDefaultModerator"
-                                       (list id contact 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 60))
-
-(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"))
@@ -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,77 +521,54 @@ 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")
        (load-linux-modules-from-directory linux-modules
                                           linux-module-directory)

+        (unless (or (member "hibernate=noresume" args)
+                    ;; Also handle the equivalent old-style argument.
+                    ;; See Documentation/admin-guide/kernel-parameters.txt.
+                    (member "noresume" args))
+          ;; Try to resume immediately after loading (storage) modules
+          ;; but before any on-disk file systems have been mounted.
+          (false-if-exception           ; failure is not fatal
+           (resume-if-hibernated (find-long-option "resume" args))))
+
        (when keymap-file
          (let ((status (system* "loadkeys" keymap-file)))
            (unless (zero? status)
@@ -602,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"))
@@ -622,37 +593,18 @@ the root file system...\n" root-delay)
          (unless (pre-mount)
            (error "pre-mount actions failed")))

-        (unless (or (member "hibernate=noresume" args)
-                    ;; Also handle the equivalent old-style argument.
-                    ;; See Documentation/admin-guide/kernel-parameters.txt.
-                    (member "noresume" args))
-          ;; Try to resume immediately after loading (storage) modules
-          ;; but before any on-disk file systems have been mounted.
-          (false-if-exception           ; failure is not fatal
-           (resume-if-hibernated (find-long-option "resume" args))))
-
        (setenv "EXT2FS_NO_MTAB_OK" "1")

-        ;; Mount the root file system.
-        (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))
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017-2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -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)
@@ -233,7 +232,7 @@ that host UIDs (respectively GIDs) map to in the namespace."
  ;; The parent process must initialize the user namespace for the child
  ;; before it can boot.  To negotiate this, a pipe is used such that the
  ;; child process blocks until the parent writes to it.
-  (match (socketpair PF_UNIX (logior SOCK_CLOEXEC SOCK_STREAM) 0)
+  (match (socketpair PF_UNIX SOCK_STREAM 0)
    ((child . parent)
     (let ((flags (namespaces->bit-mask namespaces)))
       (match (clone flags)
@@ -301,28 +300,8 @@ delete it when leaving the dynamic extent of this call."
      (lambda ()
        (false-if-exception (delete-file-recursively tmp-dir))))))

-(define (wait-child-process)
-  "Wait for one child process and return a pair, like 'waitpid', or return #f
-if there are no child processes left."
-  (catch 'system-error
-    (lambda ()
-      (waitpid WAIT_ANY))
-    (lambda args
-      (if (= ECHILD (system-error-errno args))
-          #f
-          (apply throw args)))))
-
-(define (status->exit-status status)
-  "Reify STATUS as an exit status."
-  (or (status:exit-val status)
-      ;; See <http://www.tldp.org/LDP/abs/html/exitcodes.html#EXITCODESREF>.
-      (+ 128 (or (status:term-sig status)
-                 (status:stop-sig status)))))
-
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                              (host-uids 1) (guest-uid 0) (guest-gid 0)
-                              (relayed-signals (list SIGINT SIGTERM))
-                              (child-is-pid1? #t)
                              (process-spawned-hook (const #t)))
  "Run THUNK in a new container process and return its exit status; call
 PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
@@ -340,64 +319,20 @@ can map more than a single uid/gid.
 GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host
 UIDs (respectively GIDs) map to in the namespace.

-RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
-process when caught by its parent.
-
-When CHILD-IS-PID1? is true, and if NAMESPACES contains 'pid', then the child
-process runs directly as PID 1.  As such, it is responsible for (1) installing
-signal handlers and (2) reaping terminated processes by calling 'waitpid'.
-When CHILD-IS-PID1? is false, a new intermediate process is created instead
-that takes this responsibility.
-
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
-  (define thunk*
-    (if (and (memq 'pid namespaces)
-             (not child-is-pid1?))
-        (lambda ()
-          ;; Behave like an init process: create a sub-process that calls
-          ;; THUNK, and wait for child processes.  Furthermore, forward
-          ;; RELAYED-SIGNALS to the child process.
-          (match (primitive-fork)
-            (0
-             (call-with-clean-exit thunk))
-            (pid
-             (install-signal-handlers pid)
-             (let loop ()
-               (match (wait-child-process)
-                 ((child . status)
-                  (if (= child pid)
-                      (primitive-exit (status->exit-status status))
-                      (loop)))
-                 (#f
-                  (primitive-exit 128)))))))      ;cannot happen
-        thunk))
-
-  (define (periodically-schedule-asyncs)
-    ;; XXX: In Guile there's a time window where a signal-handling async could
-    ;; be queued without being processed by the time we enter a blocking
-    ;; syscall like waitpid(2) (info "(guile) Signals").  This terrible hack
-    ;; ensures pending asyncs get a chance to run periodically.
-    (sigaction SIGALRM (lambda _ (alarm 1)))
-    (alarm 1))
-
-  (define (install-signal-handlers pid)
-    ;; Install handlers that forward signals to PID.
-    (define (relay-signal signal)
-      (false-if-exception (kill pid signal)))
-
-    (periodically-schedule-asyncs)
-    (for-each (lambda (signal)
-                (sigaction signal relay-signal))
-              relayed-signals))
-
  (call-with-temporary-directory
   (lambda (root)
-     (let ((pid (run-container root mounts namespaces host-uids thunk*
+     (let ((pid (run-container root mounts namespaces host-uids thunk
                               #:guest-uid guest-uid
                               #:guest-gid guest-gid)))
-       (install-signal-handlers pid)
+       ;; Catch SIGINT and kill the container process.
+       (sigaction SIGINT
+         (lambda (signum)
+           (false-if-exception
+            (kill pid SIGKILL))))
+
       (process-spawned-hook pid)
       (match (waitpid pid)
         ((_ . status) status))))))
@@ -442,10 +377,6 @@ return the exit status."
  "Like 'container-excursion', but return the return value of THUNK."
  (match (pipe)
    ((in . out)
-     ;; Make sure IN and OUT are not inherited if THUNK forks + execs.
-     (fcntl in F_SETFD FD_CLOEXEC)
-     (fcntl out F_SETFD FD_CLOEXEC)
-
     (match (container-excursion pid
              (lambda ()
                (close-port in)
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
@@ -28,7 +28,6 @@
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
@@ -51,17 +50,6 @@
            load-linux-module*
            load-linux-modules-from-directory

-            pci-devices
-            pci-device?
-            pci-device-vendor
-            pci-device-id
-            pci-device-class
-            pci-device-module-alias
-            storage-pci-device?
-            network-pci-device?
-            display-pci-device?
-            load-pci-device-database
-
            current-module-debugging-port

            device-module-aliases
@@ -366,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
@@ -441,127 +427,6 @@ key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
      (line
       (loop (cons (key=value->pair line) result))))))

-;; PCI device known to the Linux kernel.
-(define-immutable-record-type <pci-device>
-  (pci-device vendor device class module-alias)
-  pci-device?
-  (vendor       pci-device-vendor)                ;integer
-  (device       pci-device-id)                    ;integer
-  (class        pci-device-class)                 ;integer
-  (module-alias pci-device-module-alias))         ;string | #f
-
-(define (pci-device-class-predicate mask bits)
-  (lambda (device)
-    "Return true if DEVICE has the chosen class."
-    (= (logand mask (pci-device-class device)) bits)))
-
-(define storage-pci-device?                   ;"Mass storage controller" class
-  (pci-device-class-predicate #xff0000 #x010000))
-(define network-pci-device?                       ;"Network controller" class
-  (pci-device-class-predicate #xff0000 #x020000))
-(define display-pci-device?                       ;"Display controller" class
-  (pci-device-class-predicate #xff0000 #x030000))
-
-(define (pci-devices)
-  "Return the list of PCI devices of the system (<pci-device> records)."
-  (define (read-hex port)
-    (let ((line (read-line port)))
-      (and (string? line)
-           (string-prefix? "0x" line)
-           (string->number (string-drop line 2) 16))))
-
-  (filter-map (lambda (directory)
-                (define properties
-                  (call-with-input-file (string-append directory "/uevent")
-                    read-uevent))
-                (define vendor
-                  (call-with-input-file (string-append directory "/vendor")
-                    read-hex))
-                (define device
-                  (call-with-input-file (string-append directory "/device")
-                    read-hex))
-                (define class
-                  (call-with-input-file (string-append directory "/class")
-                    read-hex))
-
-                (pci-device vendor device class
-                            (assq-ref properties 'MODALIAS)))
-              (find-files "/sys/bus/pci/devices"
-                          #:stat lstat)))
-
-(define (read-pci-device-database port)
-  "Parse the 'pci.ids' database that ships with the pciutils package and is
-maintained at <https://pci-ids.ucw.cz/>."
-  (define (comment? str)
-    (string-prefix? "#" (string-trim str)))
-  (define (blank? str)
-    (string-null? (string-trim-both str)))
-  (define (device? str)
-    (eqv? #\tab (string-ref str 0)))
-  (define (subvendor? str)
-    (string-prefix? "\t\t" str))
-  (define (class? str)
-    (string-prefix? "C " str))
-  (define (parse-id-line str)
-    (let* ((str   (string-trim-both str))
-           (space (string-index str char-set:whitespace)))
-      (values (string->number (string-take str space) 16)
-              (string-trim (string-drop str (+ 1 space))))))
-  (define (finish vendor vendor-id devices table)
-    (fold (lambda (device table)
-            (match device
-              ((device-id . name)
-               (vhash-consv (logior (ash vendor-id 16) device-id)
-                            (cons vendor name)
-                            table))))
-          table
-          devices))
-
-  (let loop ((table vlist-null)
-             (vendor-id #f)
-             (vendor #f)
-             (devices '()))
-    (match (read-line port)
-      ((? eof-object?)
-       (let ((table (if (and vendor vendor-id)
-                        (finish vendor vendor-id devices table)
-                        table)))
-         (lambda (vendor device)
-           (match (vhash-assv (logior (ash vendor 16) device) table)
-             (#f
-              (values #f #f))
-             ((_ . (vendor . name))
-              (values vendor name))))))
-      ((? comment?)
-       (loop table vendor-id vendor devices))
-      ((? blank?)
-       (loop table vendor-id vendor devices))
-      ((? subvendor?)                             ;currently ignored
-       (loop table vendor-id vendor devices))
-      ((? class?)                                 ;currently ignored
-       (loop table vendor-id vendor devices))
-      ((? device? line)
-       (let-values (((id name) (parse-id-line line)))
-         (loop table vendor-id vendor
-               (if (and vendor-id vendor)         ;class or device?
-                   (alist-cons id name devices)
-                   devices))))
-      (line
-       (let ((table (if (and vendor vendor-id)
-                        (finish vendor vendor-id devices table)
-                        table)))
-         (let-values (((vendor-id vendor) (parse-id-line line)))
-           (loop table vendor-id vendor '())))))))
-
-(define (load-pci-device-database file)
-  "Read the 'pci.ids' database at FILE (get it from the pciutils package or
-from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI
-vendor ID and a device ID (two integers) and returns the vendor name and
-device name as two values."
-  (let ((port (open-file file "r0")))
-    (call-with-gzip-input-port port
-      read-pci-device-database)))
-
 (define (device-module-aliases device)
  "Return the list of module aliases required by DEVICE, a /dev file name, as
 in this example:
@@ -1,7 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,26 +20,20 @@
 (define-module (gnu build marionette)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-64)
-  #:use-module (srfi srfi-71)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
-  #:use-module (ice-9 regex)
  #:export (marionette?
-            marionette-pid
            make-marionette
            marionette-eval
            wait-for-file
            wait-for-tcp-port
            wait-for-unix-socket
            marionette-control
+            marionette-screen-text
            wait-for-screen-text
            %qwerty-us-keystrokes
-            marionette-type
-
-            system-test-runner
-            qemu-command))
+            marionette-type))

 ;;; Commentary:
 ;;;
@@ -107,14 +100,11 @@ QEMU monitor and to the guest's backdoor REPL."
          "-monitor" (string-append "unix:" socket-directory "/monitor")
          "-chardev" (string-append "socket,id=repl,path=" socket-directory
                                    "/repl")
-          "-chardev" (string-append "socket,id=qga,server=on,wait=off,path="
-                                    socket-directory "/qemu-ga")

          ;; See
          ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
          "-device" "virtio-serial"
-          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"
-          "-device" "virtserialport,chardev=qga,name=org.qemu.guest_agent.0"))
+          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"))

  (define (accept* port)
    (match (select (list port) '() (list port) timeout)
@@ -179,18 +169,7 @@ QEMU monitor and to the guest's backdoor REPL."
    (($ <marionette> command pid monitor (= force repl))
     (write exp repl)
     (newline repl)
-     (with-exception-handler
-         (lambda (exn)
-           (simple-format
-            (current-error-port)
-            "error reading marionette response: ~A
-  remaining response: ~A\n"
-            exn
-            (get-line repl))
-           (raise-exception exn))
-       (lambda ()
-         (read repl))
-       #:unwind? #t))))
+     (read repl))))

 (define* (wait-for-file file marionette
                        #:key (timeout 10) (read 'read))
@@ -199,14 +178,7 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
  (match (marionette-eval
          `(let loop ((i ,timeout))
             (cond ((file-exists? ,file)
-                    (cons 'success
-                          (let ((content
-                                 (call-with-input-file ,file ,read)))
-                            (if (eof-object? content)
-                                ;; #<eof> can't be read, so convert to the
-                                ;; empty string
-                                ""
-                                content))))
+                    (cons 'success (call-with-input-file ,file ,read)))
                   ((> i 0)
                    (sleep 1)
                    (loop (- i 1)))
@@ -219,38 +191,31 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
     (error "file didn't show up" file))))

 (define* (wait-for-tcp-port port marionette
-                            #:key
-                            (timeout 20)
-                            (address `(make-socket-address AF_INET
-                                                           INADDR_LOOPBACK
-                                                           ,port)))
+                            #:key (timeout 20))
  "Wait for up to TIMEOUT seconds for PORT to accept connections in
-MARIONETTE.  ADDRESS must be an expression that returns a socket address,
-typically a call to 'make-socket-address'.  Raise an error on failure."
+MARIONETTE.  Raise an error on failure."
  ;; Note: The 'connect' loop has to run within the guest because, when we
  ;; forward ports to the host, connecting to the host never raises
  ;; ECONNREFUSED.
  (match (marionette-eval
-          `(let* ((address ,address)
-                  (sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
-             (let loop ((i 0))
-               (catch 'system-error
-                 (lambda ()
-                   (connect sock address)
-                   (close-port sock)
-                   'success)
-                 (lambda args
-                   (if (< i ,timeout)
-                       (begin
-                         (sleep 1)
-                         (loop (+ 1 i)))
-                       (list 'failure address))))))
+          `(begin
+             (let ((sock (socket PF_INET SOCK_STREAM 0)))
+               (let loop ((i 0))
+                 (catch 'system-error
+                   (lambda ()
+                     (connect sock AF_INET INADDR_LOOPBACK ,port)
+                     (close-port sock)
+                     'success)
+                   (lambda args
+                     (if (< i ,timeout)
+                         (begin
+                           (sleep 1)
+                           (loop (+ 1 i)))
+                         'failure))))))
          marionette)
    ('success #t)
-    (('failure address)
-     (error "nobody's listening on port"
-            (list (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
-                  (sockaddr:port address))))))
+    ('failure
+     (error "nobody's listening on port" port))))

 (define* (wait-for-unix-socket file-name marionette
                                #:key (timeout 20))
@@ -278,8 +243,8 @@ accept connections in MARIONETTE.  Raise an error on failure."

 (define (marionette-control command marionette)
  "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
-\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(QEMU) QEMU
-Monitor\")."
+\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
+pcsys_monitor\")."
  (match marionette
    (($ <marionette> _ _ monitor)
     (display command monitor)
@@ -287,87 +252,54 @@ Monitor\")."
     ;; The "quit" command terminates QEMU immediately, with no output.
     (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))

-(define* (invoke-ocrad-ocr image #:key (ocrad "ocrad"))
-  "Invoke the OCRAD command on image, and return the recognized text."
-  (let* ((pipe (open-pipe* OPEN_READ ocrad "-i" "-s" "10" image))
-         (text (get-string-all pipe)))
-    (unless (zero? (close-pipe pipe))
-      (error "'ocrad' failed" ocrad))
-    text))
+(define* (marionette-screen-text marionette
+                                 #:key
+                                 (ocrad "ocrad"))
+  "Take a screenshot of MARIONETTE, perform optical character
+recognition (OCR), and return the text read from the screen as a string.  Do
+this by invoking OCRAD (file name for GNU Ocrad's command)"
+  (define (random-file-name)
+    (string-append "/tmp/marionette-screenshot-"
+                   (number->string (random (expt 2 32)) 16)
+                   ".ppm"))

-(define* (invoke-tesseract-ocr image #:key (tesseract "tesseract"))
-  "Invoke the TESSERACT command on IMAGE, and return the recognized text."
-  (let* ((output-basename (tmpnam))
-         (output-basename* (string-append output-basename ".txt")))
+  (let ((image (random-file-name)))
    (dynamic-wind
      (const #t)
      (lambda ()
-        (let ((exit-val (status:exit-val
-                         (system* tesseract image output-basename))))
-          (unless (zero? exit-val)
-            (error "'tesseract' failed" tesseract))
-          (call-with-input-file output-basename* get-string-all)))
-      (lambda ()
-        (false-if-exception (delete-file output-basename))
-        (false-if-exception (delete-file output-basename*))))))
+        (marionette-control (string-append "screendump " image)
+                            marionette)

-(define* (marionette-screen-text marionette #:key (ocr "ocrad"))
-  "Take a screenshot of MARIONETTE, perform optical character
-recognition (OCR), and return the text read from the screen as a string, along
-the screen dump image used.  Do this by invoking OCR, which should be the file
-name of GNU Ocrad's@command{ocrad} or Tesseract OCR's @command{tesseract}
-command.  The screen dump image returned as the second value should be deleted
-if it is not needed."
-  (define image (string-append (tmpnam) ".ppm"))
-  ;; Use the QEMU Monitor to save an image of the screen to the host.
-  (marionette-control (string-append "screendump " image) marionette)
-  ;; Process it via the OCR.
-  (cond
-   ((string-contains ocr "ocrad")
-    (values (invoke-ocrad-ocr image #:ocrad ocr) image))
-   ((string-contains ocr "tesseract")
-    (values (invoke-tesseract-ocr image #:tesseract ocr) image))
-   (else (error "unsupported ocr command"))))
+        ;; Tell Ocrad to invert the image colors (make it black on white) and
+        ;; to scale the image up, which significantly improves the quality of
+        ;; the result.  In spite of this, be aware that OCR confuses "y" and
+        ;; "V" and sometimes erroneously introduces white space.
+        (let* ((pipe (open-pipe* OPEN_READ ocrad
+                                 "-i" "-s" "10" image))
+               (text (get-string-all pipe)))
+          (unless (zero? (close-pipe pipe))
+            (error "'ocrad' failed" ocrad))
+          text))
+      (lambda ()
+        (false-if-exception (delete-file image))))))

 (define* (wait-for-screen-text marionette predicate
-                               #:key
-                               (ocr "ocrad")
-                               (timeout 30)
-                               pre-action
-                               post-action)
+                               #:key (timeout 30) (ocrad "ocrad"))
  "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
-PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded.
-The error contains the recognized text along the preserved file name of the
-screen dump, which is relative to the current working directory.  If
-PRE-ACTION is provided, it should be a thunk to call before each OCR attempt.
-Likewise for POST-ACTION, except it runs at the end of a successful OCR."
+PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
  (define start
    (car (gettimeofday)))

  (define end
    (+ start timeout))

-  (let loop ((last-text #f)
-             (last-screendump #f))
+  (let loop ()
    (if (> (car (gettimeofday)) end)
-        (let ((screendump-backup (string-drop last-screendump 5)))
-          ;; Move the file from /tmp/fileXXXXXX.pmm to the current working
-          ;; directory, so that it is preserved in the test derivation output.
-          (copy-file last-screendump screendump-backup)
-          (delete-file last-screendump)
-          (error "'wait-for-screen-text' timeout"
-                 'ocr-text: last-text
-                 'screendump: screendump-backup))
-        (let* ((_ (and (procedure? pre-action) (pre-action)))
-               (text screendump (marionette-screen-text marionette #:ocr ocr))
-               (_ (and (procedure? post-action) (post-action)))
-               (result (predicate text)))
-          (cond (result
-                 (delete-file screendump)
-                 result)
-                (else
-                 (sleep 1)
-                 (loop text screendump)))))))
+        (error "'wait-for-screen-text' timeout" predicate)
+        (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
+            (begin
+              (sleep 1)
+              (loop))))))

 (define %qwerty-us-keystrokes
  ;; Maps "special" characters to their keystrokes.
@@ -389,10 +321,8 @@ Likewise for POST-ACTION, except it runs at the end of a successful OCR."
    (#\> . "shift-dot")
    (#\. . "dot")
    (#\, . "comma")
-    (#\: . "shift-semicolon")
    (#\; . "semicolon")
    (#\' . "apostrophe")
-    (#\! . "shift-1")
    (#\" . "shift-apostrophe")
    (#\` . "grave_accent")
    (#\bs . "backspace")
@@ -428,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
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 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.
@@ -47,52 +47,6 @@
         ;; to syslog.
         #'(format (current-output-port) fmt args ...))))))

-(define-syntax with-modules
-  (syntax-rules ()
-    "Dynamically load the given MODULEs at run time, making the chosen
-bindings available within the lexical scope of BODY."
-    ((_ ((module #:select (bindings ...)) rest ...) body ...)
-     (let* ((iface (resolve-interface 'module))
-            (bindings (module-ref iface 'bindings))
-            ...)
-       (with-modules (rest ...) body ...)))
-    ((_ () body ...)
-     (begin body ...))))
-
-(define (wait-for-readable-fd port timeout)
-  "Wait until PORT has data available for reading or TIMEOUT has expired.
-Return #t in the former case and #f in the latter case."
-  (match (resolve-module '(fibers) #f)            ;using Fibers?
-    (#f
-     (log "blocking on socket...~%")
-     (match (select (list port) '() '() timeout)
-       (((_) () ()) #t)
-       ((() () ())  #f)))
-    (fibers
-     ;; We're running on the Shepherd 0.9+ with Fibers.  Arrange to make a
-     ;; non-blocking wait so that other fibers can be scheduled in while we
-     ;; wait for PORT.
-     (with-modules (((fibers) #:select (spawn-fiber sleep))
-                    ((fibers channels)
-                     #:select (make-channel put-message get-message)))
-       ;; Make PORT non-blocking.
-       (let ((flags (fcntl port F_GETFL)))
-         (fcntl port F_SETFL (logior O_NONBLOCK flags)))
-
-       (let ((channel (make-channel)))
-         (spawn-fiber
-          (lambda ()
-            (sleep timeout)                       ;suspends the fiber
-            (put-message channel 'timeout)))
-         (spawn-fiber
-          (lambda ()
-            (lookahead-u8 port)                   ;suspends the fiber
-            (put-message channel 'readable)))
-         (log "suspending fiber on socket...~%")
-         (match (get-message channel)
-           ('readable #t)
-           ('timeout  #f)))))))
-
 (define* (secret-service-send-secrets port secret-root
                                      #:key (retry 60)
                                      (handshake-timeout 120))
@@ -119,11 +73,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
                files)))

  (log "sending secrets to ~a~%" port)
-  (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0))
-        (addr (make-socket-address AF_INET INADDR_LOOPBACK port))
-        (sleep (if (resolve-module '(fibers) #f)
-                   (module-ref (resolve-interface '(fibers)) 'sleep)
-                   sleep)))
+  (let ((sock (socket AF_INET SOCK_STREAM 0))
+        (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
    ;; Connect to QEMU on the forwarded port.  The 'connect' call succeeds as
    ;; soon as QEMU is ready, even if there's no server listening on the
    ;; forward port inside the guest.
@@ -142,31 +93,23 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return

    ;; Wait for "hello" message from the server.  This is the only way to know
    ;; that we're really connected to the server inside the guest.
-    (if (wait-for-readable-fd sock handshake-timeout)
-        (match (read sock)
-          (('secret-service-server ('version version ...))
-           (log "sending files from ~s...~%" secret-root)
-           (send-files sock)
-           (log "done sending files to port ~a~%" port)
-           (close-port sock)
-           secret-root)
-          (x
-           (log "invalid handshake ~s~%" x)
-           (close-port sock)
-           #f))
-        (begin                                    ;timeout
-         (log "timeout while sending files to ~a~%" port)
-         (close-port sock)
-         #f))))
-
-(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)))))
+    (match (select (list sock) '() '() handshake-timeout)
+      (((_) () ())
+       (match (read sock)
+         (('secret-service-server ('version version ...))
+          (log "sending files from ~s...~%" secret-root)
+          (send-files sock)
+          (log "done sending files to port ~a~%" port)
+          (close-port sock)
+          secret-root)
+         (x
+          (log "invalid handshake ~s~%" x)
+          (close-port sock)
+          #f)))
+      ((() () ())                                 ;timeout
+       (log "timeout while sending files to ~a~%" port)
+       (close-port sock)
+       #f))))

 (define (secret-service-receive-secrets port)
  "Listen to local PORT and wait for a secret service client to send secrets.
@@ -177,7 +120,7 @@ and #f otherwise."
    ;; Wait for a TCP connection on PORT.  Note: We cannot use the
    ;; virtio-serial ports, which would be safer, because they are
    ;; (presumably) unsupported on GNU/Hurd.
-    (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0)))
+    (let ((sock (socket AF_INET SOCK_STREAM 0)))
      (bind sock AF_INET INADDR_ANY port)
      (listen sock 1)
      (log "waiting for secrets on port ~a...~%" port)
@@ -227,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)
@@ -250,8 +187,4 @@ and #f otherwise."
      (close-port port))
    result))

-;;; Local Variables:
-;;; eval: (put 'with-modules 'scheme-indent-function 1)
-;;; End:
-
 ;;; secret-service.scm ends here
@@ -1,8 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
-;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,14 +24,7 @@
  #: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 (default-mounts
-            make-forkexec-constructor/container
+  #:export (make-forkexec-constructor/container
            fork+exec-command/container))

 ;;; Commentary:
@@ -101,18 +92,21 @@
                           (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. "
  (match (container-excursion* pid
           (lambda ()
-             ;; XXX: Trick for Shepherd 0.9: prevent 'read-pid-file' from
-             ;; using (@ (fibers) sleep), which would try to suspend the
-             ;; current task, which doesn't work in this extra process.
-             (with-continuation-barrier
-              (lambda ()
-                (read-pid-file pid-file
-                               #:max-delay max-delay)))))
+             (read-pid-file pid-file
+                            #:max-delay max-delay)))
    (#f
     ;; Send SIGTERM to the whole process group.
     (catch-system-error (kill (- pid) SIGTERM))
@@ -122,28 +116,6 @@ separate mount and PID name space.  Return the \"outer\" PID. "
     ;; PID is always 1, but that's not what Shepherd needs to know.
     pid)))

-(define* (exec-command* command #:key user group log-file pid-file
-                        (supplementary-groups '())
-                        (directory "/") (environment-variables (environ)))
-  "Like 'exec-command', but first restore signal handles modified by
-shepherd (PID 1)."
-  ;; First restore the default handlers.
-  (for-each (cut sigaction <> SIG_DFL) %precious-signals)
-
-  ;; Unblock any signals that have been blocked by the parent process.
-  (unblock-signals %precious-signals)
-
-  (mkdir-p "/var/run")
-  (clean-up pid-file)
-
-  (exec-command command
-                #:user user
-                #:group group
-                #:supplementary-groups supplementary-groups
-                #:log-file log-file
-                #:directory directory
-                #:environment-variables environment-variables))
-
 (define* (make-forkexec-constructor/container command
                                              #:key
                                              (namespaces
@@ -151,7 +123,6 @@ shepherd (PID 1)."
                                              (mappings '())
                                              (user #f)
                                              (group #f)
-                                              (supplementary-groups '())
                                              (log-file #f)
                                              pid-file
                                              (pid-file-timeout 5)
@@ -187,7 +158,7 @@ namespace, in addition to essential bind-mounts such /proc."
    (when log-file
      ;; Create LOG-FILE so we can map it in the container.
      (unless (file-exists? log-file)
-        (close (open log-file (logior O_CREAT O_APPEND O_CLOEXEC) #o640))
+        (call-with-output-file log-file (const #t))
        (when user
          (let ((pw (getpwnam user)))
            (chown log-file (passwd:uid pw) (passwd:gid pw))))))
@@ -195,16 +166,24 @@ namespace, in addition to essential bind-mounts such /proc."
    (let ((pid (run-container container-directory
                              mounts namespaces 1
                              (lambda ()
-                                (exec-command* command
-                                               #:user user
-                                               #:group group
-                                               #:supplementary-groups
-                                               supplementary-groups
-                                               #:pid-file pid-file
-                                               #:log-file log-file
-                                               #:directory directory
-                                               #:environment-variables
-                                               environment-variables)))))
+                                ;; First restore the default handlers.
+                                (for-each (cut sigaction <> SIG_DFL)
+                                          %precious-signals)
+
+                                ;; Unblock any signals that have been blocked
+                                ;; by the parent process.
+                                (unblock-signals %precious-signals)
+
+                                (mkdir-p "/var/run")
+                                (clean-up pid-file)
+
+                                (exec-command command
+                                              #:user user
+                                              #:group group
+                                              #:log-file log-file
+                                              #:directory directory
+                                              #:environment-variables
+                                              environment-variables)))))
      (if pid-file
          (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
              (read-pid-file/container pid pid-file
@@ -232,24 +211,14 @@ on Hurd systems for instance, fallback to direct forking."
        ((head . rest)
         (loop rest (cons head result))))))

-  (let ((container-support? (file-exists? "/proc/self/ns")))
-    (if (and container-support?
-             (not (and pid (= pid (getpid)))))
-        (container-excursion* pid
-          (lambda ()
-            ;; Note: In the Shepherd 0.9, 'fork+exec-command' expects to be
-            ;; called from the shepherd process (because it creates a pipe to
-            ;; capture stdout/stderr and spawns a logging fiber) so we cannot
-            ;; use it here.
-            (match (primitive-fork)
-              (0 (dynamic-wind
-                   (const #t)
-                   (lambda ()
-                     (apply exec-command* command (strip-pid args)))
-                   (lambda ()
-                     (primitive-_exit 127))))
-              (pid pid))))               ;XXX: assuming the same PID namespace
-        (apply fork+exec-command command (strip-pid args)))))
+  (let ((container-support?
+         (file-exists? "/proc/self/ns"))
+        (fork-proc (lambda ()
+                     (apply fork+exec-command command
+                            (strip-pid args)))))
+    (if container-support?
+        (container-excursion* pid fork-proc)
+        (fork-proc))))

 ;; Local Variables:
 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)
@@ -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
@@ -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 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
@@ -21,16 +21,17 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

 (define-module (gnu ci)
-  #:use-module (guix build-system channel)
+  #:use-module (guix channels)
  #:use-module (guix config)
-  #:autoload   (guix describe) (package-channels)
+  #:use-module (guix describe)
  #:use-module (guix store)
+  #:use-module (guix grafts)
  #:use-module (guix profiles)
  #:use-module (guix packages)
-  #:autoload   (guix transformations) (tunable-package? tuned-package)
  #:use-module (guix channels)
  #:use-module (guix config)
  #:use-module (guix derivations)
+  #:use-module (guix build-system)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix ui)
@@ -39,10 +40,9 @@
  #:use-module ((guix utils) #:select (%current-system))
  #:use-module ((guix scripts system) #:select (read-operating-system))
  #:use-module ((guix scripts pack)
-                #:select (self-contained-tarball))
+                #:select (lookup-compressor self-contained-tarball))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
-  #:use-module (gnu compression)
  #:use-module (gnu image)
  #:use-module (gnu packages)
  #:use-module (gnu packages gcc)
@@ -54,7 +54,6 @@
  #:use-module (gnu packages multiprecision)
  #:use-module (gnu packages make-bootstrap)
  #:use-module (gnu packages package-management)
-  #:use-module (guix platform)
  #:use-module (gnu system)
  #:use-module (gnu system image)
  #:use-module (gnu system vm)
@@ -71,6 +70,8 @@
            image->job

            %core-packages
+            %cross-targets
+            channel-source->package

            arguments->systems
            cuirass-jobs))
@@ -84,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
@@ -106,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
@@ -128,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)))
@@ -137,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)
@@ -147,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.
@@ -167,6 +155,17 @@ SYSTEM."
      (drop-right %core-packages 6)
      %core-packages))

+(define %cross-targets
+  '("mips64el-linux-gnu"
+    "arm-linux-gnueabihf"
+    "aarch64-linux-gnu"
+    "powerpc-linux-gnu"
+    "powerpc64le-linux-gnu"
+    "riscv64-linux-gnu"
+    "i586-pc-gnu"                                 ;aka. GNU/Hurd
+    "i686-w64-mingw32"
+    "x86_64-w64-mingw32"))
+
 (define (cross-jobs store system)
  "Return a list of cross-compilation jobs for SYSTEM."
  (define (from-32-to-64? target)
@@ -208,7 +207,7 @@ SYSTEM."
                                          package target system))
                     (packages-to-cross-build target)))
              (remove (either from-32-to-64? same? pointless?)
-                      (targets))))
+                      %cross-targets)))

 (define* (guix-jobs store systems #:key source commit)
  "Return a list of jobs for Guix itself."
@@ -251,44 +250,81 @@ otherwise use the IMAGE name."
         (drv (run-with-store store
                (mbegin %store-monad
                  (set-guile-for-build (default-guile))
-                  (lower-object (system-image image) system)))))
+                  (lower-object (system-image image))))))
    (parameterize ((%graft? #f))
      (derivation->job name drv))))

-(define* (image-jobs store system
-                     #:key source commit)
+(define (image-jobs store system)
  "Return a list of jobs that build images for SYSTEM."
  (define MiB
    (expt 2 20))

-  (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
-    (if (member system %guix-system-supported-systems)
-        `(,(image->job store
-                       (image
-                        (inherit efi-disk-image)
-                        (operating-system installation-os))
-                       #:name "usb-image"
-                       #:system system)
-          ,(image->job
-            store
-            (image
-             (inherit (image-with-label
-                       iso9660-image
-                       (string-append "GUIX_" system "_"
-                                      (if (> (string-length %guix-version) 7)
-                                          (substring %guix-version 0 7)
-                                          %guix-version))))
-             (operating-system installation-os))
-            #:name "iso9660-image"
-            #:system system)
-          ;; Only cross-compile Guix System images from x86_64-linux for now.
-          ,@(if (string=? system "x86_64-linux")
-                (map (cut image->job store <>
-                          #:system system)
-                     %guix-system-images)
-                '()))
-        '())))
+  (if (member system %guix-system-supported-systems)
+      `(,(image->job store
+                     (image
+                      (inherit efi-disk-image)
+                      (operating-system installation-os))
+                     #:name "usb-image"
+                     #:system system)
+        ,(image->job
+          store
+          (image
+           (inherit (image-with-label
+                     iso9660-image
+                     (string-append "GUIX_" system "_"
+                                    (if (> (string-length %guix-version) 7)
+                                        (substring %guix-version 0 7)
+                                        %guix-version))))
+           (operating-system installation-os))
+          #:name "iso9660-image"
+          #:system system)
+        ;; Only cross-compile Guix System images from x86_64-linux for now.
+        ,@(if (string=? system "x86_64-linux")
+              (map (cut image->job store <>
+                        #:system system)
+                   %guix-system-images)
+              '()))
+      '()))
+
+(define channel-build-system
+  ;; Build system used to "convert" a channel instance to a package.
+  (let* ((build (lambda* (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
+                    (name name)
+                    (system system)
+                    (build build)
+                    (arguments `(#:source ,source
+                                 #:commit ,commit))))))
+    (build-system (name 'channel)
+                  (description "Turn a channel instance into a package.")
+                  (lower lower))))
+
+(define* (channel-source->package source #:key commit)
+  "Return a package for the given channel SOURCE, a lowerable object."
+  (package
+    (inherit guix)
+    (version (string-append (package-version guix) "+"))
+    (build-system channel-build-system)
+    (arguments `(#:source ,source
+                 #:commit ,commit))
+    (inputs '())
+    (native-inputs '())
+    (propagated-inputs '())))

 (define* (system-test-jobs store system
                           #:key source commit)
@@ -350,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)
@@ -416,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."
@@ -500,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.
@@ -517,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.
@@ -531,9 +522,7 @@ names."
                               hello system))))
         ('images
          ;; Build Guix System images only.
-          (image-jobs store system
-                      #:source source
-                      #:commit commit))
+          (image-jobs store system))
         ('system-tests
          ;; Build Guix System tests only.
          (system-test-jobs store system
@@ -570,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)))
@@ -1,69 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu compression)
-  #:use-module (guix gexp)
-  #:use-module (guix ui)
-  #:use-module ((gnu packages compression) #:hide (zip))
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (ice-9 match)
-  #:export (compressor
-            compressor?
-            compressor-name
-            compressor-extension
-            compressor-command
-            %compressors
-            lookup-compressor))
-
-;; Type of a compression tool.
-(define-record-type <compressor>
-  (compressor name extension command)
-  compressor?
-  (name       compressor-name)      ;string (e.g., "gzip")
-  (extension  compressor-extension) ;string (e.g., ".lz")
-  (command    compressor-command))  ;gexp (e.g., #~(list "/gnu/store/…/gzip"
-                                    ;                    "-9n" ))
-
-(define %compressors
-  ;; Available compression tools.
-  (list (compressor "gzip"  ".gz"
-                    #~(list #+(file-append gzip "/bin/gzip") "-9n"))
-        (compressor "lzip"  ".lz"
-                    #~(list #+(file-append lzip "/bin/lzip") "-9"))
-        (compressor "xz"    ".xz"
-                    #~(append (list #+(file-append xz "/bin/xz")
-                                    "-e")
-                              (%xz-parallel-args)))
-        (compressor "bzip2" ".bz2"
-                    #~(list #+(file-append bzip2 "/bin/bzip2") "-9"))
-        (compressor "zstd" ".zst"
-                    ;; The default level 3 compresses better than gzip in a
-                    ;; fraction of the time, while the highest level 19
-                    ;; (de)compresses more slowly and worse than xz.
-                    #~(list #+(file-append zstd "/bin/zstd") "-3"))
-        (compressor "none" "" #f)))
-
-(define (lookup-compressor name)
-  "Return the compressor object called NAME.  Error out if it could not be
-found."
-  (or (find (match-lambda
-              (($ <compressor> name*)
-               (string=? name* name)))
-            %compressors)
-      (leave (G_ "~a: compressor not found~%") name)))
@@ -1,138 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; 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)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 regex)
-  #: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
-
-            home-generation-base))
-
-;;; 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 home environment."
-  (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)))))
-
-(define %profile-generation-rx
-  ;; Regexp that matches profile generation.
-  (make-regexp "(.*)-([0-9]+)-link$"))
-
-(define (home-generation-base file)
-  "If FILE is a Home generation GC root such as \"guix-home-42-link\",
-return its corresponding base---e.g., \"guix-home\".  Otherwise return #f.
-
-This is similar to the 'generation-profile' procedure but applied to Home
-generations."
-  (match (regexp-exec %profile-generation-rx file)
-    (#f #f)
-    (m  (let ((profile (match:substring m 1)))
-          ;; Distinguish from a "real" profile and from a system generation.
-          (and (file-exists? (string-append profile "/on-first-login"))
-               (file-exists? (string-append profile "/profile/manifest"))
-               profile)))))
@@ -1,649 +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 ((gnu packages base) #:select (coreutils))
-  #: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)
-  #:use-module (ice-9 vlist)
-
-  #:export (home-service-type
-            home-profile-service-type
-            home-environment-variables-service-type
-            home-files-service-type
-            home-xdg-configuration-files-service-type
-            home-xdg-data-files-service-type
-            home-run-on-first-login-service-type
-            home-activation-service-type
-            home-run-on-change-service-type
-            home-provenance-service-type
-
-            environment-variable-shell-definitions
-            home-files-directory
-            xdg-configuration-files-directory
-            xdg-data-files-directory
-
-            fold-home-service-types
-            lookup-home-service-types
-            home-provenance
-
-            %initialize-gettext)
-
-  #: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-variable-shell-definitions variables)
-  "Return a gexp that evaluates to a list of POSIX shell statements defining
-VARIABLES, a list of environment variable name/value pairs.  The returned code
-ensures variable values are properly quoted."
-  #~(let ((shell-quote
-           (lambda (value)
-             ;; Double-quote VALUE, leaving dollar sign as is.
-             (let ((quoted (list->string
-                            (string-fold-right
-                             (lambda (chr lst)
-                               (case chr
-                                 ((#\" #\\)
-                                  (append (list chr #\\) lst))
-                                 (else (cons chr lst))))
-                             '()
-                             value))))
-               (string-append "\"" quoted "\"")))))
-      (string-append
-       #$@(map (match-lambda
-                 ((key . #f)
-                  "")
-                 ((key . #t)
-                  #~(string-append "export " #$key "\n"))
-                 ((key . value)
-                  #~(string-append "export " #$key "="
-                                   (shell-quote #$value) "\n")))
-               variables))))
-
-(define (environment-variables->setup-environment-script vars)
-  "Return a file that can be sourced by a POSIX compliant shell which
-initializes the environment.  The file will source the home
-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-definitions)
-    (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-definitions)
-  (with-monad
-   %store-monad
-   (return
-    `(("setup-environment"
-       ;; TODO: It's necessary to source ~/.guix-profile too
-       ;; on foreign distros
-       ,(computed-file "setup-environment"
-                       #~(call-with-output-file #$output
-                           (lambda (port)
-                             (set-port-encoding! port "UTF-8")
-                             (display "\
-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
-
-" port)
-                             (display
-                              #$(environment-variable-shell-definitions vars)
-                              port)))))))))
-
-(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-xdg-configuration)
-                (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 xdg-data-files-directory ".local/share")
-
-(define (xdg-data-files files)
-  "Add .local/share prefix to each file-path in FILES."
-  (map (match-lambda
-         ((file-path . rest)
-          (cons (string-append xdg-data-files-directory "/" file-path)
-                rest)))
-         files))
-
-(define home-xdg-data-files-service-type
-  (service-type (name 'home-xdg-data)
-                (extensions
-                 (list (service-extension home-files-service-type
-                                          xdg-data-files)))
-                (compose concatenate)
-                (extend append)
-                (default-value '())
-                (description "Files that will be put in
-@file{~~/.guix-home/files/.local/share}, and further processed during
-activation.")))
-
-
-(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)
-                                                   (guix diagnostics)))
-     #~(begin
-         (use-modules (guix i18n)
-                      (guix diagnostics))
-       #$%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
-             (warning (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
-                          ;; Absolute path of the directory of the activation
-                          ;; file if called interactively.
-                          (canonicalize-path (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 && ~a -0"
-                                   (he-init-file new-home)
-                                   #$(file-append coreutils "/bin/env"))))
-                  (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)))
-
-(define lookup-home-service-types
-  (let ((table
-         (delay (fold-home-service-types (lambda (type result)
-                                           (vhash-consq (service-type-name type)
-                                                        type result))
-                                         vlist-null))))
-    (lambda (name)
-      "Return the list of services with the given NAME (a symbol)."
-      (vhash-foldq* cons '() name (force table)))))
@@ -1,228 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2022 ( <paren@disroot.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; 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 glib)    (dbus)
-  #: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
-
-            home-dbus-configuration
-            home-dbus-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
-   "Daytime screen brightness, between 0.1 and 1.0.")
-  (nighttime-brightness
-   maybe-inexact-number
-   "Nighttime screen brightness, between 0.1 and 1.0.")
-
-  (latitude
-   maybe-inexact-number
-   "Latitude, when @code{location-provider} is @code{'manual}.")
-  (longitude
-   maybe-inexact-number
-   "Longitude, when @code{location-provider} is @code{'manual}.")
-
-  (dawn-time
-   maybe-string
-   "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
-   "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))
-         (actions (list (shepherd-configuration-action config-file))))))
-
-(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.")))
-
-
-;;;
-;;; D-Bus.
-;;;
-
-(define-record-type* <home-dbus-configuration>
-  home-dbus-configuration make-home-dbus-configuration
-  home-dbus-configuration?
-  (dbus home-dbus-dbus                  ;file-like
-        (default dbus)))
-
-(define (home-dbus-shepherd-services config)
-  (list (shepherd-service
-         (documentation "Run the D-Bus daemon in session-specific mode.")
-         (provision '(dbus))
-         (start #~(make-forkexec-constructor
-                   (list #$(file-append (home-dbus-dbus config)
-                                        "/bin/dbus-daemon")
-                         "--nofork" "--session"
-                         (format #f "--address=unix:path=~a/bus"
-                                 (or (getenv "XDG_RUNTIME_DIR")
-                                     (format #f "/run/user/~a"
-                                             (getuid)))))
-                   #:environment-variables
-                   (cons "DBUS_VERBOSE=1"
-                         (default-environment-variables))
-                   #:log-file
-                   (format #f "~a/dbus.log"
-                           (or (getenv "XDG_LOG_HOME")
-                               (format #f "~a/.local/var/log"
-                                       (getenv "HOME"))))))
-         (stop #~(make-kill-destructor)))))
-
-(define (home-dbus-environment-variables config)
-  '(("DBUS_SESSION_BUS_ADDRESS"
-     . "unix:path=${XDG_RUNTIME_DIR:-/run/user/$UID}/bus")))
-
-(define home-dbus-service-type
-  (service-type
-   (name 'home-dbus)
-   (extensions
-    (list (service-extension home-shepherd-service-type
-                             home-dbus-shepherd-services)
-          (service-extension home-environment-variables-service-type
-                             home-dbus-environment-variables)))
-   (default-value (home-dbus-configuration))
-   (description
-    "Run the session-specific D-Bus inter-process message bus.")))
@@ -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.")))
@@ -1,44 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Reily Siegel <mail@reilysiegel.com>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu home services guix)
-  #:use-module (gnu home services)
-  #:use-module (guix channels)
-  #:use-module (guix gexp)
-  #:use-module (ice-9 pretty-print)
-  #:use-module (srfi srfi-1)
-  #:export (home-channels-service-type))
-
-(define (channels-xdg-files channels)
-  `(("guix/channels.scm"
-     ,(plain-file
-       "channels.scm"
-       (call-with-output-string
-         (lambda (port)
-           (pretty-print (cons 'list (map channel->code channels)) port)))))))
-
-(define home-channels-service-type
-  (service-type
-   (name 'home-channels)
-   (default-value %default-channels)
-   (compose concatenate)
-   (extend append)
-   (extensions
-    (list (service-extension home-xdg-configuration-files-service-type
-                             channels-xdg-files)))
-   (description "Manages the per-user Guix channels specification.")))
@@ -1,140 +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 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/>.
-
-(define-module (gnu home services mcron)
-  #:use-module (gnu packages guile-xyz)
-  #:use-module (gnu home services)
-  #:use-module (gnu services configuration)
-  #:use-module (gnu services shepherd)
-  #:use-module (gnu home services shepherd)
-  #:use-module (guix records)
-  #: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 list-of-gexps?
-  (list-of gexp?))
-
-(define-configuration/no-serialization home-mcron-configuration
-  (mcron (file-like mcron) "The mcron package to use.")
-  (jobs
-   (list-of-gexps '())
-   "This is a list of gexps (@pxref{G-Expressions}), where each gexp
-corresponds to an mcron job specification (@pxref{Syntax, mcron job
-specifications,, mcron, GNU@tie{}mcron}).")
-  (log? (boolean #t) "Log messages to standard output.")
-  (log-format
-   (string "~1@*~a ~a: ~a~%")
-   "@code{(ice-9 format)} format string for log messages.  The default value
-produces messages like \"@samp{@var{pid} @var{name}:
-@var{message}\"} (@pxref{Invoking mcron, Invoking,, mcron, GNU@tie{}mcron}).
-Each message is also prefixed by a timestamp by GNU Shepherd."))
-
-(define job-files (@@ (gnu services mcron) job-files))
-(define shepherd-schedule-action
-  (@@ (gnu services mcron) shepherd-schedule-action))
-
-(define (home-mcron-shepherd-services config)
-  (match-record config <home-mcron-configuration>
-    (mcron jobs log? log-format)
-    (if (null? jobs)
-        '()                                       ;no jobs to run
-        (let ((files (job-files mcron jobs)))
-          (list (shepherd-service
-                 (documentation "User cron jobs.")
-                 (provision '(mcron))
-                 (modules `((srfi srfi-1)
-                            (srfi srfi-26)
-                            (ice-9 popen)         ;for the 'schedule' action
-                            (ice-9 rdelim)
-                            (ice-9 match)
-                            ,@%default-modules))
-                 (start #~(make-forkexec-constructor
-                           (list (string-append #$mcron "/bin/mcron")
-                                 #$@(if log?
-                                        #~("--log" "--log-format" #$log-format)
-                                        #~())
-                                 #$@files)
-                           #:log-file (string-append
-                                       (or (getenv "XDG_LOG_HOME")
-                                           (format #f "~a/.local/var/log"
-                                                   (getenv "HOME")))
-                                       "/mcron.log")))
-                 (stop #~(make-kill-destructor))
-                 (actions
-                  (list (shepherd-schedule-action mcron files)))))))))
-
-(define home-mcron-profile (compose list home-mcron-configuration-mcron))
-
-(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.")))
-
-
-;;;
-;;; Generate documentation.
-;;;
-(define (generate-doc)
-  (configuration->documentation 'home-mcron-configuration))
-
-;;; mcron.scm ends here
@@ -1,145 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 ( <paren@disroot.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu home services pm)
-  #:use-module (guix gexp)
-  #:use-module (guix packages)
-  #:use-module (guix records)
-  #:use-module (gnu home services)
-  #:use-module (gnu home services shepherd)
-  #:use-module (gnu packages monitoring)
-  #:use-module (gnu services shepherd)
-
-  #:export (home-batsignal-configuration
-            home-batsignal-service-type))
-
-;;;
-;;; batsignal
-;;;
-;;; Daemon for running commands and displaying notifications on
-;;; battery events.
-;;;
-
-(define-record-type* <home-batsignal-configuration>
-  home-batsignal-configuration make-home-batsignal-configuration
-  home-batsignal-configuration?
-  (warning-level batsignal-warning-level                    ;integer
-                 (default 15))
-  (warning-message batsignal-warning-message                ;string | #f
-                   (default #f))
-  (critical-level batsignal-critical-level                  ;integer
-                 (default 5))
-  (critical-message batsignal-critical-message              ;string | #f
-                    (default #f))
-  (danger-level batsignal-danger-level                      ;integer
-                (default 2))
-  (danger-command batsignal-danger-command                  ;file-like | string | #f
-                  (default #f))
-  (full-level batsignal-full-level                          ;integer | #f
-              (default #f))
-  (full-message batsignal-full-message                      ;string | #f
-                (default #f))
-  (batteries batsignal-batteries                            ;list of string
-             (default '()))
-  (poll-delay batsignal-poll-delay                          ;integer
-              (default 60))
-  (icon batsignal-icon                                      ;file-like | #f
-        (default #f))
-  (notifications? batsignal-notifications?                  ;boolean
-                  (default #t))
-  (notifications-expire? batsignal-notifications-expire?    ;boolean
-                         (default #f))
-  (notification-command batsignal-notification-command      ;string | #f
-                        (default #f))
-  (ignore-missing? batsignal-ignore-missing?                ;boolean
-                   (default #f)))
-
-(define (home-batsignal-shepherd-services config)
-  (let ((warning-level (batsignal-warning-level config))
-        (warning-message (batsignal-warning-message config))
-        (critical-level (batsignal-critical-level config))
-        (critical-message (batsignal-critical-message config))
-        (danger-level (batsignal-danger-level config))
-        (danger-command (batsignal-danger-command config))
-        (full-level (batsignal-full-level config))
-        (full-message (batsignal-full-message config))
-        (batteries (batsignal-batteries config))
-        (poll-delay (batsignal-poll-delay config))
-        (icon (batsignal-icon config))
-        (notifications? (batsignal-notifications? config))
-        (notifications-expire? (batsignal-notifications-expire? config))
-        (notification-command (batsignal-notification-command config))
-        (ignore-missing? (batsignal-ignore-missing? config)))
-    (list (shepherd-service
-           (provision '(batsignal))
-           (documentation "Run the batsignal battery-watching daemon.")
-           (start #~(make-forkexec-constructor
-                     (append (list #$(file-append batsignal "/bin/batsignal")
-                                   "-w" (number->string #$warning-level)
-                                   "-c" (number->string #$critical-level)
-                                   "-d" (number->string #$danger-level)
-                                   "-m" (number->string #$poll-delay))
-                             (if #$warning-message
-                                 (list "-W" #$warning-message)
-                                 (list))
-                             (if #$critical-message
-                                 (list "-C" #$critical-message)
-                                 (list))
-                             (if #$danger-command
-                                 (list "-D" #$danger-command)
-                                 (list))
-                             (if #$full-level
-                                 (list "-f" (number->string #$full-level))
-                                 (list))
-                             (if #$full-message
-                                 (list "-F" #$full-message)
-                                 (list))
-                             (if (null? (list #$@batteries))
-                                 (list)
-                                 (list "-n" (string-join (list #$@batteries) ",")))
-                             (if #$icon
-                                 (list "-I" #$icon)
-                                 (list))
-                             (if #$notifications?
-                                 (list)
-                                 (list "-N"))
-                             (if #$notifications-expire?
-                                 (list "-e")
-                                 (list))
-                             (if #$notification-command
-                                 (list "-M" #$notification-command)
-                                 (list))
-                             (if #$ignore-missing?
-                                 (list "-i")
-                                 (list)))
-                     #:log-file (string-append
-                                 (or (getenv "XDG_LOG_HOME")
-                                     (format #f "~a/.local/var/log"
-                                               (getenv "HOME")))
-                                 "/batsignal.log")))
-           (stop #~(make-kill-destructor))))))
-
-(define home-batsignal-service-type
-  (service-type
-   (name 'home-batsignal)
-   (extensions
-    (list (service-extension home-shepherd-service-type
-                             home-batsignal-shepherd-services)))
-   (default-value (home-batsignal-configuration))
-   (description
-    "Run batsignal, a battery watching and notification daemon.")))
@@ -1,690 +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 (guix records)
-  #: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)
-  (environment-variable-shell-definitions 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"
-   "\
-# Set up the system, user profile, and related variables.
-source /etc/profile
-# Set up the 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 (or (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 (add-zsh-dot-configuration 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 (add-zsh-xdg-configuration 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
-                        add-zsh-dot-configuration)
-                       (service-extension
-                        home-xdg-configuration-files-service-type
-                        add-zsh-xdg-configuration)
-                       (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))))
-          `(,(string-append "." (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"
-        "\
-# Set up the system, user profile, and related variables.
-# /etc/profile will be sourced by bash automatically
-# Set up the 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-record original-config <home-bash-configuration>
-    (environment-variables aliases bash-profile bashrc bash-logout)
-    (home-bash-configuration
-     (inherit original-config)
-     (environment-variables
-      (append environment-variables
-              (append-map
-               home-bash-extension-environment-variables extension-configs)))
-     (aliases
-      (append aliases
-              (append-map
-               home-bash-extension-aliases extension-configs)))
-     (bash-profile
-      (append bash-profile
-              (append-map
-               home-bash-extension-bash-profile extension-configs)))
-     (bashrc
-      (append bashrc
-              (append-map
-               home-bash-extension-bashrc extension-configs)))
-     (bash-logout
-      (append bash-logout
-              (append-map
-               home-bash-extension-bash-logout extension-configs))))))
-
-(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 -x " #$key "\n"))
-               ((key . value)
-                #~(string-append "set -x " #$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)
-  `(("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-xdg-configuration-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)))
@@ -1,170 +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
-               shepherd-configuration-action))
-
-(define-record-type* <home-shepherd-configuration>
-  home-shepherd-configuration make-home-shepherd-configuration
-  home-shepherd-configuration?
-  (shepherd home-shepherd-configuration-shepherd
-            (default shepherd-0.9)) ; package
-  (auto-start? home-shepherd-configuration-auto-start?
-               (default #t))
-  (daemonize? home-shepherd-configuration-daemonize?
-              (default #t))
-  (services home-shepherd-configuration-services
-            (default '())))
-
-(define (home-shepherd-configuration-file config)
-  "Return the shepherd configuration file for SERVICES.  SHEPHERD is used
-as shepherd package."
-  (let* ((daemonize? (home-shepherd-configuration-daemonize? config))
-         (services (home-shepherd-configuration-services config))
-         (_ (assert-valid-graph services))
-         (files (map shepherd-service-file services))
-         ;; TODO: Add compilation of services, it can improve start
-         ;; time.
-         ;; (scm->go (cute scm->go <> shepherd))
-         )
-    (define config
-      #~(begin
-          (use-modules (srfi srfi-34)
-                       (system repl error-handling))
-          (apply
-           register-services
-           (map
-            (lambda (file) (load file))
-            '#$files))
-
-          #$@(if daemonize?
-                 `((action 'root 'daemonize))
-                 '())
-
-          (format #t "Starting services...~%")
-          (let ((services-to-start
-                 '#$(append-map shepherd-service-provision
-                                (filter shepherd-service-auto-start?
-                                        services))))
-            (if (defined? 'start-in-the-background)
-                (start-in-the-background services-to-start)
-                (for-each start services-to-start))
-
-            (redirect-port (open-input-file "/dev/null")
-                           (current-input-port)))))
-
-    (scheme-file "shepherd.conf" config)))
-
-(define (launch-shepherd-gexp config)
-  (let* ((shepherd (home-shepherd-configuration-shepherd config)))
-    (if (home-shepherd-configuration-auto-start? config)
-        (with-imported-modules '((guix build utils))
-          #~(unless (file-exists?
-                     (string-append
-                      (or (getenv "XDG_RUNTIME_DIR")
-                          (format #f "/run/user/~a" (getuid)))
-                      "/shepherd/socket"))
-              (let ((log-dir (or (getenv "XDG_LOG_HOME")
-                                 (format #f "~a/.local/var/log"
-                                         (getenv "HOME")))))
-                ;; TODO: Remove it, 0.9.2 creates it automatically?
-                ((@ (guix build utils) mkdir-p) log-dir)
-                (system*
-                 #$(file-append shepherd "/bin/shepherd")
-                 "--logfile"
-                 (string-append log-dir "/shepherd.log")
-                 "--config"
-                 #$(home-shepherd-configuration-file config)))))
-        #~"")))
-
-(define (reload-configuration-gexp config)
-  (let* ((shepherd (home-shepherd-configuration-shepherd config)))
-    #~(system*
-       #$(file-append shepherd "/bin/herd")
-       "load" "root"
-       #$(home-shepherd-configuration-file config))))
-
-(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 (shepherd-xdg-configuration-files config)
-  `(("shepherd/init.scm" ,(home-shepherd-configuration-file config))))
-
-(define-public home-shepherd-service-type
-  (service-type (name 'home-shepherd)
-                (extensions
-                 (list (service-extension
-                        home-run-on-first-login-service-type
-                        launch-shepherd-gexp)
-                       (service-extension
-                        home-xdg-configuration-files-service-type
-                        shepherd-xdg-configuration-files)
-                       (service-extension
-                        home-activation-service-type
-                        ensure-shepherd-gexp)
-                       (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.")))
-
-
@@ -1,256 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu home services ssh)
-  #:use-module (guix gexp)
-  #:use-module (guix records)
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
-  #:use-module (gnu services)
-  #:use-module (gnu services configuration)
-  #:use-module (guix modules)
-  #:use-module (gnu home services)
-  #:use-module ((gnu home services utils)
-                #:select (object->camel-case-string))
-  #:autoload   (gnu packages base) (glibc-utf8-locales)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
-  #:use-module (ice-9 match)
-  #:export (home-openssh-configuration
-            home-openssh-configuration-authorized-keys
-            home-openssh-configuration-known-hosts
-            home-openssh-configuration-hosts
-
-            openssh-host
-            openssh-host-host-name
-            openssh-host-identity-file
-            openssh-host-name
-            openssh-host-port
-            openssh-host-user
-            openssh-host-forward-x11?
-            openssh-host-forward-x11-trusted?
-            openssh-host-forward-agent?
-            openssh-host-compression?
-            openssh-host-proxy-command
-            openssh-host-host-key-algorithms
-            openssh-host-accepted-key-types
-            openssh-host-extra-content
-
-            home-openssh-service-type))
-
-(define (serialize-field-name name)
-  (match name
-    ('accepted-key-types "PubkeyAcceptedKeyTypes")
-    (_
-     (let ((name (let ((str (symbol->string name)))
-                   (if (string-suffix? "?" str)
-                       (string->symbol (string-drop-right str 1))
-                       name))))
-       (object->camel-case-string name 'upper)))))
-
-(define (serialize-string field value)
-  (string-append "  " (serialize-field-name field)
-                 " " value "\n"))
-
-(define (address-family? obj)
-  (memv obj (list AF_INET AF_INET6)))
-
-(define-maybe address-family)
-
-(define (serialize-address-family field family)
-  (if (maybe-value-set? family)
-      (string-append "  " (serialize-field-name field) " "
-                     (cond ((= family AF_INET) "inet")
-                           ((= family AF_INET6) "inet6")
-                           ;; The 'else' branch is unreachable.
-                           (else (raise (condition (&error)))))
-                     "\n")
-      ""))
-
-(define (natural-number? obj)
-  (and (integer? obj) (exact? obj) (> obj 0)))
-
-(define (serialize-natural-number field value)
-  (string-append "  " (serialize-field-name field) " "
-                 (number->string value) "\n"))
-
-(define (serialize-boolean field value)
-  (string-append "  " (serialize-field-name field) " "
-                 (if value "yes" "no") "\n"))
-
-(define-maybe string)
-(define-maybe natural-number)
-
-(define (serialize-raw-configuration-string field value)
-  (string-append value "\n"))
-(define raw-configuration-string? string?)
-
-(define (string-list? lst)
-  (and (pair? lst) (every string? lst)))
-(define (serialize-string-list field lst)
-  (string-append "  " (serialize-field-name field) " "
-                 (string-join lst ",") "\n"))
-
-(define-maybe string-list)
-
-(define-configuration openssh-host
-  (name
-   (string)
-   "Name of this host declaration.")
-  (host-name
-   maybe-string
-   "Host name---e.g., @code{\"foo.example.org\"} or @code{\"192.168.1.2\"}.")
-  (address-family
-   maybe-address-family
-   "Address family to use when connecting to this host: one of
-@code{AF_INET} (for IPv4 only), @code{AF_INET6} (for IPv6 only).
-Additionally, the field can be left unset to allow any address family.")
-  (identity-file
-   maybe-string
-   "The identity file to use---e.g.,
-@code{\"/home/charlie/.ssh/id_ed25519\"}.")
-  (port
-   maybe-natural-number
-   "TCP port number to connect to.")
-  (user
-   maybe-string
-   "User name on the remote host.")
-  (forward-x11?
-   (boolean #f)
-   "Whether to forward remote client connections to the local X11 graphical
-display.")
-  (forward-x11-trusted?
-   (boolean #f)
-   "Whether remote X11 clients have full access to the original X11 graphical
-display.")
-  (forward-agent?
-   (boolean #f)
-   "Whether the authentication agent (if any) is forwarded to the remote
-machine.")
-  (compression?
-   (boolean #f)
-   "Whether to compress data in transit.")
-  (proxy-command
-   maybe-string
-   "The command to use to connect to the server.  As an example, a command
-to connect via an HTTP proxy at 192.0.2.0 would be: @code{\"nc -X
-connect -x 192.0.2.0:8080 %h %p\"}.")
-  (host-key-algorithms
-   maybe-string-list
-   "The list of accepted host key algorithms---e.g.,
-@code{'(\"ssh-ed25519\")}.")
-  (accepted-key-types
-   maybe-string-list
-   "The list of accepted user public key types.")
-  (extra-content
-   (raw-configuration-string "")
-   "Extra content appended as-is to this @code{Host} block in
-@file{~/.ssh/config}."))
-
-(define (serialize-openssh-host config)
-  (define (openssh-host-name-field? field)
-    (eq? (configuration-field-name field) 'name))
-
-  (string-append
-   "Host " (openssh-host-name config) "\n"
-   (string-concatenate
-    (map (lambda (field)
-           ((configuration-field-serializer field)
-            (configuration-field-name field)
-            ((configuration-field-getter field) config)))
-         (remove openssh-host-name-field?
-                 openssh-host-fields)))))
-
-(define-record-type* <home-openssh-configuration>
-  home-openssh-configuration make-home-openssh-configuration
-  home-openssh-configuration?
-  (authorized-keys home-openssh-configuration-authorized-keys ;list of file-like
-                   (default '()))
-  (known-hosts     home-openssh-configuration-known-hosts ;unspec | list of file-like
-                   (default *unspecified*))
-  (hosts           home-openssh-configuration-hosts   ;list of <openssh-host>
-                   (default '())))
-
-(define (openssh-configuration->string config)
-  (string-join (map serialize-openssh-host
-                    (home-openssh-configuration-hosts config))
-               "\n"))
-
-(define* (file-join name files #:optional (delimiter " "))
-  "Return a file in the store called @var{name} that is the concatenation
-of all the file-like objects listed in @var{files}, with @var{delimited}
-inserted after each of them."
-  (computed-file name
-                 (with-imported-modules '((guix build utils))
-                   #~(begin
-                       (use-modules (guix build utils))
-
-                       ;; Support non-ASCII file names.
-                       (setenv "GUIX_LOCPATH"
-                               #+(file-append glibc-utf8-locales
-                                              "/lib/locale"))
-                       (setlocale LC_ALL "en_US.utf8")
-
-                       (call-with-output-file #$output
-                         (lambda (output)
-                           (for-each (lambda (file)
-                                       (call-with-input-file file
-                                         (lambda (input)
-                                           (dump-port input output)))
-                                       (display #$delimiter output))
-                                     '#$files)))))))
-
-(define (openssh-configuration-files config)
-  (let ((config (plain-file "ssh.conf"
-                            (openssh-configuration->string config)))
-        (known-hosts (home-openssh-configuration-known-hosts config))
-        (authorized-keys (file-join
-                          "authorized_keys"
-                          (home-openssh-configuration-authorized-keys config)
-                          "\n")))
-    `((".ssh/authorized_keys" ,authorized-keys)
-      ,@(if (unspecified? known-hosts)
-            '()
-            `((".ssh/known_hosts"
-               ,(file-join "known_hosts" known-hosts "\n"))))
-      (".ssh/config" ,config))))
-
-(define openssh-activation
-  (with-imported-modules (source-module-closure
-                          '((gnu build activation)))
-    #~(begin
-        (use-modules (gnu build activation))
-
-        ;; Make sure ~/.ssh is #o700.
-        (let* ((home (getenv "HOME"))
-               (dot-ssh (string-append home "/.ssh")))
-          (mkdir-p/perms dot-ssh (getpw (getuid)) #o700)))))
-
-(define home-openssh-service-type
-  (service-type
-   (name 'home-openssh)
-   (extensions
-    (list (service-extension home-files-service-type
-                             openssh-configuration-files)
-          (service-extension home-activation-service-type
-                             (const openssh-activation))))
-   (description "Configure the OpenSSH @acronym{SSH, secure shell} client
-by providing a @file{~/.ssh/config} file, which is honored by the OpenSSH
-client,@command{ssh}, and by other tools such as @command{guix deploy}.")
-   (default-value (home-openssh-configuration))))
@@ -1,248 +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 xdg-data-home
-           (or (getenv "XDG_DATA_HOME")
-               (string-append (getenv "HOME") "/.local/share")))
-
-         (define backup-directory
-           (string-append home-directory "/" (number->string (current-time))
-                          "-guix-home-legacy-configs-backup"))
-
-         (define (preprocess-file file)
-           "If file is in XDG-CONFIGURATION-FILES-DIRECTORY use
-subdirectory from XDG_CONFIG_HOME to generate a target path."
-           (cond
-            ((string-prefix? #$xdg-configuration-files-directory file)
-             (string-append
-              (substring xdg-config-home
-                         (1+ (string-length home-directory)))
-              (substring file
-                         (string-length #$xdg-configuration-files-directory))))
-            ((string-prefix? #$xdg-data-files-directory file)
-             (string-append
-              (substring xdg-data-home
-                         (1+ (string-length home-directory)))
-              (substring file
-                         (string-length #$xdg-data-files-directory))))
-            (else file)))
-
-         (define (target-file file)
-           ;; Return the target of FILE, a config file name sans leading dot
-           ;; such as "config/fontconfig/fonts.conf" or "bashrc".
-           (string-append home-directory "/" (preprocess-file file)))
-
-         (define (no-follow-file-exists? file)
-           "Return #t if file exists, even if it's a dangling symlink."
-           (->bool (false-if-exception (lstat file))))
-
-         (define (symlink-to-store? file)
-           (catch 'system-error
-             (lambda ()
-               (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 (no-follow-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))
-                         ((= ENOENT errno) #t)
-                         ((= 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 (no-follow-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 (no-follow-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.")))
@@ -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)))))))
-
@@ -1,488 +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 modules)
-  #: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)))
-         '#$(filter-map
-             (lambda (field)
-               (let ((variable
-                      (string-append
-                       "XDG_"
-                       (object->snake-case-string
-                        (configuration-field-name field) 'upper))))
-                 ;; XDG_RUNTIME_DIR shouldn't be created during activation
-                 ;; and will be provided by elogind or other service.
-                 (and (not (string=? "XDG_RUNTIME_DIR" variable))
-                      variable)))
-             home-xdg-base-directories-configuration-fields)))
-
-(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)
-               ((@ (guix build utils) 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 desktop-action)
-    (match-record desktop-action <xdg-desktop-action>
-      (action name config)
-      `(,(format #f "[Desktop Action ~a]\n"
-                 (string-capitalize (maybe-object->string action)))
-        ,(format #f "Name=~a\n" name)
-        ,@(serialize-alist config))))
-
-  (match-record entry <xdg-desktop-entry>
-    (file name type config actions)
-    (list (if (string-suffix? file ".desktop")
-              file
-              (string-append file ".desktop"))
-          `("[Desktop Entry]\n"
-            ,(format #f "Name=~a\n" name)
-            ,(format #f "Type=~a\n"
-                     (string-capitalize (symbol->string type)))
-            ,@(serialize-alist config)
-            ,@(append-map serialize-xdg-desktop-action actions)))))
-
-(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)))
-      ;; TODO: Use xdg-data-files instead of home-files here
-      (list (format #f "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-xdg-data-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.")))
--- a/Show More
+++ b/Show More
Author	SHA1	Message	Date
Mathieu Othacehe	aa34d4d28d	ci: Update to the last version. * gnu/ci.scm: Update to the master version.	2021-06-14 08:58:41 +02:00
Leo Famulari	6110751b53	nls: Mention Libera Chat in the translations. * po/doc/guix-manual.de.po, po/doc/guix-manual.es.po, po/doc/guix-manual.fa.po, po/doc/guix-manual.fr.po, po/doc/guix-manual.it.po, po/doc/guix-manual.ko.po, po/doc/guix-manual.pt_BR.po, po/doc/guix-manual.ru.po, po/doc/guix-manual.sk.po, po/doc/guix-manual.zh_CN.po: Point users to Libera Chat.	2021-05-20 16:57:35 -04:00
Tobias Geerinckx-Rice	a8509d8d43	The #guix channel is hosted by Libera Chat. * README (Contact): Update network name. * ROADMAP: Likewise. * doc/contributing.texi (Contributing): Likewise. * doc/guix.texi (After System Installation): Likewise.	2021-05-20 16:57:28 -04:00
Leo Famulari	0961807915	doc: Clarify further the distinction between the web-based manuals. As discussed on #guix IRC, several of us struggle to reliably choose the right option based on the old labels: https://logs.guix.gnu.org/guix/2021-04-20.log#182137 * doc/build.scm (html-manual-indexes): Try to distinguish between the two options more clearly.	2021-05-12 15:00:06 -04:00