mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2026-07-08 23:34:04 +02:00
Compare commits
4 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Mathieu Othacehe
|
aa34d4d28d | ||
|
Leo Famulari
|
6110751b53 | ||
|
Tobias Geerinckx-Rice
|
a8509d8d43 | ||
|
Leo Famulari
|
0961807915 |
+2
-14
@@ -6,9 +6,9 @@
|
||||
(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")
|
||||
. "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")
|
||||
|
||||
;; Emacs-Guix
|
||||
(eval . (setq-local guix-directory
|
||||
@@ -52,16 +52,11 @@
|
||||
(eval . (put 'test-equal 'scheme-indent-function 1))
|
||||
(eval . (put 'test-eq 'scheme-indent-function 1))
|
||||
(eval . (put 'call-with-input-string 'scheme-indent-function 1))
|
||||
(eval . (put 'call-with-port 'scheme-indent-function 1))
|
||||
(eval . (put 'guard 'scheme-indent-function 1))
|
||||
(eval . (put 'lambda* 'scheme-indent-function 1))
|
||||
(eval . (put 'substitute* 'scheme-indent-function 1))
|
||||
(eval . (put 'match-record 'scheme-indent-function 2))
|
||||
|
||||
;; 'modify-inputs' and its keywords.
|
||||
(eval . (put 'modify-inputs 'scheme-indent-function 1))
|
||||
(eval . (put 'replace 'scheme-indent-function 1))
|
||||
|
||||
;; 'modify-phases' and its keywords.
|
||||
(eval . (put 'modify-phases 'scheme-indent-function 1))
|
||||
(eval . (put 'replace 'scheme-indent-function 1))
|
||||
@@ -80,7 +75,6 @@
|
||||
(eval . (put 'origin 'scheme-indent-function 0))
|
||||
(eval . (put 'build-system 'scheme-indent-function 0))
|
||||
(eval . (put 'bag 'scheme-indent-function 0))
|
||||
(eval . (put 'gexp->derivation 'scheme-indent-function 1))
|
||||
(eval . (put 'graft 'scheme-indent-function 0))
|
||||
(eval . (put 'operating-system 'scheme-indent-function 0))
|
||||
(eval . (put 'file-system 'scheme-indent-function 0))
|
||||
@@ -121,12 +115,10 @@
|
||||
(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))
|
||||
@@ -148,10 +140,6 @@
|
||||
|
||||
(eval . (put 'with-paginated-output-port 'scheme-indent-function 1))
|
||||
|
||||
(eval . (put 'with-shepherd-action 'scheme-indent-function 3))
|
||||
|
||||
(eval . (put 'with-http-server 'scheme-indent-function 1))
|
||||
|
||||
;; This notably allows '(' in Paredit to not insert a space when the
|
||||
;; preceding symbol is one of these.
|
||||
(eval . (modify-syntax-entry ?~ "'"))
|
||||
|
||||
@@ -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
|
||||
|
||||
+32
-6
@@ -6,6 +6,8 @@
|
||||
|
||||
(("AD17 A21E F8AE D8F1 CC02 DBD9 F7D5 C9BF 765C 61E3"
|
||||
(name "andreas"))
|
||||
("2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5"
|
||||
(name "ajgrf"))
|
||||
("4FB9 9F49 2B12 A365 7997 E664 8246 0C08 2A0E E98F"
|
||||
(name "alezost"))
|
||||
("50F3 3E2E 5B0C 3D90 0424 ABE8 9BDC F497 A4BB CC7F"
|
||||
@@ -14,9 +16,21 @@
|
||||
(name "apteryx"))
|
||||
("7F73 0343 F2F0 9F3C 77BF 79D3 2E25 EE8B 6180 2BB3"
|
||||
(name "arunisaac"))
|
||||
(;; primary: "3B12 9196 AE30 0C3C 0E90 A26F A715 5567 3271 9948"
|
||||
"9A2B 401E D001 0650 1584 BAAC 8BC4 F447 6E8A 8E00"
|
||||
(name "atheia"))
|
||||
(;; primary: "BE62 7373 8E61 6D6D 1B3A 08E8 A21A 0202 4881 6103"
|
||||
"39B3 3C8D 9448 0D2D DCC2 A498 8B44 A0CD C7B9 56F2"
|
||||
(name "bandali"))
|
||||
(;; primary: "34FF 38BC D151 25A6 E340 A0B5 3453 2F9F AFCA 8B8E"
|
||||
"A3A4 B419 0074 087C A7DE 5698 BC45 CA67 E2F8 D007"
|
||||
"A0C5 E352 2EF8 EF5C 64CD B7F0 FD73 CAC7 19D3 2566"
|
||||
(name "bavier"))
|
||||
("45CC 63B8 5258 C9D5 5F34 B239 D37D 0EA7 CECC 3912"
|
||||
(name "biscuolo"))
|
||||
("7988 3B9F 7D6A 4DBF 3719 0367 2506 A96C CF63 0B21"
|
||||
(name "boskovits"))
|
||||
("E82A C026 95D6 FF02 43CA 1E5C F6C5 2DD1 BA27 CB87"
|
||||
(name "brettgilio"))
|
||||
(;; primary: "8929 BBC5 73CD 9206 3DDD 979D 3D36 CAA0 116F 0F99"
|
||||
"1C9B F005 1A1A 6A44 5257 599A A949 03A1 66A1 8FAE"
|
||||
(name "bricewge"))
|
||||
@@ -36,6 +50,8 @@
|
||||
(name "davexunit"))
|
||||
("8CCB A7F5 52B9 CBEA E1FB 2915 8328 C747 0FF1 D807" ;FIXME: to be confirmed!
|
||||
(name "davexunit (2nd)"))
|
||||
("53C4 1E6E 41AA FE55 335A CA5E 446A 2ED4 D940 BF14"
|
||||
(name "daviwil"))
|
||||
("A28B F40C 3E55 1372 662D 14F7 41AA E7DC CA3D 8351"
|
||||
(name "efraim"))
|
||||
(;; primary: "2453 02B1 BAB1 F867 FDCA 96BC 8F3F 861F 82EB 7A9A"
|
||||
@@ -45,6 +61,8 @@
|
||||
(name "hoebjo"))
|
||||
("B943 509D 633E 80DD 27FC 4EED 634A 8DFF D3F6 31DF"
|
||||
(name "htgoebel"))
|
||||
("7440 26BA 7CA3 C668 E940 1D53 0B43 1E98 3705 6942"
|
||||
(name "ipetkov"))
|
||||
(;; primary: "66A5 6D9C 9A98 BE7F 719A B401 2652 5665 AE72 7D37"
|
||||
"0325 78A6 8298 94E7 2AA2 66F5 D415 BF25 3B51 5976"
|
||||
(name "iyzsong"))
|
||||
@@ -55,25 +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"))
|
||||
("925C 8EBD F446 931D 1B64 4498 2D58 A112 6E2D FC90"
|
||||
(name "magali"))
|
||||
("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"
|
||||
@@ -91,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>
|
||||
|
||||
+66
-91
@@ -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
|
||||
|
||||
+35
-160
@@ -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,14 +126,7 @@ MODULES = \
|
||||
guix/cache.scm \
|
||||
guix/cve.scm \
|
||||
guix/workers.scm \
|
||||
guix/least-authority.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 \
|
||||
@@ -146,13 +136,11 @@ MODULES = \
|
||||
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 \
|
||||
@@ -171,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 \
|
||||
@@ -199,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 \
|
||||
@@ -217,7 +203,6 @@ MODULES = \
|
||||
guix/build/gnu-dist.scm \
|
||||
guix/build/guile-build-system.scm \
|
||||
guix/build/maven-build-system.scm \
|
||||
guix/build/minetest-build-system.scm \
|
||||
guix/build/node-build-system.scm \
|
||||
guix/build/perl-build-system.scm \
|
||||
guix/build/python-build-system.scm \
|
||||
@@ -226,7 +211,6 @@ MODULES = \
|
||||
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 \
|
||||
@@ -236,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 \
|
||||
@@ -251,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 \
|
||||
@@ -265,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 \
|
||||
@@ -308,40 +286,29 @@ 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 \
|
||||
guix/scripts/git.scm \
|
||||
guix/scripts/git/authenticate.scm \
|
||||
guix/scripts/git/log.scm \
|
||||
guix/scripts/graph.scm \
|
||||
guix/scripts/weather.scm \
|
||||
guix/scripts/container.scm \
|
||||
@@ -396,14 +363,10 @@ AUX_FILES = \
|
||||
gnu/packages/aux-files/chromium/master-preferences.json \
|
||||
gnu/packages/aux-files/emacs/guix-emacs.el \
|
||||
gnu/packages/aux-files/guix.vim \
|
||||
gnu/packages/aux-files/linux-libre/5.18-arm.conf \
|
||||
gnu/packages/aux-files/linux-libre/5.18-arm64.conf \
|
||||
gnu/packages/aux-files/linux-libre/5.18-i686.conf \
|
||||
gnu/packages/aux-files/linux-libre/5.18-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 \
|
||||
@@ -421,10 +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/sitecustomize.py \
|
||||
gnu/packages/aux-files/renpy/renpy.in \
|
||||
gnu/packages/aux-files/run-in-namespace.c
|
||||
|
||||
# Templates, examples.
|
||||
@@ -473,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 \
|
||||
@@ -488,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 \
|
||||
@@ -498,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 \
|
||||
@@ -530,9 +484,7 @@ SCM_TESTS = \
|
||||
tests/search-paths.scm \
|
||||
tests/services.scm \
|
||||
tests/services/file-sharing.scm \
|
||||
tests/services/configuration.scm \
|
||||
tests/services/linux.scm \
|
||||
tests/services/telephony.scm \
|
||||
tests/sets.scm \
|
||||
tests/size.scm \
|
||||
tests/status.scm \
|
||||
@@ -544,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 \
|
||||
@@ -554,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
|
||||
@@ -580,13 +525,10 @@ SH_TESTS = \
|
||||
tests/guix-package-aliases.sh \
|
||||
tests/guix-package-net.sh \
|
||||
tests/guix-system.sh \
|
||||
tests/guix-home.sh \
|
||||
tests/guix-archive.sh \
|
||||
tests/guix-authenticate.sh \
|
||||
tests/guix-environment.sh \
|
||||
tests/guix-environment-container.sh \
|
||||
tests/guix-shell.sh \
|
||||
tests/guix-shell-export-manifest.sh \
|
||||
tests/guix-graph.sh \
|
||||
tests/guix-describe.sh \
|
||||
tests/guix-repl.sh \
|
||||
@@ -637,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 \
|
||||
@@ -662,11 +603,9 @@ EXTRA_DIST += \
|
||||
.guix-authorizations \
|
||||
.guix-channel \
|
||||
scripts/guix.in \
|
||||
etc/disarchive-manifest.scm \
|
||||
etc/guix-install.sh \
|
||||
etc/news.scm \
|
||||
etc/release-manifest.scm \
|
||||
etc/source-manifest.scm \
|
||||
etc/system-tests.scm \
|
||||
etc/historical-authorizations \
|
||||
build-aux/build-self.scm \
|
||||
@@ -675,24 +614,21 @@ EXTRA_DIST += \
|
||||
build-aux/check-final-inputs-self-contained.scm \
|
||||
build-aux/check-channel-news.scm \
|
||||
build-aux/compile-as-derivation.scm \
|
||||
build-aux/convert-xref.scm \
|
||||
build-aux/generate-authors.scm \
|
||||
build-aux/test-driver.scm \
|
||||
build-aux/update-guix-package.scm \
|
||||
build-aux/update-NEWS.scm \
|
||||
tests/test.drv \
|
||||
tests/signing-key.pub \
|
||||
tests/signing-key.sec \
|
||||
tests/cve-sample.json \
|
||||
tests/keys/signing-key.pub \
|
||||
tests/keys/signing-key.sec \
|
||||
tests/keys/civodul.pub \
|
||||
tests/keys/rsa.pub \
|
||||
tests/keys/dsa.pub \
|
||||
tests/keys/ed25519.pub \
|
||||
tests/keys/ed25519.sec \
|
||||
tests/keys/ed25519-2.pub \
|
||||
tests/keys/ed25519-2.sec \
|
||||
tests/keys/ed25519-3.pub \
|
||||
tests/keys/ed25519-3.sec \
|
||||
tests/civodul.key \
|
||||
tests/rsa.key \
|
||||
tests/dsa.key \
|
||||
tests/ed25519.key \
|
||||
tests/ed25519.sec \
|
||||
tests/ed25519bis.key \
|
||||
tests/ed25519bis.sec \
|
||||
build-aux/config.rpath \
|
||||
bootstrap \
|
||||
doc/build.scm \
|
||||
@@ -719,60 +655,15 @@ CLEANFILES = \
|
||||
# the whole thing. Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly
|
||||
# stale files from ~/.cache/guile/ccache.
|
||||
%.go: make-go ; @:
|
||||
make-go: make-core-go make-packages-go make-system-go make-cli-go
|
||||
|
||||
# Define a rule to build a subset of the .go files.
|
||||
define guile-compilation-rule
|
||||
|
||||
$(1): $(2)
|
||||
$(AM_V_at)echo "Compiling Scheme modules..." ; \
|
||||
unset GUILE_LOAD_COMPILED_PATH ; \
|
||||
XDG_CACHE_HOME=/nowhere \
|
||||
host=$(host) srcdir="$(top_srcdir)" \
|
||||
$(top_builddir)/pre-inst-env \
|
||||
$(GUILE) -L "$(top_builddir)" -L "$(top_srcdir)" \
|
||||
--no-auto-compile \
|
||||
-s "$(top_srcdir)"/build-aux/compile-all.scm \
|
||||
--total $(words $(MODULES)) \
|
||||
--completed $(3) \
|
||||
$$(filter %.scm,$$^)
|
||||
|
||||
endef
|
||||
|
||||
# Split compilation in several steps, each of which building a subset of
|
||||
# $(MODULES). The main goal is to reduce peak memory consumption, as reported
|
||||
# in <https://issues.guix.gnu.org/48963>. Each 'eval' call below creates a
|
||||
# 'make-*-go' phony target that builds the corresponding subset.
|
||||
|
||||
MODULES_CORE = guix.scm $(filter-out guix/scripts/%,$(filter guix/%,$(MODULES)))
|
||||
MODULES_PACKAGES = $(filter gnu/packages/%,$(MODULES))
|
||||
MODULES_SYSTEM = gnu.scm $(filter-out gnu/packages/%,$(filter gnu/%,$(MODULES)))
|
||||
MODULES_CLI = $(filter guix/scripts/%,$(MODULES))
|
||||
MODULES_PO = guix/build/po.scm
|
||||
|
||||
$(eval $(call guile-compilation-rule,make-core-go, \
|
||||
$(MODULES_CORE) guix/config.scm $(dist_noinst_DATA), \
|
||||
0))
|
||||
.PHONY: make-core-go
|
||||
|
||||
$(eval $(call guile-compilation-rule,make-packages-go, \
|
||||
$(MODULES_PACKAGES) make-core-go, \
|
||||
$(words $(MODULES_CORE))))
|
||||
.PHONY: make-packages-go
|
||||
|
||||
$(eval $(call guile-compilation-rule,make-system-go, \
|
||||
$(MODULES_SYSTEM) make-packages-go make-core-go, \
|
||||
$(words $(MODULES_CORE) $(MODULES_PACKAGES))))
|
||||
.PHONY: make-system-go
|
||||
|
||||
$(eval $(call guile-compilation-rule,make-cli-go, \
|
||||
$(MODULES_CLI) make-system-go make-packages-go make-core-go, \
|
||||
$(words $(MODULES_CORE) $(MODULES_PACKAGES) $(MODULES_SYSTEM))))
|
||||
.PHONY: make-cli-go
|
||||
|
||||
$(eval $(call guile-compilation-rule,guix/build/po.go, \
|
||||
$(MODULES_PO), \
|
||||
0))
|
||||
make-go: $(MODULES) guix/config.scm $(dist_noinst_DATA)
|
||||
$(AM_V_at)echo "Compiling Scheme modules..." ; \
|
||||
unset GUILE_LOAD_COMPILED_PATH ; \
|
||||
XDG_CACHE_HOME=/nowhere \
|
||||
host=$(host) srcdir="$(top_srcdir)" \
|
||||
$(top_builddir)/pre-inst-env \
|
||||
$(GUILE) -L "$(top_builddir)" -L "$(top_srcdir)" \
|
||||
--no-auto-compile \
|
||||
-s "$(top_srcdir)"/build-aux/compile-all.scm $^
|
||||
|
||||
SUFFIXES = .go
|
||||
|
||||
@@ -991,7 +882,7 @@ release: dist-with-updated-version all
|
||||
--system=$$system --fallback \
|
||||
gnu/system/install.scm` ; \
|
||||
if [ ! -f "$$image" ] ; then \
|
||||
echo "failed to produce Guix installation image for $$system" >&2 ; \
|
||||
echo "failed to produced Guix installation image for $$system" >&2 ; \
|
||||
exit 1 ; \
|
||||
fi ; \
|
||||
cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_IMAGE_BASE).$$system.iso.tmp" ; \
|
||||
@@ -1006,7 +897,7 @@ release: dist-with-updated-version all
|
||||
--system=$$system --fallback \
|
||||
gnu/system/examples/vm-image.tmpl` ; \
|
||||
if [ ! -f "$$image" ] ; then \
|
||||
echo "failed to produce Guix VM image for $$system" >&2 ; \
|
||||
echo "failed to produced Guix VM image for $$system" >&2 ; \
|
||||
exit 1 ; \
|
||||
fi ; \
|
||||
cp "$$image" "$(releasedir)/$(GUIX_SYSTEM_VM_IMAGE_BASE).$$system.qcow2"; \
|
||||
@@ -1046,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.
|
||||
@@ -1087,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
|
||||
|
||||
|
||||
@@ -4,7 +4,6 @@
|
||||
|
||||
Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
|
||||
Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
|
||||
Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
|
||||
Copying and distribution of this file, with or without modification,
|
||||
are permitted in any medium without royalty provided the copyright
|
||||
@@ -12,40 +11,10 @@ Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
|
||||
Please send Guix bug reports to bug-guix@gnu.org.
|
||||
|
||||
* Changes in 1.4.0 (since 1.3.0)
|
||||
** Package management
|
||||
*** New ‘guix home’ command, for home environment management
|
||||
*** New ‘guix shell’ command, the successor to ‘guix environment’
|
||||
*** New ‘deb’ format for the ‘guix pack’ command
|
||||
*** New ‘guix import minetest’ command, to import Minetest extensions
|
||||
*** ‘guix import texlive’ rewritten to use the TLPDB as its source
|
||||
*** ‘guix import elpa’ now supports the non-GNU ELPA repository
|
||||
*** ‘guix import pypi’ can now import a specific version
|
||||
*** ‘guix import cran’ can now import a specific version
|
||||
*** New updater (see ‘guix refresh’): ‘generic-git’
|
||||
*** ‘guix graph’ has a new ‘--max-depth’ option
|
||||
*** ‘--with-commit’ option now accepts strings returned by ‘git describe’
|
||||
** Distribution
|
||||
*** The installation script can now enable local substitute servers discovery
|
||||
*** More control over boot-time file system checks and repairs
|
||||
*** XFS file systems can be created by the installer and mounted by label/UUID
|
||||
*** New interface for declaring swap space
|
||||
** Programming interfaces
|
||||
*** (guix records) now supports “field sanitizers”
|
||||
** Noteworthy bug fixes
|
||||
*** Fall back to Software Heritage when cloning a channel
|
||||
(<https://issues.guix.gnu.org/44187>)
|
||||
*** ‘--with-patch’ can be used on packages with non-origin sources
|
||||
(<https://issues.guix.gnu.org/49697>)
|
||||
*** Fix pathological profile building performance in the presence of grafts
|
||||
(<https://issues.guix.gnu.org/49439>)
|
||||
*** Deduplication phase of the garbage collector is now faster
|
||||
(<https://issues.guix.gnu.org/24937>)
|
||||
*** File system flags are validated before system instantiation
|
||||
(<https://issues.guix.gnu.org/51425>)
|
||||
|
||||
* Changes in 1.3.0 (since 1.2.0)
|
||||
|
||||
** Package management
|
||||
|
||||
*** POWER9 (powerpc64le-linux) is now supported as a technology preview
|
||||
*** New ‘--export-manifest’ and ‘--export-channels’ options of ‘guix package’
|
||||
*** New ‘--profile’ option for ‘guix environment’
|
||||
|
||||
@@ -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))))))))))))
|
||||
|
||||
+24
-31
@@ -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
|
||||
|
||||
|
||||
+12
-1
@@ -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])
|
||||
|
||||
+5
-5
@@ -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])
|
||||
|
||||
+221
-426
@@ -1,7 +1,6 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
|
||||
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -31,7 +30,6 @@
|
||||
(guix gexp)
|
||||
(guix git)
|
||||
(guix git-download)
|
||||
(guix profiles)
|
||||
(guix utils)
|
||||
(git)
|
||||
(gnu packages base)
|
||||
@@ -64,19 +62,11 @@
|
||||
(or (getenv "GUIX_MANUAL")
|
||||
"guix"))
|
||||
|
||||
(define %manual-languages
|
||||
;; Available translations for the 'guix-manual' text domain.
|
||||
'("de" "en" "es" "fr" "ru" "zh_CN"))
|
||||
|
||||
(define %cookbook-languages
|
||||
;; Available translations for the 'guix-cookbook' text domain.
|
||||
'("de" "en" "fr" "sk"))
|
||||
|
||||
(define %languages
|
||||
;; Available translations for the document being built.
|
||||
;; The cookbook is not translated in the same languages as the manual
|
||||
(if (string=? %manual "guix-cookbook")
|
||||
%cookbook-languages
|
||||
%manual-languages))
|
||||
'("de" "en" "fr")
|
||||
'("de" "en" "es" "fr" "ru" "zh_CN")))
|
||||
|
||||
(define (texinfo-manual-images source)
|
||||
"Return a directory containing all the images used by the user manual, taken
|
||||
@@ -311,9 +301,8 @@ actual file name."
|
||||
(define (html-files directory)
|
||||
;; Return the list of HTML files under DIRECTORY.
|
||||
(map (cut string-append directory "/" <>)
|
||||
(or (scandir #$manual (lambda (file)
|
||||
(string-suffix? ".html" file)))
|
||||
'())))
|
||||
(scandir #$manual (lambda (file)
|
||||
(string-suffix? ".html" file)))))
|
||||
|
||||
(define anchors
|
||||
(sort (concatenate
|
||||
@@ -450,7 +439,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||
("rarr" "→")
|
||||
("hellip" "…")
|
||||
("rsquo" "’")
|
||||
("nbsp" " ")
|
||||
(e (pk 'unknown-entity e) (primitive-exit 2))))
|
||||
|
||||
(define (concatenate-snippets pieces)
|
||||
@@ -611,175 +599,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||
|
||||
(computed-file name build))
|
||||
|
||||
(define* (stylized-html source input
|
||||
#:key
|
||||
(languages %languages)
|
||||
(manual %manual)
|
||||
(manual-css-url "/static/base/css/manual.css"))
|
||||
"Process all the HTML files in INPUT; add them MANUAL-CSS-URL as a <style>
|
||||
link, and add a menu to choose among LANGUAGES. Use the Guix PO files found
|
||||
in SOURCE."
|
||||
(define build
|
||||
(with-extensions (list guile-lib)
|
||||
(with-imported-modules `((guix build utils)
|
||||
((localization)
|
||||
=> ,(localization-helper-module
|
||||
source languages)))
|
||||
#~(begin
|
||||
(use-modules (htmlprag)
|
||||
(localization)
|
||||
(guix build utils)
|
||||
(srfi srfi-1)
|
||||
(ice-9 match)
|
||||
(ice-9 threads))
|
||||
|
||||
(define* (menu-dropdown #:key (label "Item") (url "#") (items '()))
|
||||
;; Return an SHTML <li> element representing a dropdown for the
|
||||
;; navbar. LABEL is the text of the dropdown menu, and ITEMS is
|
||||
;; the list of items in this menu.
|
||||
(define id "visible-dropdown")
|
||||
|
||||
`(li
|
||||
(@ (class "navbar-menu-item dropdown dropdown-btn"))
|
||||
(input (@ (class "navbar-menu-hidden-input")
|
||||
(type "radio")
|
||||
(name "dropdown")
|
||||
(id ,id)))
|
||||
(label (@ (for ,id)) ,label)
|
||||
(label (@ (for "all-dropdowns-hidden")) ,label)
|
||||
(div
|
||||
(@ (class "navbar-submenu")
|
||||
(id "navbar-submenu"))
|
||||
(div (@ (class "navbar-submenu-triangle"))
|
||||
" ")
|
||||
(ul ,@items))))
|
||||
|
||||
(define (menu-item label url)
|
||||
;; Return an SHTML <li> element for a menu item with the given
|
||||
;; LABEL and URL.
|
||||
`(li (a (@ (class "navbar-menu-item")
|
||||
(href ,url))
|
||||
,label)))
|
||||
|
||||
(define* (navigation-bar menus #:key split-node?)
|
||||
;; Return the navigation bar showing all of MENUS.
|
||||
`(header (@ (class "navbar"))
|
||||
(h1 (a (@ (class "branding")
|
||||
(href ,(if split-node? ".." "#")))))
|
||||
(nav (@ (class "navbar-menu"))
|
||||
(input (@ (class "navbar-menu-hidden-input")
|
||||
(type "radio")
|
||||
(name "dropdown")
|
||||
(id "all-dropdowns-hidden")))
|
||||
(ul ,@menus))
|
||||
|
||||
;; This is the button that shows up on small screen in
|
||||
;; lieu of the drop-down button.
|
||||
(a (@ (class "navbar-menu-btn")
|
||||
(href ,(if split-node? "../.." ".."))))))
|
||||
|
||||
(define* (base-language-url code manual
|
||||
#:key split-node?)
|
||||
;; Return the base URL of MANUAL for language CODE.
|
||||
(if split-node?
|
||||
(string-append "../../" (normalize code) "/html_node")
|
||||
(string-append "../" (normalize code) "/" manual
|
||||
(if (string=? code "en")
|
||||
""
|
||||
(string-append "." code))
|
||||
".html")))
|
||||
|
||||
(define (language-menu-items file)
|
||||
;; Return the language menu items to be inserted in FILE.
|
||||
(define split-node?
|
||||
(string-contains file "/html_node/"))
|
||||
|
||||
(append
|
||||
(map (lambda (code)
|
||||
(menu-item (language-code->native-name code)
|
||||
(base-language-url code #$manual
|
||||
#:split-node?
|
||||
split-node?)))
|
||||
'#$%languages)
|
||||
(list
|
||||
(menu-item "⊕"
|
||||
(if (string=? #$manual "guix-cookbook")
|
||||
"https://translate.fedoraproject.org/projects/guix/documentation-cookbook/"
|
||||
"https://translate.fedoraproject.org/projects/guix/documentation-manual/")))))
|
||||
|
||||
(define (stylized-html sxml file)
|
||||
;; Return SXML, which was read from FILE, with additional
|
||||
;; styling.
|
||||
(define split-node?
|
||||
(string-contains file "/html_node/"))
|
||||
|
||||
(let loop ((sxml sxml))
|
||||
(match sxml
|
||||
(('*TOP* decl body ...)
|
||||
`(*TOP* ,decl ,@(map loop body)))
|
||||
(('head elements ...)
|
||||
;; Add reference to our own manual CSS, which provides
|
||||
;; support for the language menu.
|
||||
`(head ,@elements
|
||||
(link (@ (rel "stylesheet")
|
||||
(type "text/css")
|
||||
(href #$manual-css-url)))))
|
||||
(('body ('@ attributes ...) elements ...)
|
||||
`(body (@ ,@attributes)
|
||||
,(navigation-bar
|
||||
;; TODO: Add "Contribute" menu, to report
|
||||
;; errors, etc.
|
||||
(list (menu-dropdown
|
||||
#:label
|
||||
`(img (@ (alt "Language")
|
||||
(src "/static/base/img/language-picker.svg")))
|
||||
#:items
|
||||
(language-menu-items file)))
|
||||
#:split-node? split-node?)
|
||||
,@elements))
|
||||
((tag ('@ attributes ...) body ...)
|
||||
`(,tag (@ ,@attributes) ,@(map loop body)))
|
||||
((tag body ...)
|
||||
`(,tag ,@(map loop body)))
|
||||
((? string? str)
|
||||
str))))
|
||||
|
||||
(define (process-html file)
|
||||
;; Parse FILE and add links to translations. Install the result
|
||||
;; to #$output.
|
||||
(format (current-error-port) "processing ~a...~%" file)
|
||||
(let* ((shtml (parameterize ((%strict-tokenizer? #t))
|
||||
(call-with-input-file file html->shtml)))
|
||||
(processed (stylized-html shtml file))
|
||||
(base (string-drop file (string-length #$input)))
|
||||
(target (string-append #$output base)))
|
||||
(mkdir-p (dirname target))
|
||||
(call-with-output-file target
|
||||
(lambda (port)
|
||||
(write-shtml-as-html processed port)))))
|
||||
|
||||
;; Install a UTF-8 locale so we can process UTF-8 files.
|
||||
(setenv "GUIX_LOCPATH"
|
||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||
(setlocale LC_ALL "en_US.utf8")
|
||||
(setenv "LC_ALL" "en_US.utf8")
|
||||
(setvbuf (current-error-port) 'line)
|
||||
|
||||
(n-par-for-each (parallel-job-count)
|
||||
(lambda (file)
|
||||
(if (string-suffix? ".html" file)
|
||||
(process-html file)
|
||||
;; Copy FILE as is to #$output.
|
||||
(let* ((base (string-drop file (string-length #$input)))
|
||||
(target (string-append #$output base)))
|
||||
(mkdir-p (dirname target))
|
||||
(if (eq? 'symlink (stat:type (lstat file)))
|
||||
(symlink (readlink file) target)
|
||||
(copy-file file target)))))
|
||||
(find-files #$input))))))
|
||||
|
||||
(computed-file "stylized-html-manual" build))
|
||||
|
||||
(define* (html-manual source #:key (languages %languages)
|
||||
(version "0.0")
|
||||
(manual %manual)
|
||||
@@ -870,11 +689,9 @@ makeinfo OPTIONS."
|
||||
(filter (compose file-exists? language->texi-file-name)
|
||||
'#$languages)))))
|
||||
|
||||
(let* ((name (string-append manual "-html-manual"))
|
||||
(manual* (computed-file name build #:local-build? #f)))
|
||||
(syntax-highlighted-html (stylized-html source manual*
|
||||
#:languages languages
|
||||
#:manual manual)
|
||||
(let* ((name (string-append manual "-html-manual"))
|
||||
(manual (computed-file name build)))
|
||||
(syntax-highlighted-html manual
|
||||
#:mono-node-indexes mono-node-indexes
|
||||
#:split-node-indexes split-node-indexes
|
||||
#:name (string-append name "-highlighted"))))
|
||||
@@ -892,22 +709,14 @@ makeinfo OPTIONS."
|
||||
#:languages languages
|
||||
#:date date))
|
||||
|
||||
(define texinfo-profile
|
||||
(profile
|
||||
(content (packages->manifest
|
||||
;; texi2dvi requires various command line tools.
|
||||
(list coreutils
|
||||
diffutils
|
||||
gawk
|
||||
grep
|
||||
sed
|
||||
tar
|
||||
texinfo
|
||||
texlive-base
|
||||
texlive-bin ;for GUIX_TEXMF
|
||||
texlive-epsf
|
||||
texlive-fonts-ec
|
||||
texlive-tex-texinfo)))))
|
||||
;; FIXME: This union works, except for the table of contents of non-English
|
||||
;; manuals, which contains escape sequences like "^^ca^^fe" instead of
|
||||
;; accented letters.
|
||||
;;
|
||||
;; (define texlive
|
||||
;; (texlive-union (list texlive-tex-texinfo
|
||||
;; texlive-generic-epsf
|
||||
;; texlive-fonts-ec)))
|
||||
|
||||
(define build
|
||||
(with-imported-modules '((guix build utils))
|
||||
@@ -924,12 +733,21 @@ makeinfo OPTIONS."
|
||||
(string-downcase language)))
|
||||
|
||||
;; Install a UTF-8 locale so that 'makeinfo' is at ease.
|
||||
(setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales
|
||||
"/lib/locale"))
|
||||
(setenv "GUIX_LOCPATH"
|
||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||
(setenv "LC_ALL" "en_US.utf8")
|
||||
(setenv "PATH" #+(file-append texinfo-profile "/bin"))
|
||||
(setenv "GUIX_TEXMF" #+(file-append texinfo-profile
|
||||
"/share/texmf-dist"))
|
||||
(setenv "PATH"
|
||||
(string-append #+(file-append texlive "/bin") ":"
|
||||
#+(file-append texinfo "/bin") ":"
|
||||
|
||||
;; Below are command-line tools needed by
|
||||
;; 'texi2dvi' and friends.
|
||||
#+(file-append sed "/bin") ":"
|
||||
#+(file-append grep "/bin") ":"
|
||||
#+(file-append coreutils "/bin") ":"
|
||||
#+(file-append gawk "/bin") ":"
|
||||
#+(file-append tar "/bin") ":"
|
||||
#+(file-append diffutils "/bin")))
|
||||
|
||||
(setvbuf (current-output-port) 'line)
|
||||
(setvbuf (current-error-port) 'line)
|
||||
@@ -976,11 +794,9 @@ PDF for language '~a'!~%~%"
|
||||
opts))))
|
||||
'#$languages))))
|
||||
|
||||
(computed-file (string-append manual "-pdf-manual") build
|
||||
#:local-build? #f))
|
||||
(computed-file (string-append manual "-pdf-manual") build))
|
||||
|
||||
(define* (guix-manual-text-domain source
|
||||
#:optional (languages %manual-languages))
|
||||
(define (guix-manual-text-domain source languages)
|
||||
"Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
|
||||
from SOURCE."
|
||||
(define po-directory
|
||||
@@ -1007,102 +823,6 @@ from SOURCE."
|
||||
|
||||
(computed-file "guix-manual-po" build))
|
||||
|
||||
(define* (localization-helper-module source
|
||||
#:optional (languages %languages))
|
||||
"Return a file-like object for use as the (localization) module. SOURCE
|
||||
must be the Guix top-level source directory, from which PO files are taken."
|
||||
(define content
|
||||
(with-extensions (list guile-json-3)
|
||||
#~(begin
|
||||
(define-module (localization)
|
||||
#:use-module (json)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 popen)
|
||||
#:export (normalize
|
||||
with-language
|
||||
translate
|
||||
language-code->name
|
||||
language-code->native-name
|
||||
seconds->string))
|
||||
|
||||
(define (normalize language) ;XXX: deduplicate
|
||||
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
||||
(string-map (match-lambda
|
||||
(#\_ #\-)
|
||||
(chr chr))
|
||||
(string-downcase language)))
|
||||
|
||||
(define-syntax-rule (with-language language exp ...)
|
||||
(let ((lang (getenv "LANGUAGE")))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(setenv "LANGUAGE" language)
|
||||
(setlocale LC_MESSAGES))
|
||||
(lambda () exp ...)
|
||||
(lambda ()
|
||||
(if lang
|
||||
(setenv "LANGUAGE" lang)
|
||||
(unsetenv "LANGUAGE"))
|
||||
(setlocale LC_MESSAGES)))))
|
||||
|
||||
;; (put 'with-language 'scheme-indent-function 1)
|
||||
(define* (translate str language
|
||||
#:key (domain "guix-manual"))
|
||||
(define exp
|
||||
`(begin
|
||||
(bindtextdomain "guix-manual"
|
||||
#+(guix-manual-text-domain source))
|
||||
(bindtextdomain "iso_639-3" ;language names
|
||||
#+(file-append iso-codes
|
||||
"/share/locale"))
|
||||
(setenv "LANGUAGE" ,language)
|
||||
(write (gettext ,str ,domain))))
|
||||
|
||||
;; Since the 'gettext' function caches msgid translations,
|
||||
;; regardless of $LANGUAGE, we have to spawn a new process each
|
||||
;; time we want to translate to a different language. Bah!
|
||||
(let* ((pipe (open-pipe* OPEN_READ
|
||||
#+(file-append guile-3.0
|
||||
"/bin/guile")
|
||||
"-c" (object->string exp)))
|
||||
(str (read pipe)))
|
||||
(close-pipe pipe)
|
||||
str))
|
||||
|
||||
(define %iso639-languages
|
||||
(vector->list
|
||||
(assoc-ref (call-with-input-file
|
||||
#+(file-append iso-codes
|
||||
"/share/iso-codes/json/iso_639-3.json")
|
||||
json->scm)
|
||||
"639-3")))
|
||||
|
||||
(define (language-code->name code)
|
||||
"Return the full name of a language from its ISO-639-3 code."
|
||||
(let ((code (match (string-index code #\_)
|
||||
(#f code)
|
||||
(index (string-take code index)))))
|
||||
(any (lambda (language)
|
||||
(and (string=? (or (assoc-ref language "alpha_2")
|
||||
(assoc-ref language "alpha_3"))
|
||||
code)
|
||||
(assoc-ref language "name")))
|
||||
%iso639-languages)))
|
||||
|
||||
(define (language-code->native-name code)
|
||||
"Return the name of language CODE in that language."
|
||||
(translate (language-code->name code) code
|
||||
#:domain "iso_639-3"))
|
||||
|
||||
(define (seconds->string seconds language)
|
||||
(let* ((time (make-time time-utc 0 seconds))
|
||||
(date (time-utc->date time)))
|
||||
(with-language language (date->string date "~e ~B ~Y")))))))
|
||||
|
||||
(scheme-file "localization.scm" content))
|
||||
|
||||
(define* (html-manual-indexes source
|
||||
#:key (languages %languages)
|
||||
(version "0.0")
|
||||
@@ -1112,132 +832,207 @@ must be the Guix top-level source directory, from which PO files are taken."
|
||||
"GNU Guix Cookbook"))
|
||||
(date 1))
|
||||
(define build
|
||||
(with-imported-modules `((guix build utils)
|
||||
((localization)
|
||||
=> ,(localization-helper-module
|
||||
source languages)))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(localization)
|
||||
(sxml simple)
|
||||
(srfi srfi-1))
|
||||
(with-extensions (list guile-json-3)
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(json)
|
||||
(ice-9 match)
|
||||
(ice-9 popen)
|
||||
(sxml simple)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-19))
|
||||
|
||||
(define (guix-url path)
|
||||
(string-append #$%web-site-url path))
|
||||
(define (normalize language) ;XXX: deduplicate
|
||||
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
||||
(string-map (match-lambda
|
||||
(#\_ #\-)
|
||||
(chr chr))
|
||||
(string-downcase language)))
|
||||
|
||||
(define (sxml-index language title body)
|
||||
;; FIXME: Avoid duplicating styling info from guix-artwork.git.
|
||||
`(html (@ (lang ,language))
|
||||
(head
|
||||
(title ,(string-append title " — GNU Guix"))
|
||||
(meta (@ (charset "UTF-8")))
|
||||
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
|
||||
;; Menu prefetch.
|
||||
(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
|
||||
;; Base CSS.
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
|
||||
(define-syntax-rule (with-language language exp ...)
|
||||
(let ((lang (getenv "LANGUAGE")))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(setenv "LANGUAGE" language)
|
||||
(setlocale LC_MESSAGES))
|
||||
(lambda () exp ...)
|
||||
(lambda ()
|
||||
(if lang
|
||||
(setenv "LANGUAGE" lang)
|
||||
(unsetenv "LANGUAGE"))
|
||||
(setlocale LC_MESSAGES)))))
|
||||
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
|
||||
(body
|
||||
(header (@ (class "navbar"))
|
||||
(h1 (a (@ (class "branding")
|
||||
(href #$%web-site-url)))
|
||||
(span (@ (class "a11y-offset"))
|
||||
"Guix"))
|
||||
(nav (@ (class "menu"))))
|
||||
(nav (@ (class "breadcrumbs"))
|
||||
(a (@ (class "crumb")
|
||||
(href #$%web-site-url))
|
||||
"Home"))
|
||||
,body
|
||||
(footer))))
|
||||
;; (put 'with-language 'scheme-indent-function 1)
|
||||
(define* (translate str language
|
||||
#:key (domain "guix-manual"))
|
||||
(define exp
|
||||
`(begin
|
||||
(bindtextdomain "guix-manual"
|
||||
#+(guix-manual-text-domain
|
||||
source
|
||||
languages))
|
||||
(bindtextdomain "iso_639-3" ;language names
|
||||
#+(file-append iso-codes
|
||||
"/share/locale"))
|
||||
(write (gettext ,str ,domain))))
|
||||
|
||||
(define (language-index language)
|
||||
(define title
|
||||
(translate #$title language))
|
||||
(with-language language
|
||||
;; Since the 'gettext' function caches msgid translations,
|
||||
;; regardless of $LANGUAGE, we have to spawn a new process each
|
||||
;; time we want to translate to a different language. Bah!
|
||||
(let* ((pipe (open-pipe* OPEN_READ
|
||||
#+(file-append guile-2.2
|
||||
"/bin/guile")
|
||||
"-c" (object->string exp)))
|
||||
(str (read pipe)))
|
||||
(close-pipe pipe)
|
||||
str)))
|
||||
|
||||
(sxml-index
|
||||
language title
|
||||
`(main
|
||||
(article
|
||||
(@ (class "page centered-block limit-width"))
|
||||
(h2 ,title)
|
||||
(p (@ (class "post-metadata centered-text"))
|
||||
#$version " — "
|
||||
,(seconds->string #$date language))
|
||||
(define (seconds->string seconds language)
|
||||
(let* ((time (make-time time-utc 0 seconds))
|
||||
(date (time-utc->date time)))
|
||||
(with-language language (date->string date "~e ~B ~Y"))))
|
||||
|
||||
(div
|
||||
(ul
|
||||
(li (a (@ (href "html_node"))
|
||||
"HTML, with a separate page per node"))
|
||||
(li (a (@ (href
|
||||
,(string-append
|
||||
#$manual
|
||||
(if (string=? language
|
||||
"en")
|
||||
""
|
||||
(string-append "."
|
||||
language))
|
||||
".html")))
|
||||
"HTML, entirely on one page"))
|
||||
,@(if (member language '("ru" "zh_CN"))
|
||||
'()
|
||||
`((li (a (@ (href ,(string-append
|
||||
#$manual
|
||||
(if (string=? language "en")
|
||||
""
|
||||
(string-append "."
|
||||
language))
|
||||
".pdf"))))
|
||||
"PDF")))))))))
|
||||
(define (guix-url path)
|
||||
(string-append #$%web-site-url path))
|
||||
|
||||
(define (top-level-index languages)
|
||||
(define title #$title)
|
||||
(sxml-index
|
||||
"en" title
|
||||
`(main
|
||||
(article
|
||||
(@ (class "page centered-block limit-width"))
|
||||
(h2 ,title)
|
||||
(div
|
||||
"This document is available in the following
|
||||
(define (sxml-index language title body)
|
||||
;; FIXME: Avoid duplicating styling info from guix-artwork.git.
|
||||
`(html (@ (lang ,language))
|
||||
(head
|
||||
(title ,(string-append title " — GNU Guix"))
|
||||
(meta (@ (charset "UTF-8")))
|
||||
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
|
||||
;; Menu prefetch.
|
||||
(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
|
||||
;; Base CSS.
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
|
||||
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
|
||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
|
||||
(body
|
||||
(header (@ (class "navbar"))
|
||||
(h1 (a (@ (class "branding")
|
||||
(href #$%web-site-url)))
|
||||
(span (@ (class "a11y-offset"))
|
||||
"Guix"))
|
||||
(nav (@ (class "menu"))))
|
||||
(nav (@ (class "breadcrumbs"))
|
||||
(a (@ (class "crumb")
|
||||
(href #$%web-site-url))
|
||||
"Home"))
|
||||
,body
|
||||
(footer))))
|
||||
|
||||
(define (language-index language)
|
||||
(define title
|
||||
(translate #$title language))
|
||||
|
||||
(sxml-index
|
||||
language title
|
||||
`(main
|
||||
(article
|
||||
(@ (class "page centered-block limit-width"))
|
||||
(h2 ,title)
|
||||
(p (@ (class "post-metadata centered-text"))
|
||||
#$version " — "
|
||||
,(seconds->string #$date language))
|
||||
|
||||
(div
|
||||
(ul
|
||||
(li (a (@ (href "html_node"))
|
||||
"HTML, with a separate page per node"))
|
||||
(li (a (@ (href
|
||||
,(string-append
|
||||
#$manual
|
||||
(if (string=? language
|
||||
"en")
|
||||
""
|
||||
(string-append "."
|
||||
language))
|
||||
".html")))
|
||||
"HTML, entirely on one page"))
|
||||
,@(if (member language '("ru" "zh_CN"))
|
||||
'()
|
||||
`((li (a (@ (href ,(string-append
|
||||
#$manual
|
||||
(if (string=? language "en")
|
||||
""
|
||||
(string-append "."
|
||||
language))
|
||||
".pdf"))))
|
||||
"PDF")))))))))
|
||||
|
||||
(define %iso639-languages
|
||||
(vector->list
|
||||
(assoc-ref (call-with-input-file
|
||||
#+(file-append iso-codes
|
||||
"/share/iso-codes/json/iso_639-3.json")
|
||||
json->scm)
|
||||
"639-3")))
|
||||
|
||||
(define (language-code->name code)
|
||||
"Return the full name of a language from its ISO-639-3 code."
|
||||
(let ((code (match (string-index code #\_)
|
||||
(#f code)
|
||||
(index (string-take code index)))))
|
||||
(any (lambda (language)
|
||||
(and (string=? (or (assoc-ref language "alpha_2")
|
||||
(assoc-ref language "alpha_3"))
|
||||
code)
|
||||
(assoc-ref language "name")))
|
||||
%iso639-languages)))
|
||||
|
||||
(define (top-level-index languages)
|
||||
(define title #$title)
|
||||
(sxml-index
|
||||
"en" title
|
||||
`(main
|
||||
(article
|
||||
(@ (class "page centered-block limit-width"))
|
||||
(h2 ,title)
|
||||
(div
|
||||
"This document is available in the following
|
||||
languages:\n"
|
||||
(ul
|
||||
,@(map (lambda (language)
|
||||
`(li (a (@ (href ,(normalize language)))
|
||||
,(language-code->native-name language))))
|
||||
languages)))))))
|
||||
(ul
|
||||
,@(map (lambda (language)
|
||||
`(li (a (@ (href ,(normalize language)))
|
||||
,(translate
|
||||
(language-code->name language)
|
||||
language
|
||||
#:domain "iso_639-3"))))
|
||||
languages)))))))
|
||||
|
||||
(define (write-html file sxml)
|
||||
(call-with-output-file file
|
||||
(lambda (port)
|
||||
(display "<!DOCTYPE html>\n" port)
|
||||
(sxml->xml sxml port))))
|
||||
(define (write-html file sxml)
|
||||
(call-with-output-file file
|
||||
(lambda (port)
|
||||
(display "<!DOCTYPE html>\n" port)
|
||||
(sxml->xml sxml port))))
|
||||
|
||||
(setenv "GUIX_LOCPATH"
|
||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||
(setenv "LC_ALL" "en_US.utf8")
|
||||
(setlocale LC_ALL "en_US.utf8")
|
||||
(setenv "GUIX_LOCPATH"
|
||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||
(setenv "LC_ALL" "en_US.utf8")
|
||||
(setlocale LC_ALL "en_US.utf8")
|
||||
|
||||
(for-each (lambda (language)
|
||||
(define directory
|
||||
(string-append #$output "/"
|
||||
(normalize language)))
|
||||
(for-each (lambda (language)
|
||||
(define directory
|
||||
(string-append #$output "/"
|
||||
(normalize language)))
|
||||
|
||||
(mkdir-p directory)
|
||||
(write-html (string-append directory "/index.html")
|
||||
(language-index language)))
|
||||
'#$languages)
|
||||
(mkdir-p directory)
|
||||
(write-html (string-append directory "/index.html")
|
||||
(language-index language)))
|
||||
'#$languages)
|
||||
|
||||
(write-html (string-append #$output "/index.html")
|
||||
(top-level-index '#$languages)))))
|
||||
(write-html (string-append #$output "/index.html")
|
||||
(top-level-index '#$languages))))))
|
||||
|
||||
(computed-file "html-indexes" build))
|
||||
|
||||
|
||||
+68
-702
@@ -26,10 +26,9 @@ choice.
|
||||
* Packaging Guidelines:: Growing the distribution.
|
||||
* Coding Style:: Hygiene of the contributor.
|
||||
* Submitting Patches:: Share your work.
|
||||
* Tracking Bugs and Patches:: Keeping it all organized.
|
||||
* Tracking Bugs and Patches:: Using Debbugs.
|
||||
* Commit Access:: Pushing to the official repository.
|
||||
* Updating the Guix Package:: Updating the Guix package definition.
|
||||
* Translating Guix:: Make Guix speak your native language.
|
||||
@end menu
|
||||
|
||||
@node Building from Git
|
||||
@@ -73,10 +72,10 @@ all the dependencies and appropriate environment variables are set up to
|
||||
hack on Guix:
|
||||
|
||||
@example
|
||||
guix shell -D guix --pure
|
||||
guix environment guix --pure
|
||||
@end example
|
||||
|
||||
@xref{Invoking guix shell}, for more information on that command.
|
||||
@xref{Invoking guix environment}, for more information on that command.
|
||||
|
||||
If you are unable to use Guix when building Guix from a checkout, the
|
||||
following are the required packages in addition to those mentioned in the
|
||||
@@ -92,20 +91,14 @@ installation instructions (@pxref{Requirements}).
|
||||
@end itemize
|
||||
|
||||
On Guix, extra dependencies can be added by instead running @command{guix
|
||||
shell}:
|
||||
environment} with @option{--ad-hoc}:
|
||||
|
||||
@example
|
||||
guix shell -D guix help2man git strace --pure
|
||||
guix environment guix --pure --ad-hoc help2man git strace
|
||||
@end example
|
||||
|
||||
From there you can generate the build system infrastructure
|
||||
using Autoconf and Automake:
|
||||
|
||||
@example
|
||||
./bootstrap
|
||||
@end example
|
||||
|
||||
If you get an error like this one:
|
||||
Run @command{./bootstrap} to generate the build system infrastructure
|
||||
using Autoconf and Automake. If you get an error like this one:
|
||||
|
||||
@example
|
||||
configure.ac:46: error: possibly undefined macro: PKG_CHECK_MODULES
|
||||
@@ -126,30 +119,17 @@ export ACLOCAL_PATH=/usr/share/aclocal
|
||||
@xref{Macro Search Path,,, automake, The GNU Automake Manual}, for
|
||||
more information.
|
||||
|
||||
Then, run:
|
||||
Then, run @command{./configure} as usual. Make sure to pass
|
||||
@code{--localstatedir=@var{directory}} where @var{directory} is the
|
||||
@code{localstatedir} value used by your current installation (@pxref{The
|
||||
Store}, for information about this), usually @file{/var}. Note that you
|
||||
will probably not run @command{make install} at the end (you don't have
|
||||
to) but it's still important to pass the right @code{localstatedir}.
|
||||
|
||||
@example
|
||||
./configure --localstatedir=/var
|
||||
@end example
|
||||
|
||||
@noindent
|
||||
... where @file{/var} is the normal @code{localstatedir} value
|
||||
(@pxref{The Store}, for information about this). Note that you will
|
||||
probably not run @command{make install} at the end (you don't have to)
|
||||
but it's still important to pass the right @code{localstatedir}.
|
||||
|
||||
Finally, you can build Guix and, if you feel so inclined, run the tests
|
||||
(@pxref{Running the Test Suite}):
|
||||
|
||||
@example
|
||||
make
|
||||
make check
|
||||
@end example
|
||||
|
||||
@noindent
|
||||
If anything fails, take a look at installation instructions
|
||||
(@pxref{Installation}) or send a message to the
|
||||
@email{guix-devel@@gnu.org, mailing list}.
|
||||
Finally, you have to invoke @code{make && make check} to build Guix and
|
||||
run the tests (@pxref{Running the Test Suite}). If anything fails, take
|
||||
a look at installation instructions (@pxref{Installation}) or send a
|
||||
message to the @email{guix-devel@@gnu.org, mailing list}.
|
||||
|
||||
From there on, you can authenticate all the commits included in your
|
||||
checkout by running:
|
||||
@@ -176,18 +156,6 @@ You are advised to run @command{make authenticate} after every
|
||||
changes to the repository.
|
||||
@end quotation
|
||||
|
||||
After updating the repository, @command{make} might fail with an error
|
||||
similar to the following example:
|
||||
|
||||
@example
|
||||
error: failed to load 'gnu/packages/dunst.scm':
|
||||
ice-9/eval.scm:293:34: In procedure abi-check: #<record-type <origin>>: record ABI mismatch; recompilation needed
|
||||
@end example
|
||||
|
||||
This means that one of the record types that Guix defines (in this
|
||||
example, the @code{origin} record) has changed, and all of guix needs
|
||||
to be recompiled to take that change into account. To do so, run
|
||||
@command{make clean-go} followed by @command{make}.
|
||||
|
||||
@node Running Guix Before It Is Installed
|
||||
@section Running Guix Before It Is Installed
|
||||
@@ -262,24 +230,6 @@ local source tree; it simply updates the @file{~/.config/guix/current}
|
||||
symlink (@pxref{Invoking guix pull}). Run @command{git pull} instead if
|
||||
you want to upgrade your local source tree.
|
||||
|
||||
Sometimes, especially if you have recently updated your repository,
|
||||
running @command{./pre-inst-env} will print a message similar to the
|
||||
following example:
|
||||
|
||||
@example
|
||||
;;; note: source file /home/user/projects/guix/guix/progress.scm
|
||||
;;; newer than compiled /home/user/projects/guix/guix/progress.go
|
||||
@end example
|
||||
|
||||
This is only a note and you can safely ignore it. You can get rid of
|
||||
the message by running @command{make -j4}. Until you do, Guile will run
|
||||
slightly slower because it will interpret the code instead of using
|
||||
prepared Guile object (@file{.go}) files.
|
||||
|
||||
You can run @command{make} automatically as you work using
|
||||
@command{watchexec} from the @code{watchexec} package. For example,
|
||||
to build again each time you update a package file, you can run
|
||||
@samp{watchexec -w gnu/packages make -j4}.
|
||||
|
||||
@node The Perfect Setup
|
||||
@section The Perfect Setup
|
||||
@@ -291,7 +241,7 @@ Manual}). First, you need more than an editor, you need
|
||||
wonderful @url{https://nongnu.org/geiser/, Geiser}. To set that up, run:
|
||||
|
||||
@example
|
||||
guix package -i emacs guile emacs-geiser emacs-geiser-guile
|
||||
guix package -i emacs guile emacs-geiser
|
||||
@end example
|
||||
|
||||
Geiser allows for interactive and incremental development from within
|
||||
@@ -425,12 +375,12 @@ Once your package builds correctly, please send us a patch
|
||||
(@pxref{Submitting Patches}). Well, if you need help, we will be happy to
|
||||
help you too. Once the patch is committed in the Guix repository, the
|
||||
new package automatically gets built on the supported platforms by
|
||||
@url{https://@value{SUBSTITUTE-SERVER-1}, our continuous integration system}.
|
||||
@url{@value{SUBSTITUTE-URL}, our continuous integration system}.
|
||||
|
||||
@cindex substituter
|
||||
Users can obtain the new package definition simply by running
|
||||
@command{guix pull} (@pxref{Invoking guix pull}). When
|
||||
@code{@value{SUBSTITUTE-SERVER-1}} is done building the package, installing the
|
||||
@code{@value{SUBSTITUTE-SERVER}} is done building the package, installing the
|
||||
package automatically downloads binaries from there
|
||||
(@pxref{Substitutes}). The only place where human intervention is
|
||||
needed is to review and apply the patch.
|
||||
@@ -447,7 +397,6 @@ needed is to review and apply the patch.
|
||||
* Perl Modules:: Little pearls.
|
||||
* Java Packages:: Coffee break.
|
||||
* Rust Crates:: Beware of oxidation.
|
||||
* Elm Packages:: Trees of browser code
|
||||
* Fonts:: Fond of fonts.
|
||||
@end menu
|
||||
|
||||
@@ -582,11 +531,9 @@ It is a good idea to strip commit identifiers in the @code{version}
|
||||
field to, say, 7 digits. It avoids an aesthetic annoyance (assuming
|
||||
aesthetics have a role to play here) as well as problems related to OS
|
||||
limits such as the maximum shebang length (127 bytes for the Linux
|
||||
kernel). There are helper functions for doing this for packages using
|
||||
@code{git-fetch} or @code{hg-fetch} (see below). It is best to use the
|
||||
full commit identifiers in @code{origin}s, though, to avoid ambiguities.
|
||||
A typical package definition may look like this:
|
||||
|
||||
kernel). It is best to use the full commit identifiers in
|
||||
@code{origin}s, though, to avoid ambiguities. A typical package
|
||||
definition may look like this:
|
||||
|
||||
@lisp
|
||||
(define my-package
|
||||
@@ -605,20 +552,6 @@ A typical package definition may look like this:
|
||||
)))
|
||||
@end lisp
|
||||
|
||||
@deffn {Scheme Procedure} git-version @var{VERSION} @var{REVISION} @var{COMMIT}
|
||||
Return the version string for packages using @code{git-fetch}.
|
||||
|
||||
@lisp
|
||||
(git-version "0.2.3" "0" "93818c936ee7e2f1ba1b315578bde363a7d43d05")
|
||||
@result{} "0.2.3-0.93818c9"
|
||||
@end lisp
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} hg-version @var{VERSION} @var{REVISION} @var{CHANGESET}
|
||||
Return the version string for packages using @code{hg-fetch}. It works
|
||||
in the same way as @code{git-version}.
|
||||
@end deffn
|
||||
|
||||
@node Synopses and Descriptions
|
||||
@subsection Synopses and Descriptions
|
||||
|
||||
@@ -745,7 +678,7 @@ package typically include a @file{snippets} directory, which could be
|
||||
copied to the installation directory using:
|
||||
|
||||
@lisp
|
||||
#:include (cons "^snippets/" %default-include)
|
||||
#:include (cons "^snippets/" %default-include))
|
||||
@end lisp
|
||||
|
||||
When encountering problems, it is wise to check for the presence of the
|
||||
@@ -899,87 +832,6 @@ developed for a different Operating System, depend on features from the Nightly
|
||||
Rust compiler, or the test suite may have atrophied since it was released.
|
||||
|
||||
|
||||
@node Elm Packages
|
||||
@subsection Elm Packages
|
||||
|
||||
@cindex Elm
|
||||
Elm applications can be named like other software: their names need not
|
||||
mention Elm.
|
||||
|
||||
Packages in the Elm sense (see @code{elm-build-system} under @ref{Build
|
||||
Systems}) are required use names of the format
|
||||
@var{author}@code{/}@var{project}, where both the @var{author} and the
|
||||
@var{project} may contain hyphens internally, and the @var{author} sometimes
|
||||
contains uppercase letters.
|
||||
|
||||
To form the Guix package name from the upstream name, we follow a convention
|
||||
similar to Python packages (@pxref{Python Modules}), adding an @code{elm-}
|
||||
prefix unless the name would already begin with @code{elm-}.
|
||||
|
||||
In many cases we can reconstruct an Elm package's upstream name heuristically,
|
||||
but, since conversion to a Guix-style name involves a loss of information,
|
||||
this is not always possible. Care should be taken to add the
|
||||
@code{'upstream-name} property when necessary so that @samp{guix import elm}
|
||||
will work correctly (@pxref{Invoking guix import}). The most notable scenarios
|
||||
when explicitly specifying the upstream name is necessary are:
|
||||
|
||||
@enumerate
|
||||
@item
|
||||
When the @var{author} is @code{elm} and the @var{project} contains one or more
|
||||
hyphens, as with @code{elm/virtual-dom}; and
|
||||
|
||||
@item
|
||||
When the @var{author} contains hyphens or uppercase letters, as with
|
||||
@code{Elm-Canvas/raster-shapes}---unless the @var{author} is
|
||||
@code{elm-explorations}, which is handled as a special case, so packages like
|
||||
@code{elm-explorations/markdown} do @emph{not} need to use the
|
||||
@code{'upstream-name} property.
|
||||
@end enumerate
|
||||
|
||||
The module @code{(guix build-system elm)} provides the following utilities for
|
||||
working with names and related conventions:
|
||||
|
||||
@deffn {Scheme procedure} elm-package-origin @var{elm-name} @var{version} @
|
||||
@var{hash}
|
||||
Returns a Git origin using the repository naming and tagging regime required
|
||||
for a published Elm package with the upstream name @var{elm-name} at version
|
||||
@var{version} with sha256 checksum @var{hash}.
|
||||
|
||||
For example:
|
||||
@lisp
|
||||
(package
|
||||
(name "elm-html")
|
||||
(version "1.0.0")
|
||||
(source
|
||||
(elm-package-origin
|
||||
"elm/html"
|
||||
version
|
||||
(base32 "15k1679ja57vvlpinpv06znmrxy09lbhzfkzdc89i01qa8c4gb4a")))
|
||||
...)
|
||||
@end lisp
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme procedure} elm->package-name @var{elm-name}
|
||||
Returns the Guix-style package name for an Elm package with upstream name
|
||||
@var{elm-name}.
|
||||
|
||||
Note that there is more than one possible @var{elm-name} for which
|
||||
@code{elm->package-name} will produce a given result.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme procedure} guix-package->elm-name @var{package}
|
||||
Given an Elm @var{package}, returns the possibly-inferred upstream name, or
|
||||
@code{#f} the upstream name is not specified via the @code{'upstream-name}
|
||||
property and can not be inferred by @code{infer-elm-package-name}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme procedure} infer-elm-package-name @var{guix-name}
|
||||
Given the @var{guix-name} of an Elm package, returns the inferred upstream
|
||||
name, or @code{#f} if the upstream name can't be inferred. If the result is
|
||||
not @code{#f}, supplying it to @code{elm->package-name} would produce
|
||||
@var{guix-name}.
|
||||
@end deffn
|
||||
|
||||
@node Fonts
|
||||
@subsection Fonts
|
||||
|
||||
@@ -1090,11 +942,17 @@ If you do not use Emacs, please make sure to let your editor knows these
|
||||
rules. To automatically indent a package definition, you can also run:
|
||||
|
||||
@example
|
||||
./pre-inst-env guix style @var{package}
|
||||
./etc/indent-code.el gnu/packages/@var{file}.scm @var{package}
|
||||
@end example
|
||||
|
||||
@noindent
|
||||
@xref{Invoking guix style}, for more information.
|
||||
This automatically indents the definition of @var{package} in
|
||||
@file{gnu/packages/@var{file}.scm} by running Emacs in batch mode. To
|
||||
indent a whole file, omit the second argument:
|
||||
|
||||
@example
|
||||
./etc/indent-code.el gnu/services/@var{file}.scm
|
||||
@end example
|
||||
|
||||
@cindex Vim, Scheme code editing
|
||||
If you are editing code with Vim, we recommend that you run @code{:set
|
||||
@@ -1117,12 +975,9 @@ keyword parameters for procedures that take more than four parameters.
|
||||
Development is done using the Git distributed version control system.
|
||||
Thus, access to the repository is not strictly necessary. We welcome
|
||||
contributions in the form of patches as produced by @code{git
|
||||
format-patch} sent to the @email{guix-patches@@gnu.org} mailing list
|
||||
(@pxref{submitting patches,, Submitting patches to a project, git, Git
|
||||
User Manual}). Contributors are encouraged to take a moment to set some
|
||||
Git repository options (@pxref{Configuring Git}) first, which can
|
||||
improve the readability of patches. Seasoned Guix developers may also
|
||||
want to look at the section on commit access (@pxref{Commit Access}).
|
||||
format-patch} sent to the @email{guix-patches@@gnu.org} mailing list.
|
||||
Seasoned Guix developers may also want to look at the section on commit
|
||||
access (@pxref{Commit Access}).
|
||||
|
||||
This mailing list is backed by a Debbugs instance, which allows us to
|
||||
keep track of submissions (@pxref{Tracking Bugs and Patches}). Each
|
||||
@@ -1139,15 +994,6 @@ Before submitting a patch that adds or modifies a package definition,
|
||||
please run through this check list:
|
||||
|
||||
@enumerate
|
||||
@cindex @code{git format-patch}
|
||||
@cindex @code{git-format-patch}
|
||||
@item
|
||||
When generating your patches with @code{git format-patch} or @code{git
|
||||
send-email}, we recommend using the option @code{--base=}, perhaps with
|
||||
the value @code{auto}. This option adds a note to the patch stating
|
||||
which commit the patch is based on. This helps reviewers understand how
|
||||
to apply and review your patches.
|
||||
|
||||
@item
|
||||
If the authors of the packaged software provide a cryptographic
|
||||
signature for the release tarball, make an effort to verify the
|
||||
@@ -1163,10 +1009,6 @@ Run @code{guix lint @var{package}}, where @var{package} is the
|
||||
name of the new or modified package, and fix any errors it reports
|
||||
(@pxref{Invoking guix lint}).
|
||||
|
||||
@item
|
||||
Run @code{guix style @var{package}} to format the new package definition
|
||||
according to the project's conventions (@pxref{Invoking guix style}).
|
||||
|
||||
@item
|
||||
Make sure the package builds on your platform, using @code{guix build
|
||||
@var{package}}.
|
||||
@@ -1175,21 +1017,20 @@ Make sure the package builds on your platform, using @code{guix build
|
||||
We recommend you also try building the package on other supported
|
||||
platforms. As you may not have access to actual hardware platforms, we
|
||||
recommend using the @code{qemu-binfmt-service-type} to emulate them. In
|
||||
order to enable it, add the @code{virtualization} service module and the
|
||||
following service to the list of services in your @code{operating-system}
|
||||
configuration:
|
||||
order to enable it, add the following service to the list of services in
|
||||
your @code{operating-system} configuration:
|
||||
|
||||
@lisp
|
||||
(service qemu-binfmt-service-type
|
||||
(qemu-binfmt-configuration
|
||||
(platforms (lookup-qemu-platforms "arm" "aarch64"))))
|
||||
(platforms (lookup-qemu-platforms "arm" "aarch64"))
|
||||
@end lisp
|
||||
|
||||
Then reconfigure your system.
|
||||
|
||||
You can then build packages for different platforms by specifying the
|
||||
@code{--system} option. For example, to build the "hello" package for
|
||||
the armhf or aarch64 architectures, you would run the following
|
||||
the armhf, aarch64, or mips64 architectures, you would run the following
|
||||
commands, respectively:
|
||||
@example
|
||||
guix build --system=armhf-linux --rounds=2 hello
|
||||
@@ -1220,7 +1061,7 @@ and which optional dependencies should be used. In particular, avoid adding
|
||||
the @code{texlive-tiny} package or @code{texlive-union} procedure instead.
|
||||
|
||||
@item
|
||||
For important changes, check that dependent packages (if applicable) are
|
||||
For important changes, check that dependent package (if applicable) are
|
||||
not affected by the change; @code{guix refresh --list-dependent
|
||||
@var{package}} will help you do that (@pxref{Invoking guix refresh}).
|
||||
|
||||
@@ -1238,17 +1079,15 @@ rebuilding induced, commits go to different branches, along these lines:
|
||||
@code{staging} branch (non-disruptive changes). This branch is intended
|
||||
to be merged in @code{master} every 6 weeks or so. Topical changes
|
||||
(e.g., an update of the GNOME stack) can instead go to a specific branch
|
||||
(say, @code{gnome-updates}). This branch is not expected to be
|
||||
buildable or usable until late in its development process.
|
||||
(say, @code{gnome-updates}).
|
||||
|
||||
@item more than 1,800 dependent packages
|
||||
@code{core-updates} branch (may include major and potentially disruptive
|
||||
changes). This branch is intended to be merged in @code{master} every
|
||||
6 months or so. This branch is not expected to be buildable or usable
|
||||
until late in its development process.
|
||||
6 months or so.
|
||||
@end table
|
||||
|
||||
All these branches are @uref{https://@value{SUBSTITUTE-SERVER-1},
|
||||
All these branches are @uref{@value{SUBSTITUTE-URL},
|
||||
tracked by our build farm} and merged into @code{master} once
|
||||
everything has been successfully built. This allows us to fix issues
|
||||
before they hit users, and to reduce the window during which pre-built
|
||||
@@ -1282,7 +1121,7 @@ as timestamps or randomly-generated output in the build result.
|
||||
|
||||
Another option is to use @command{guix challenge} (@pxref{Invoking guix
|
||||
challenge}). You may run it once the package has been committed and
|
||||
built by @code{@value{SUBSTITUTE-SERVER-1}} to check whether it obtains the same
|
||||
built by @code{@value{SUBSTITUTE-SERVER}} to check whether it obtains the same
|
||||
result as you did. Better yet: Find another machine that can build it
|
||||
and run @command{guix publish}. Since the remote build machine is
|
||||
likely different from yours, this can catch non-determinism issues
|
||||
@@ -1304,8 +1143,8 @@ Examples of unrelated changes include the addition of several packages,
|
||||
or a package update along with fixes to that package.
|
||||
|
||||
@item
|
||||
Please follow our code formatting rules, possibly running
|
||||
@command{guix style} script to do that automatically for you
|
||||
Please follow our code formatting rules, possibly running the
|
||||
@command{etc/indent-code.el} script to do that automatically for you
|
||||
(@pxref{Formatting Code}).
|
||||
|
||||
@item
|
||||
@@ -1338,54 +1177,14 @@ MIME attachments. You are advised to pay attention if your email client
|
||||
changes anything like line breaks or indentation which could potentially
|
||||
break the patches.
|
||||
|
||||
Expect some delay when you submit your very first patch to
|
||||
@email{guix-patches@@gnu.org}. You have to wait until you get an
|
||||
acknowledgement with the assigned tracking number. Future acknowledgements
|
||||
should not be delayed.
|
||||
|
||||
When a bug is resolved, please close the thread by sending an email to
|
||||
@email{@var{NNN}-done@@debbugs.gnu.org}.
|
||||
|
||||
@node Configuring Git
|
||||
@subsection Configuring Git
|
||||
@cindex git configuration
|
||||
@cindex @code{git format-patch}
|
||||
@cindex @code{git send-email}
|
||||
|
||||
If you have not done so already, you may wish to set a name and email
|
||||
that will be associated with your commits (@pxref{telling git your name,
|
||||
, Telling Git your name, git, Git User Manual}). If you wish to use a
|
||||
different name or email just for commits in this repository, you can
|
||||
use @command{git config --local}, or edit @file{.git/config} in the
|
||||
repository instead of @file{~/.gitconfig}.
|
||||
|
||||
We provide some default settings in @file{etc/git/gitconfig} which
|
||||
modify how patches are generated, making them easier to read and apply.
|
||||
These settings can be applied by manually copying them to
|
||||
@file{.git/config} in your checkout, or by telling Git to include the
|
||||
whole file:
|
||||
|
||||
@example
|
||||
git config --local include.path ../etc/git/gitconfig
|
||||
@end example
|
||||
|
||||
From then on, any changes to @file{etc/git/gitconfig} would
|
||||
automatically take effect.
|
||||
|
||||
Since the first patch in a series must be sent separately
|
||||
(@pxref{Sending a Patch Series}), it can also be helpful to tell
|
||||
@command{git format-patch} to handle the e-mail threading instead of
|
||||
@command{git send-email}:
|
||||
|
||||
@example
|
||||
git config --local format.thread shallow
|
||||
git config --local sendemail.thread no
|
||||
@end example
|
||||
|
||||
@unnumberedsubsec Sending a Patch Series
|
||||
@anchor{Sending a Patch Series}
|
||||
@cindex patch series
|
||||
@cindex @code{git send-email}
|
||||
@cindex @code{git-send-email}
|
||||
|
||||
When sending a patch series (e.g., using @code{git send-email}), please
|
||||
first send one message to @email{guix-patches@@gnu.org}, and then send
|
||||
@@ -1399,18 +1198,6 @@ for more information. You can install @command{git send-email} with
|
||||
@node Tracking Bugs and Patches
|
||||
@section Tracking Bugs and Patches
|
||||
|
||||
This section describes how the Guix project tracks its bug reports and
|
||||
patch submissions.
|
||||
|
||||
@menu
|
||||
* The Issue Tracker:: The official bug and patch tracker.
|
||||
* Debbugs User Interfaces:: Ways to interact with Debbugs.
|
||||
* Debbugs Usertags:: Tag reports with custom labels.
|
||||
@end menu
|
||||
|
||||
@node The Issue Tracker
|
||||
@subsection The Issue Tracker
|
||||
|
||||
@cindex bug reports, tracking
|
||||
@cindex patch submissions, tracking
|
||||
@cindex issue tracking
|
||||
@@ -1422,9 +1209,6 @@ email to @email{bug-guix@@gnu.org}, while patch submissions are filed
|
||||
against the @code{guix-patches} package by sending email to
|
||||
@email{guix-patches@@gnu.org} (@pxref{Submitting Patches}).
|
||||
|
||||
@node Debbugs User Interfaces
|
||||
@subsection Debbugs User Interfaces
|
||||
|
||||
A web interface (actually @emph{two} web interfaces!) are available to
|
||||
browse issues:
|
||||
|
||||
@@ -1462,77 +1246,12 @@ For example, to list all open issues on @code{guix-patches}, hit:
|
||||
@xref{Top,,, debbugs-ug, Debbugs User Guide}, for more information on
|
||||
this nifty tool!
|
||||
|
||||
@node Debbugs Usertags
|
||||
@subsection Debbugs Usertags
|
||||
|
||||
@cindex usertags, for debbugs
|
||||
@cindex Debbugs usertags
|
||||
Debbugs provides a feature called @dfn{usertags} that allows any user to
|
||||
tag any bug with an arbitrary label. Bugs can be searched by usertag,
|
||||
so this is a handy way to organize bugs@footnote{The list of usertags is
|
||||
public information, and anyone can modify any user's list of usertags,
|
||||
so keep that in mind if you choose to use this feature.}.
|
||||
|
||||
For example, to view all the bug reports (or patches, in the case of
|
||||
@code{guix-patches}) tagged with the usertag @code{powerpc64le-linux}
|
||||
for the user @code{guix}, open a URL like the following in a web
|
||||
browser:
|
||||
@url{https://debbugs.gnu.org/cgi-bin/pkgreport.cgi?tag=powerpc64le-linux;users=guix}.
|
||||
|
||||
For more information on how to use usertags, please refer to the
|
||||
documentation for Debbugs or the documentation for whatever tool you use
|
||||
to interact with Debbugs.
|
||||
|
||||
In Guix, we are experimenting with usertags to keep track of
|
||||
architecture-specific issues. To facilitate collaboration, all our
|
||||
usertags are associated with the single user @code{guix}. The following
|
||||
usertags currently exist for that user:
|
||||
|
||||
@table @code
|
||||
|
||||
@item powerpc64le-linux
|
||||
The purpose of this usertag is to make it easy to find the issues that
|
||||
matter most for the @code{powerpc64le-linux} system type. Please assign
|
||||
this usertag to bugs or patches that affect @code{powerpc64le-linux} but
|
||||
not other system types. In addition, you may use it to identify issues
|
||||
that for some reason are particularly important for the
|
||||
@code{powerpc64le-linux} system type, even if the issue affects other
|
||||
system types, too.
|
||||
|
||||
@item reproducibility
|
||||
For issues related to reproducibility. For example, it would be
|
||||
appropriate to assign this usertag to a bug report for a package that
|
||||
fails to build reproducibly.
|
||||
|
||||
@end table
|
||||
|
||||
If you're a committer and you want to add a usertag, just start using it
|
||||
with the @code{guix} user. If the usertag proves useful to you,
|
||||
consider updating this section of the manual so that others will know
|
||||
what your usertag means.
|
||||
|
||||
@node Commit Access
|
||||
@section Commit Access
|
||||
|
||||
@cindex commit access, for developers
|
||||
Everyone can contribute to Guix without having commit access
|
||||
(@pxref{Submitting Patches}). However, for frequent contributors,
|
||||
having write access to the repository can be convenient. As a rule of
|
||||
thumb, a contributor should have accumulated fifty (50) reviewed commits
|
||||
to be considered as a committer and have sustained their activity in the
|
||||
project for at least 6 months. This ensures enough interactions with
|
||||
the contributor, which is essential for mentoring and assessing whether
|
||||
they are ready to become a committer. Commit access should not be
|
||||
thought of as a ``badge of honor'' but rather as a responsibility a
|
||||
contributor is willing to take to help the project.
|
||||
|
||||
The following sections explain how to get commit access, how to be ready
|
||||
to push commits, and the policies and community expectations for commits
|
||||
pushed upstream.
|
||||
|
||||
@subsection Applying for Commit Access
|
||||
|
||||
When you deem it necessary, consider applying for commit
|
||||
For frequent contributors, having write access to the repository is
|
||||
convenient. When you deem it necessary, consider applying for commit
|
||||
access by following these steps:
|
||||
|
||||
@enumerate
|
||||
@@ -1604,29 +1323,6 @@ review and merging system, which, as a consequence, may lead us to have
|
||||
fewer people with commit access to the main repository. Stay tuned!
|
||||
@end quotation
|
||||
|
||||
All commits that are pushed to the central repository on Savannah must
|
||||
be signed with an OpenPGP key, and the public key should be uploaded to
|
||||
your user account on Savannah and to public key servers, such as
|
||||
@code{keys.openpgp.org}. To configure Git to automatically sign
|
||||
commits, run:
|
||||
|
||||
@example
|
||||
git config commit.gpgsign true
|
||||
|
||||
# Substitute the fingerprint of your public PGP key.
|
||||
git config user.signingkey CABBA6EA1DC0FF33
|
||||
@end example
|
||||
|
||||
You can prevent yourself from accidentally pushing unsigned commits to
|
||||
Savannah by using the pre-push Git hook located at
|
||||
@file{etc/git/pre-push}:
|
||||
|
||||
@example
|
||||
cp etc/git/pre-push .git/hooks/pre-push
|
||||
@end example
|
||||
|
||||
@subsection Commit Policy
|
||||
|
||||
If you get commit access, please make sure to follow
|
||||
the policy below (discussions of the policy can take place on
|
||||
@email{guix-devel@@gnu.org}).
|
||||
@@ -1645,6 +1341,25 @@ mailing list for commit notifications (@email{guix-commits@@gnu.org}),
|
||||
so people can notice. Before pushing your changes, make sure to run
|
||||
@code{git pull --rebase}.
|
||||
|
||||
All commits that are pushed to the central repository on Savannah must
|
||||
be signed with an OpenPGP key, and the public key should be uploaded to
|
||||
your user account on Savannah and to public key servers, such as
|
||||
@code{keys.openpgp.org}. To configure Git to automatically sign
|
||||
commits, run:
|
||||
|
||||
@example
|
||||
git config commit.gpgsign true
|
||||
git config user.signingkey CABBA6EA1DC0FF33
|
||||
@end example
|
||||
|
||||
You can prevent yourself from accidentally pushing unsigned commits to
|
||||
Savannah by using the pre-push Git hook called located at
|
||||
@file{etc/git/pre-push}:
|
||||
|
||||
@example
|
||||
cp etc/git/pre-push .git/hooks/pre-push
|
||||
@end example
|
||||
|
||||
When pushing a commit on behalf of somebody else, please add a
|
||||
@code{Signed-off-by} line at the end of the commit log message---e.g.,
|
||||
with @command{git am --signoff}. This improves tracking of who did
|
||||
@@ -1666,76 +1381,12 @@ you're confident, it's OK to commit.
|
||||
That last part is subject to being adjusted, allowing individuals to commit
|
||||
directly on non-controversial changes on parts they’re familiar with.
|
||||
|
||||
@subsection Addressing Issues
|
||||
|
||||
Peer review (@pxref{Submitting Patches}) and tools such as
|
||||
@command{guix lint} (@pxref{Invoking guix lint}) and the test suite
|
||||
(@pxref{Running the Test Suite}) should catch issues before they are
|
||||
pushed. Yet, commits that ``break'' functionality might occasionally
|
||||
go through. When that happens, there are two priorities: mitigating
|
||||
the impact, and understanding what happened to reduce the chance of
|
||||
similar incidents in the future. The responsibility for both these
|
||||
things primarily lies with those involved, but like everything this is
|
||||
a group effort.
|
||||
|
||||
Some issues can directly affect all users---for instance because they
|
||||
make @command{guix pull} fail or break core functionality, because they
|
||||
break major packages (at build time or run time), or because they
|
||||
introduce known security vulnerabilities.
|
||||
|
||||
@cindex reverting commits
|
||||
The people involved in authoring, reviewing, and pushing such
|
||||
commit(s) should be at the forefront to mitigate their impact in a
|
||||
timely fashion: by pushing a followup commit to fix it (if possible),
|
||||
or by reverting it to leave time to come up with a proper fix, and by
|
||||
communicating with other developers about the problem.
|
||||
|
||||
If these persons are unavailable to address the issue in time, other
|
||||
committers are entitled to revert the commit(s), explaining in the
|
||||
commit log and on the mailing list what the problem was, with the goal
|
||||
of leaving time to the original committer, reviewer(s), and author(s)
|
||||
to propose a way forward.
|
||||
|
||||
Once the problem has been dealt with, it is the responsibility of
|
||||
those involved to make sure the situation is understood. If you are
|
||||
working to understand what happened, focus on gathering information
|
||||
and avoid assigning any blame. Do ask those involved to describe what
|
||||
happened, do not ask them to explain the situation---this would
|
||||
implicitly blame them, which is unhelpful. Accountability comes from
|
||||
a consensus about the problem, learning from it and improving
|
||||
processes so that it's less likely to reoccur.
|
||||
|
||||
@subsection Commit Revocation
|
||||
|
||||
In order to reduce the possibility of mistakes, committers will have
|
||||
their Savannah account removed from the Guix Savannah project and their
|
||||
key removed from @file{.guix-authorizations} after 12 months of
|
||||
inactivity; they can ask to regain commit access by emailing the
|
||||
maintainers, without going through the vouching process.
|
||||
|
||||
Maintainers@footnote{See @uref{https://guix.gnu.org/en/about} for the
|
||||
current list of maintainers. You can email them privately at
|
||||
@email{guix-maintainers@@gnu.org}.} may also revoke an individual's
|
||||
commit rights, as a last resort, if cooperation with the rest of the
|
||||
community has caused too much friction---even within the bounds of the
|
||||
project's code of conduct (@pxref{Contributing}). They would only do so
|
||||
after public or private discussion with the individual and a clear
|
||||
notice. Examples of behavior that hinders cooperation and could lead to
|
||||
such a decision include:
|
||||
|
||||
@itemize
|
||||
@item repeated violation of the commit policy stated above;
|
||||
@item repeated failure to take peer criticism into account;
|
||||
@item breaching trust through a series of grave incidents.
|
||||
@end itemize
|
||||
|
||||
When maintainers resort to such a decision, they notify developers on
|
||||
@email{guix-devel@@gnu.org}; inquiries may be sent to
|
||||
@email{guix-maintainers@@gnu.org}. Depending on the situation, the
|
||||
individual may still be welcome to contribute.
|
||||
|
||||
@subsection Helping Out
|
||||
|
||||
One last thing: the project keeps moving forward because committers not
|
||||
only push their own awesome changes, but also offer some of their time
|
||||
@emph{reviewing} and pushing other people's changes. As a committer,
|
||||
@@ -1778,288 +1429,3 @@ This check can be disabled, @emph{at your own peril}, by setting the
|
||||
@code{GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT} environment variable. When
|
||||
this variable is set, the updated package source is also added to the
|
||||
store. This is used as part of the release process of Guix.
|
||||
|
||||
@cindex translation
|
||||
@cindex l10n
|
||||
@cindex i18n
|
||||
@cindex native language support
|
||||
@node Translating Guix
|
||||
@section Translating Guix
|
||||
|
||||
Writing code and packages is not the only way to provide a meaningful
|
||||
contribution to Guix. Translating to a language you speak is another
|
||||
example of a valuable contribution you can make. This section is designed
|
||||
to describe the translation process. It gives you advice on how you can
|
||||
get involved, what can be translated, what mistakes you should avoid and
|
||||
what we can do to help you!
|
||||
|
||||
Guix is a big project that has multiple components that can be translated.
|
||||
We coordinate the translation effort on a
|
||||
@uref{https://translate.fedoraproject.org/projects/guix/,Weblate instance}
|
||||
hosted by our friends at Fedora. You will need an account to submit
|
||||
translations.
|
||||
|
||||
Some of the software packaged in Guix also contain translations. We do not
|
||||
host a translation platform for them. If you want to translate a package
|
||||
provided by Guix, you should contact their developers or find the information
|
||||
on their website. As an example, you can find the homepage of the
|
||||
@code{hello} package by typing @code{guix show hello}. On the ``homepage''
|
||||
line, you will see @url{https://www.gnu.org/software/hello/} as the homepage.
|
||||
|
||||
Many GNU and non-GNU packages can be translated on the
|
||||
@uref{https://translationproject.org,Translation Project}. Some projects
|
||||
with multiple components have their own platform. For instance, GNOME has
|
||||
its own platform, @uref{https://l10n.gnome.org/,Damned Lies}.
|
||||
|
||||
Guix has five components hosted on Weblate.
|
||||
|
||||
@itemize
|
||||
@item @code{guix} contains all the strings from the Guix software (the
|
||||
guided system installer, the package manager, etc), excluding packages.
|
||||
@item @code{packages} contains the synopsis (single-sentence description
|
||||
of a package) and description (longer description) of packages in Guix.
|
||||
@item @code{website} contains the official Guix website, except for
|
||||
blog posts and multimedia content.
|
||||
@item @code{documentation-manual} corresponds to this manual.
|
||||
@item @code{documentation-cookbook} is the component for the cookbook.
|
||||
@end itemize
|
||||
|
||||
@subsubheading General Directions
|
||||
|
||||
Once you get an account, you should be able to select a component from
|
||||
@uref{https://translate.fedoraproject.org/projects/guix/,the guix project},
|
||||
and select a language. If your language does not appear in the list, go
|
||||
to the bottom and click on the ``Start new translation'' button. Select
|
||||
the language you want to translate to from the list, to start your new
|
||||
translation.
|
||||
|
||||
Like lots of other free software packages, Guix uses
|
||||
@uref{https://www.gnu.org/software/gettext,GNU Gettext} for its translations,
|
||||
with which translatable strings are extracted from the source code to so-called
|
||||
PO files.
|
||||
|
||||
Even though PO files are text files, changes should not be made with a text
|
||||
editor but with PO editing software. Weblate integrates PO editing
|
||||
functionality. Alternatively, translators can use any of various
|
||||
free-software tools for filling in translations, of which
|
||||
@uref{https://poedit.net/,Poedit} is one example, and (after logging in)
|
||||
@uref{https://docs.weblate.org/en/latest/user/files.html,upload} the changed
|
||||
file. There is also a special
|
||||
@uref{https://www.emacswiki.org/emacs/PoMode,PO editing mode} for users of GNU
|
||||
Emacs. Over time translators find out what software they are happy with and
|
||||
what features they need.
|
||||
|
||||
On Weblate, you will find various links to the editor, that will show various
|
||||
subsets (or all) of the strings. Have a look around and at the
|
||||
@uref{https://docs.weblate.org/en/latest/,documentation} to familiarize
|
||||
yourself with the platform.
|
||||
|
||||
@subsubheading Translation Components
|
||||
|
||||
In this section, we provide more detailed guidance on the translation
|
||||
process, as well as details on what you should or should not do. When in
|
||||
doubt, please contact us, we will be happy to help!
|
||||
|
||||
@table @asis
|
||||
@item guix
|
||||
Guix is written in the Guile programming language, and some strings contain
|
||||
special formatting that is interpreted by Guile. These special formatting
|
||||
should be highlighted by Weblate. They start with @code{~} followed by one
|
||||
or more characters.
|
||||
|
||||
When printing the string, Guile replaces the special formatting symbols with
|
||||
actual values. For instance, the string @samp{ambiguous package specification
|
||||
`~a'} would be substituted to contain said package specification instead of
|
||||
@code{~a}. To properly translate this string, you must keep the formatting
|
||||
code in your translation, although you can place it where it makes sense in
|
||||
your language. For instance, the French translation says @samp{spécification
|
||||
du paquet « ~a » ambiguë} because the adjective needs to be placed in the
|
||||
end of the sentence.
|
||||
|
||||
If there are multiple formatting symbols, make sure to respect the order.
|
||||
Guile does not know in which order you intended the string to be read, so it
|
||||
will substitute the symbols in the same order as the English sentence.
|
||||
|
||||
As an example, you cannot translate @samp{package '~a' has been superseded by
|
||||
'~a'} by @samp{'~a' superseeds package '~a'}, because the meaning would be
|
||||
reversed. If @var{foo} is superseded by @var{bar}, the translation would read
|
||||
@samp{'foo' superseeds package 'bar'}. To work around this problem, it
|
||||
is possible to use more advanced formatting to select a given piece of data,
|
||||
instead of following the default English order. @xref{Formatted Output,,,
|
||||
guile, GNU Guile Reference Manual}, for more information on formatting in Guile.
|
||||
|
||||
@item packages
|
||||
|
||||
Package descriptions occasionally contain Texinfo markup (@pxref{Synopses
|
||||
and Descriptions}). Texinfo markup looks like @samp{@@code@{rm -rf@}},
|
||||
@samp{@@emph@{important@}}, etc. When translating, please leave markup as is.
|
||||
|
||||
The characters after ``@@'' form the name of the markup, and the text between
|
||||
``@{'' and ``@}'' is its content. In general, you should not translate the
|
||||
content of markup like @code{@@code}, as it contains literal code that do not
|
||||
change with language. You can translate the content of formatting markup such
|
||||
as @code{@@emph}, @code{@@i}, @code{@@itemize}, @code{@@item}. However, do
|
||||
not translate the name of the markup, or it will not be recognized. Do
|
||||
not translate the word after @code{@@end}, it is the name of the markup that
|
||||
is closed at this position (e.g.@: @code{@@itemize ... @@end itemize}).
|
||||
|
||||
@item documentation-manual and documentation-cookbook
|
||||
|
||||
The first step to ensure a successful translation of the manual is to find
|
||||
and translate the following strings @emph{first}:
|
||||
|
||||
@itemize
|
||||
@item @code{version.texi}: Translate this string as @code{version-xx.texi},
|
||||
where @code{xx} is your language code (the one shown in the URL on
|
||||
weblate).
|
||||
@item @code{contributing.texi}: Translate this string as
|
||||
@code{contributing.xx.texi}, where @code{xx} is the same language code.
|
||||
@item @code{Top}: Do not translate this string, it is important for Texinfo.
|
||||
If you translate it, the document will be empty (missing a Top node).
|
||||
Please look for it, and register @code{Top} as its translation.
|
||||
@end itemize
|
||||
|
||||
Translating these strings first ensure we can include your translation in
|
||||
the guix repository without breaking the make process or the
|
||||
@command{guix pull} machinery.
|
||||
|
||||
The manual and the cookbook both use Texinfo. As for @code{packages}, please
|
||||
keep Texinfo markup as is. There are more possible markup types in the manual
|
||||
than in the package descriptions. In general, do not translate the content
|
||||
of @code{@@code}, @code{@@file}, @code{@@var}, @code{@@value}, etc. You
|
||||
should translate the content of formatting markup such as @code{@@emph},
|
||||
@code{@@i}, etc.
|
||||
|
||||
The manual contains sections that can be referred to by name by @code{@@ref},
|
||||
@code{@@xref} and @code{@@pxref}. We have a mechanism in place so you do
|
||||
not have to translate their content. If you keep the English title, we will
|
||||
automatically replace it with your translation of that title. This ensures
|
||||
that Texinfo will always be able to find the node. If you decide to change
|
||||
the translation of the title, the references will automatically be updated
|
||||
and you will not have to update them all yourself.
|
||||
|
||||
When translating references from the cookbook to the manual, you need to
|
||||
replace the name of the manual and the name of the section. For instance,
|
||||
to translate @code{@@pxref@{Defining Packages,,, guix, GNU Guix Reference
|
||||
Manual@}}, you would replace @code{Defining Packages} with the title of that
|
||||
section in the translated manual @emph{only} if that title is translated.
|
||||
If the title is not translated in your language yet, do not translate it here,
|
||||
or the link will be broken. Replace @code{guix} with @code{guix.xx} where
|
||||
@code{xx} is your language code. @code{GNU Guix Reference Manual} is the
|
||||
text of the link. You can translate it however you wish.
|
||||
|
||||
@item website
|
||||
|
||||
The website pages are written using SXML, an s-expression version of HTML,
|
||||
the basic language of the web. We have a process to extract translatable
|
||||
strings from the source, and replace complex s-expressions with a more familiar
|
||||
XML markup, where each markup is numbered. Translators can arbitrarily change
|
||||
the ordering, as in the following example.
|
||||
|
||||
@example
|
||||
#. TRANSLATORS: Defining Packages is a section name
|
||||
#. in the English (en) manual.
|
||||
#: apps/base/templates/about.scm:64
|
||||
msgid "Packages are <1>defined<1.1>en</1.1><1.2>Defining-Packages.html</1.2></1> as native <2>Guile</2> modules."
|
||||
msgstr "Pakete werden als reine <2>Guile</2>-Module <1>definiert<1.1>de</1.1><1.2>Pakete-definieren.html</1.2></1>."
|
||||
@end example
|
||||
|
||||
Note that you need to include the same markups. You cannot skip any.
|
||||
@end table
|
||||
|
||||
In case you make a mistake, the component might fail to build properly with your
|
||||
language, or even make guix pull fail. To prevent that, we have a process
|
||||
in place to check the content of the files before pushing to our repository.
|
||||
We will not be able to update the translation for your language in Guix, so
|
||||
we will notify you (through weblate and/or by email) so you get a chance to
|
||||
fix the issue.
|
||||
|
||||
@subsubheading Outside of Weblate
|
||||
|
||||
Currently, some parts of Guix cannot be translated on Weblate, help wanted!
|
||||
|
||||
@itemize
|
||||
@item @command{guix pull} news can be translated in @file{news.scm}, but is not
|
||||
available from Weblate. If you want to provide a translation, you
|
||||
can prepare a patch as described above, or simply send us your
|
||||
translation with the name of the news entry you translated and your
|
||||
language. @xref{Writing Channel News}, for more information about
|
||||
channel news.
|
||||
@item Guix blog posts cannot currently be translated.
|
||||
@item The installer script (for foreign distributions) is entirely in English.
|
||||
@item Some of the libraries Guix uses cannot be translated or are translated
|
||||
outside of the Guix project. Guile itself is not internationalized.
|
||||
@item Other manuals linked from this manual or the cookbook might not be
|
||||
translated.
|
||||
@end itemize
|
||||
|
||||
@subsubheading Conditions for Inclusion
|
||||
|
||||
There are no conditions for adding new translations of the @code{guix} and
|
||||
@code{guix-packages} components, other than they need at least one translated
|
||||
string. New languages will be added to Guix as soon as possible. The
|
||||
files may be removed if they fall out of sync and have no more translated
|
||||
strings.
|
||||
|
||||
Given that the web site is dedicated to new users, we want its translation
|
||||
to be as complete as possible before we include it in the language menu.
|
||||
For a new language to be included, it needs to reach at least 80% completion.
|
||||
When a language is included, it may be removed in the future if it stays
|
||||
out of sync and falls below 60% completion.
|
||||
|
||||
The manual and cookbook are automatically added in the default compilation
|
||||
target. Every time we synchronize translations, developers need to
|
||||
recompile all the translated manuals and cookbooks. This is useless for what
|
||||
is essentially the English manual or cookbook. Therefore, we will only
|
||||
include a new language when it reaches 10% completion in the component.
|
||||
When a language is included, it may be removed in the future if it stays
|
||||
out of sync and falls below 5% completion.
|
||||
|
||||
@subsubheading Translation Infrastructure
|
||||
|
||||
Weblate is backed by a git repository from which it discovers new strings to
|
||||
translate and pushes new and updated translations. Normally, it would be
|
||||
enough to give it commit access to our repositories. However, we decided
|
||||
to use a separate repository for two reasons. First, we would have to give
|
||||
Weblate commit access and authorize its signing key, but we do not trust it
|
||||
in the same way we trust guix developers, especially since we do not manage
|
||||
the instance ourselves. Second, if translators mess something up, it can
|
||||
break the generation of the website and/or guix pull for all our users,
|
||||
independently of their language.
|
||||
|
||||
For these reasons, we use a dedicated repository to host translations, and we
|
||||
synchronize it with our guix and artworks repositories after checking no issue
|
||||
was introduced in the translation.
|
||||
|
||||
Developers can download the latest PO files from weblate in the Guix
|
||||
repository by running the @command{make download-po} command. It will
|
||||
automatically download the latest files from weblate, reformat them to a
|
||||
canonical form, and check they do not contain issues. The manual needs to be
|
||||
built again to check for additional issues that might crash Texinfo.
|
||||
|
||||
Before pushing new translation files, developers should add them to the
|
||||
make machinery so the translations are actually available. The process
|
||||
differs for the various components.
|
||||
|
||||
@itemize
|
||||
@item New po files for the @code{guix} and @code{packages} components must
|
||||
be registered by adding the new language to @file{po/guix/LINGUAS} or
|
||||
@file{po/packages/LINGUAS}.
|
||||
@item New po files for the @code{documentation-manual} component must be
|
||||
registered by adding the file name to @code{DOC_PO_FILES} in
|
||||
@file{po/doc/local.mk}, the generated @file{%D%/guix.xx.texi} manual to
|
||||
@code{info_TEXINFOS} in @file{doc/local.mk} and the generated
|
||||
@file{%D%/guix.xx.texi} and @file{%D%/contributing.xx.texi} to
|
||||
@code{TRANSLATED_INFO} also in @file{doc/local.mk}.
|
||||
@item New po files for the @code{documentation-cookbook} component must be
|
||||
registered by adding the file name to @code{DOC_COOKBOOK_PO_FILES} in
|
||||
@file{po/doc/local.mk}, the generated @file{%D%/guix-cookbook.xx.texi}
|
||||
manual to @code{info_TEXINFOS} in @file{doc/local.mk} and the generated
|
||||
@file{%D%/guix-cookbook.xx.texi} to @code{TRANSLATED_INFO} also
|
||||
in @file{doc/local.mk}.
|
||||
@item New po files for the @code{website} component must be added to the
|
||||
@code{guix-artwork} repository, in @file{website/po/}.
|
||||
@file{website/po/LINGUAS} and @file{website/po/ietf-tags.scm} must
|
||||
be updated accordingly (see @file{website/i18n-howto.txt} for more
|
||||
information on the process).
|
||||
@end itemize
|
||||
|
||||
@@ -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))))
|
||||
|
||||
+95
-143
@@ -7,9 +7,6 @@
|
||||
@settitle GNU Guix Cookbook
|
||||
@c %**end of header
|
||||
|
||||
@c Onion service for ci.guix.gnu.org.
|
||||
@set SUBSTITUTE-TOR-URL https://4zwzi66wwdaalbhgnix55ea3ab4pvvw66ll2ow53kjub6se4q2bclcyd.onion
|
||||
|
||||
@copying
|
||||
Copyright @copyright{} 2019 Ricardo Wurmus@*
|
||||
Copyright @copyright{} 2019 Efraim Flashner@*
|
||||
@@ -19,8 +16,7 @@ Copyright @copyright{} 2020 Matthew Brooks@*
|
||||
Copyright @copyright{} 2020 Marcin Karpezo@*
|
||||
Copyright @copyright{} 2020 Brice Waegeneire@*
|
||||
Copyright @copyright{} 2020 André Batista@*
|
||||
Copyright @copyright{} 2020 Christine Lemmer-Webber@*
|
||||
Copyright @copyright{} 2021 Joshua Branson@*
|
||||
Copyright @copyright{} 2020 Christopher Lemmer Webber
|
||||
|
||||
Permission is granted to copy, distribute and/or modify this document
|
||||
under the terms of the GNU Free Documentation License, Version 1.3 or
|
||||
@@ -60,12 +56,10 @@ its API, and related concepts.
|
||||
@c TRANSLATORS: You can replace the following paragraph with information on
|
||||
@c how to join your own translation team and how to report issues with the
|
||||
@c translation.
|
||||
This manual is also available in French (@pxref{Top,,, guix-cookbook.fr,
|
||||
Livre de recettes de GNU Guix}) and German (@pxref{Top,,,
|
||||
guix-cookbook.de, GNU-Guix-Kochbuch}). If you would like to translate
|
||||
this document in your native language, consider joining
|
||||
If you would like to translate this document in your native language, consider
|
||||
joining
|
||||
@uref{https://translate.fedoraproject.org/projects/guix/documentation-cookbook,
|
||||
Weblate} (@pxref{Translating Guix,,, guix, GNU Guix reference manual}).
|
||||
Weblate}.
|
||||
|
||||
@menu
|
||||
* Scheme tutorials:: Meet your new favorite language!
|
||||
@@ -91,8 +85,8 @@ Packaging
|
||||
|
||||
System Configuration
|
||||
|
||||
* Auto-Login to a Specific TTY:: Automatically Login a User to a Specific TTY
|
||||
* Customizing the Kernel:: Creating and using a custom Linux kernel on Guix System.
|
||||
* Customizing the Kernel:: Creating and using a custom Linux kernel
|
||||
|
||||
|
||||
@end detailmenu
|
||||
@end menu
|
||||
@@ -296,7 +290,7 @@ online}, together with
|
||||
@uref{https://ocw.mit.edu/courses/electrical-engineering-and-computer-science/6-001-structure-and-interpretation-of-computer-programs-spring-2005/video-lectures/,
|
||||
videos of the lectures by the authors}. The book is available in Texinfo
|
||||
format as the @code{sicp} Guix package. Go ahead, run @code{guix install
|
||||
sicp} and start reading with @code{info sicp} (@pxref{Top,,, sicp, Structure and Interpretation of Computer Programs}).
|
||||
sicp} and start reading with @code{info sicp} (@pxref{,,, sicp, Structure and Interpretation of Computer Programs}).
|
||||
An @uref{https://sarabander.github.io/sicp/, unofficial ebook is also
|
||||
available}.
|
||||
|
||||
@@ -596,7 +590,7 @@ packages.
|
||||
Guix makes it possible to streamline the process by adding as many ``package
|
||||
declaration directories'' as you want.
|
||||
|
||||
Create a directory, say @file{~/guix-packages} and add it to the @samp{GUIX_PACKAGE_PATH}
|
||||
Create a directory, say @file{~./guix-packages} and add it to the @samp{GUIX_PACKAGE_PATH}
|
||||
environment variable:
|
||||
|
||||
@example
|
||||
@@ -798,8 +792,10 @@ another, more sophisticated package (slightly modified from the source):
|
||||
"17pjvprmdrx4h6bb1hhc98w9qi6ki7yl57f090n9kbhswxqfs7s3"))
|
||||
(patches (search-patches "libgit2-mtime-0.patch"))
|
||||
(modules '((guix build utils)))
|
||||
;; Remove bundled software.
|
||||
(snippet '(delete-file-recursively "deps"))))
|
||||
(snippet '(begin
|
||||
;; Remove bundled software.
|
||||
(delete-file-recursively "deps")
|
||||
#true))))
|
||||
(build-system cmake-build-system)
|
||||
(outputs '("out" "debug"))
|
||||
(arguments
|
||||
@@ -813,19 +809,23 @@ another, more sophisticated package (slightly modified from the source):
|
||||
(("#!/bin/sh") (string-append "#!" (which "sh"))))
|
||||
(substitute* "tests/clar/fs.h"
|
||||
(("/bin/cp") (which "cp"))
|
||||
(("/bin/rm") (which "rm")))))
|
||||
(("/bin/rm") (which "rm")))
|
||||
#true))
|
||||
;; Run checks more verbosely.
|
||||
(replace 'check
|
||||
(lambda _ (invoke "./libgit2_clar" "-v" "-Q")))
|
||||
(add-after 'unpack 'make-files-writable-for-tests
|
||||
(lambda _ (for-each make-file-writable (find-files "." ".*")))))))
|
||||
(inputs
|
||||
(list libssh2 http-parser python-wrapper))
|
||||
`(("libssh2" ,libssh2)
|
||||
("http-parser" ,http-parser)
|
||||
("python" ,python-wrapper)))
|
||||
(native-inputs
|
||||
(list pkg-config))
|
||||
`(("pkg-config" ,pkg-config)))
|
||||
(propagated-inputs
|
||||
;; These two libraries are in 'Requires.private' in libgit2.pc.
|
||||
(list openssl zlib))
|
||||
`(("openssl" ,openssl)
|
||||
("zlib" ,zlib)))
|
||||
(home-page "https://libgit2.github.com/")
|
||||
(synopsis "Library providing Git core methods")
|
||||
(description
|
||||
@@ -889,6 +889,22 @@ Snippets might need additional Guile modules which can be imported from the
|
||||
|
||||
@subsubsection Inputs
|
||||
|
||||
First, a syntactic comment: See the quasi-quote / comma syntax?
|
||||
|
||||
@lisp
|
||||
(native-inputs
|
||||
`(("pkg-config" ,pkg-config)))
|
||||
@end lisp
|
||||
|
||||
is equivalent to
|
||||
|
||||
@lisp
|
||||
(native-inputs
|
||||
(list (list "pkg-config" pkg-config)))
|
||||
@end lisp
|
||||
|
||||
You'll mostly see the former because it's shorter.
|
||||
|
||||
There are 3 different input types. In short:
|
||||
|
||||
@table @asis
|
||||
@@ -903,7 +919,7 @@ Installed in the store and in the profile, as well as
|
||||
being present at build time.
|
||||
@end table
|
||||
|
||||
@xref{package Reference,,, guix, GNU Guix Reference Manual} for more details.
|
||||
@xref{Package Reference,,, guix, GNU Guix Reference Manual} for more details.
|
||||
|
||||
The distinction between the various inputs is important: if a dependency can be
|
||||
handled as an @emph{input} instead of a @emph{propagated input}, it should be done so, or
|
||||
@@ -922,24 +938,6 @@ It also matters when a substitute is available, in which case only the @emph{inp
|
||||
and @emph{propagated inputs} will be fetched: the @emph{native inputs} are not required to
|
||||
install a package from a substitute.
|
||||
|
||||
@quotation Note
|
||||
You may see here and there snippets where package inputs are written
|
||||
quite differently, like so:
|
||||
|
||||
@lisp
|
||||
;; The "old style" for inputs.
|
||||
(inputs
|
||||
`(("libssh2" ,libssh2)
|
||||
("http-parser" ,http-parser)
|
||||
("python" ,python-wrapper)))
|
||||
@end lisp
|
||||
|
||||
This is the ``old style'', where each input in the list is explicitly
|
||||
given a label (a string). It is still supported but we recommend using
|
||||
the style above instead. @xref{package Reference,,, guix, GNU Guix
|
||||
Reference Manual}, for more info.
|
||||
@end quotation
|
||||
|
||||
@subsubsection Outputs
|
||||
|
||||
Just like how a package can have multiple inputs, it can also produce multiple
|
||||
@@ -1225,7 +1223,10 @@ $ guix import cran --recursive walrus
|
||||
"1nk2glcvy4hyksl5ipq2mz8jy4fss90hx6cq98m3w96kzjni6jjj"))))
|
||||
(build-system r-build-system)
|
||||
(propagated-inputs
|
||||
(list r-ggplot2 r-jmvcore r-r6 r-wrs2))
|
||||
`(("r-ggplot2" ,r-ggplot2)
|
||||
("r-jmvcore" ,r-jmvcore)
|
||||
("r-r6" ,r-r6)
|
||||
("r-wrs2" ,r-wrs2)))
|
||||
(home-page "https://github.com/jamovi/walrus")
|
||||
(synopsis "Robust Statistical Methods")
|
||||
(description
|
||||
@@ -1284,7 +1285,8 @@ noticed that a significant number of them have a @code{inherit} field:
|
||||
(sha256
|
||||
(base32
|
||||
"17fpahgh5dyckgz7rwqvzgnhx53cx9kr2xw0szprc6bnqy977fi8"))))
|
||||
(native-inputs (list `(,gtk+ "bin")))))
|
||||
(native-inputs
|
||||
`(("gtk-encode-symbolic-svg" ,gtk+ "bin")))))
|
||||
@end lisp
|
||||
|
||||
All unspecified fields are inherited from the parent package. This is very
|
||||
@@ -1351,7 +1353,6 @@ chapter is to demonstrate some advanced configuration concepts.
|
||||
reference.
|
||||
|
||||
@menu
|
||||
* Auto-Login to a Specific TTY:: Automatically Login a User to a Specific TTY
|
||||
* Customizing the Kernel:: Creating and using a custom Linux kernel on Guix System.
|
||||
* Guix System Image API:: Customizing images to target specific platforms.
|
||||
* Connecting to Wireguard VPN:: Connecting to a Wireguard VPN.
|
||||
@@ -1362,51 +1363,6 @@ reference.
|
||||
* Setting up NGINX with Lua:: Configuring NGINX web-server to load Lua modules.
|
||||
@end menu
|
||||
|
||||
@node Auto-Login to a Specific TTY
|
||||
@section Auto-Login to a Specific TTY
|
||||
|
||||
While the Guix manual explains auto-login one user to @emph{all} TTYs (
|
||||
@pxref{auto-login to TTY,,, guix, GNU Guix Reference Manual}), some
|
||||
might prefer a situation, in which one user is logged into one TTY with
|
||||
the other TTYs either configured to login different users or no one at
|
||||
all. Note that one can auto-login one user to any TTY, but it is
|
||||
usually advisable to avoid @code{tty1}, which, by default, is used to
|
||||
log warnings and errors.
|
||||
|
||||
Here is how one might set up auto login for one user to one tty:
|
||||
|
||||
@lisp
|
||||
(define (auto-login-to-tty config tty user)
|
||||
(if (string=? tty (mingetty-configuration-tty config))
|
||||
(mingetty-configuration
|
||||
(inherit config)
|
||||
(auto-login user))
|
||||
config))
|
||||
|
||||
(define %my-services
|
||||
(modify-services %base-services
|
||||
;; @dots{}
|
||||
(mingetty-service-type config =>
|
||||
(auto-login-to-tty
|
||||
config "tty3" "alice"))))
|
||||
|
||||
(operating-system
|
||||
;; @dots{}
|
||||
(services %my-services))
|
||||
@end lisp
|
||||
|
||||
One could also @code{compose} (@pxref{Higher-Order Functions,,, guile,
|
||||
The Guile Reference Manual}) @code{auto-login-to-tty} to login multiple
|
||||
users to multiple ttys.
|
||||
|
||||
Finally, here is a note of caution. Setting up auto login to a TTY,
|
||||
means that anyone can turn on your computer and run commands as your
|
||||
regular user.
|
||||
However, if you have an encrypted root partition, and thus already need
|
||||
to enter a passphrase when the system boots, auto-login might be a
|
||||
convenient option.
|
||||
|
||||
|
||||
@node Customizing the Kernel
|
||||
@section Customizing the Kernel
|
||||
|
||||
@@ -1433,34 +1389,37 @@ The @code{linux-libre} kernel package definition is actually a procedure which
|
||||
creates a package.
|
||||
|
||||
@lisp
|
||||
(define* (make-linux-libre* version gnu-revision source supported-systems
|
||||
#:key
|
||||
(extra-version #f)
|
||||
;; A function that takes an arch and a variant.
|
||||
;; See kernel-config for an example.
|
||||
(configuration-file #f)
|
||||
(defconfig "defconfig")
|
||||
(extra-options %default-extra-linux-options))
|
||||
(define* (make-linux-libre version hash supported-systems
|
||||
#:key
|
||||
;; A function that takes an arch and a variant.
|
||||
;; See kernel-config for an example.
|
||||
(extra-version #false)
|
||||
(configuration-file #false)
|
||||
(defconfig "defconfig")
|
||||
(extra-options %default-extra-linux-options)
|
||||
(patches (list %boot-logo-patch)))
|
||||
...)
|
||||
@end lisp
|
||||
|
||||
The current @code{linux-libre} package is for the 5.15.x series, and is
|
||||
The current @code{linux-libre} package is for the 5.1.x series, and is
|
||||
declared like this:
|
||||
|
||||
@lisp
|
||||
(define-public linux-libre-5.15
|
||||
(make-linux-libre* linux-libre-5.15-version
|
||||
linux-libre-5.15-gnu-revision
|
||||
linux-libre-5.15-source
|
||||
'("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "riscv64-linux")
|
||||
#:configuration-file kernel-config))
|
||||
(define-public linux-libre
|
||||
(make-linux-libre %linux-libre-version
|
||||
%linux-libre-hash
|
||||
'("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux")
|
||||
#:patches %linux-libre-5.1-patches
|
||||
#:configuration-file kernel-config))
|
||||
@end lisp
|
||||
|
||||
Any keys which are not assigned values inherit their default value from the
|
||||
@code{make-linux-libre} definition. When comparing the two snippets above,
|
||||
notice the code comment that refers to @code{#:configuration-file}. Because of
|
||||
this, it is not actually easy to include a custom kernel configuration from the
|
||||
definition, but don't worry, there are other ways to work with what we do have.
|
||||
you may notice that the code comment in the first doesn't actually refer to
|
||||
the @code{#:extra-version} keyword; it is actually for
|
||||
@code{#:configuration-file}. Because of this, it is not actually easy to
|
||||
include a custom kernel configuration from the definition, but don't worry,
|
||||
there are other ways to work with what we do have.
|
||||
|
||||
There are two ways to create a kernel with a custom kernel configuration. The
|
||||
first is to provide a standard @file{.config} file during the build process by
|
||||
@@ -1560,15 +1519,14 @@ custom kernel:
|
||||
(@@@@ (gnu packages linux) %default-extra-linux-options)))
|
||||
|
||||
(define-public linux-libre-macbook41
|
||||
;; XXX: Access the internal 'make-linux-libre*' procedure, which is
|
||||
;; XXX: Access the internal 'make-linux-libre' procedure, which is
|
||||
;; private and unexported, and is liable to change in the future.
|
||||
((@@@@ (gnu packages linux) make-linux-libre*)
|
||||
(@@@@ (gnu packages linux) linux-libre-version)
|
||||
(@@@@ (gnu packages linux) linux-libre-gnu-revision)
|
||||
(@@@@ (gnu packages linux) linux-libre-source)
|
||||
'("x86_64-linux")
|
||||
#:extra-version "macbook41"
|
||||
#:extra-options %macbook41-config-options))
|
||||
((@@@@ (gnu packages linux) make-linux-libre) (@@@@ (gnu packages linux) %linux-libre-version)
|
||||
(@@@@ (gnu packages linux) %linux-libre-hash)
|
||||
'("x86_64-linux")
|
||||
#:extra-version "macbook41"
|
||||
#:patches (@@@@ (gnu packages linux) %linux-libre-5.1-patches)
|
||||
#:extra-options %macbook41-config-options))
|
||||
@end lisp
|
||||
|
||||
In the above example @code{%file-systems} is a collection of flags enabling
|
||||
@@ -1713,7 +1671,7 @@ operating-system dedicated to the @b{Pine A64 LTS} board.
|
||||
(locale "en_US.utf8")
|
||||
(bootloader (bootloader-configuration
|
||||
(bootloader u-boot-pine64-lts-bootloader)
|
||||
(targets '("/dev/vda"))))
|
||||
(target "/dev/vda")))
|
||||
(initrd-modules '())
|
||||
(kernel linux-libre-arm64-generic)
|
||||
(file-systems (cons (file-system
|
||||
@@ -2045,12 +2003,10 @@ Copy into it the output of:
|
||||
cat ~/.ssh/<username>_rsa.pub
|
||||
@end example
|
||||
|
||||
Power the Linode down.
|
||||
|
||||
In the Linode's Storage tab, resize the Debian disk to be smaller.
|
||||
30 GB free space is recommended. Then click "Add a disk", and fill
|
||||
out the form with the following:
|
||||
Power the Linode down. In the Linode's Disks/Configurations tab, resize
|
||||
the Debian disk to be smaller. 30 GB is recommended.
|
||||
|
||||
In the Linode settings, "Add a disk", with the following:
|
||||
@itemize @bullet
|
||||
@item
|
||||
Label: "Guix"
|
||||
@@ -2062,9 +2018,9 @@ Filesystem: ext4
|
||||
Set it to the remaining size
|
||||
@end itemize
|
||||
|
||||
In the Configurations tab, press "Edit" on the default Debian profile.
|
||||
Under "Block Device Assignment" click "Add a Device". It should be
|
||||
@file{/dev/sdc} and you can select the "Guix" disk. Save Changes.
|
||||
On the "configuration" field that comes with the default image, press
|
||||
"..." and select "Edit", then on that menu add to @file{/dev/sdc} the "Guix"
|
||||
label.
|
||||
|
||||
Now "Add a Configuration", with the following:
|
||||
@itemize @bullet
|
||||
@@ -2090,8 +2046,8 @@ Root device: @file{/dev/sda}
|
||||
Turn off all the filesystem/boot helpers
|
||||
@end itemize
|
||||
|
||||
Now power it back up, booting with the Debian configuration. Once it's
|
||||
running, ssh to your server via @code{ssh
|
||||
Now power it back up, picking the Debian configuration. Once it's
|
||||
booted up, ssh in your server via @code{ssh
|
||||
root@@@var{<your-server-IP-here>}}. (You can find your server IP address in
|
||||
your Linode Summary section.) Now you can run the "install guix from
|
||||
@pxref{Binary Installation,,, guix, GNU Guix}" steps:
|
||||
@@ -2180,20 +2136,19 @@ Replace the following fields in the above configuration:
|
||||
@end lisp
|
||||
|
||||
The last line in the above example lets you log into the server as root
|
||||
and set the initial root password (see the note at the end of this
|
||||
recipe about root login). After you have done this, you may
|
||||
and set the initial root password. After you have done this, you may
|
||||
delete that line from your configuration and reconfigure to prevent root
|
||||
login.
|
||||
|
||||
Copy your ssh public key (eg: @file{~/.ssh/id_rsa.pub}) as
|
||||
@file{@var{<your-username-here>}_rsa.pub} and put
|
||||
Save your ssh public key (eg: @file{~/.ssh/id_rsa.pub}) as
|
||||
@file{@var{<your-username-here>}_rsa.pub} and your
|
||||
@file{guix-config.scm} in the same directory. In a new terminal run
|
||||
these commands.
|
||||
|
||||
@example
|
||||
sftp root@@<remote server ip address>
|
||||
put /path/to/files/<username>_rsa.pub .
|
||||
put /path/to/files/guix-config.scm .
|
||||
put /home/<username>/ssh/id_rsa.pub .
|
||||
put /path/to/linode/guix-config.scm .
|
||||
@end example
|
||||
|
||||
In your first terminal, mount the guix drive:
|
||||
@@ -2203,9 +2158,9 @@ mkdir /mnt/guix
|
||||
mount /dev/sdc /mnt/guix
|
||||
@end example
|
||||
|
||||
Due to the way we set up the bootloader section of the guix-config.scm,
|
||||
only the grub configuration file will be installed. So, we need to copy
|
||||
over some of the other GRUB stuff already installed on the Debian system:
|
||||
Due to the way we set things up above, we do not install GRUB
|
||||
completely. Instead we install only our grub configuration file. So we
|
||||
need to copy over some of the other GRUB stuff that is already there:
|
||||
|
||||
@example
|
||||
mkdir -p /mnt/guix/boot/grub
|
||||
@@ -2258,7 +2213,7 @@ still need to set your root and user password initially by clicking on
|
||||
the ``Launch Console'' option in your linode. Choose the ``Glish''
|
||||
instead of ``Weblish''. Now you should be able to ssh into the machine.
|
||||
|
||||
Hooray! At this point you can shut down the server, delete the
|
||||
Horray! At this point you can shut down the server, delete the
|
||||
Debian disk, and resize the Guix to the rest of the size.
|
||||
Congratulations!
|
||||
|
||||
@@ -2357,8 +2312,7 @@ follow:
|
||||
config => (guix-configuration
|
||||
(inherit config)
|
||||
;; ci.guix.gnu.org's Onion service
|
||||
(substitute-urls
|
||||
"@value{SUBSTITUTE-TOR-URL}")
|
||||
(substitute-urls "https://bp7o7ckwlewr4slm.onion")
|
||||
(http-proxy "http://localhost:9250")))))))
|
||||
@end lisp
|
||||
|
||||
@@ -2376,8 +2330,7 @@ want to get a substitute from the Tor tunnel run:
|
||||
|
||||
@example
|
||||
sudo herd set-http-proxy guix-daemon http://localhost:9250
|
||||
guix build \
|
||||
--substitute-urls=@value{SUBSTITUTE-TOR-URL} @dots{}
|
||||
guix build --substitute-urls=https://bp7o7ckwlewr4slm.onion …
|
||||
@end example
|
||||
|
||||
@node Setting up NGINX with Lua
|
||||
@@ -2533,9 +2486,8 @@ Let's dive in the set up!
|
||||
@node Basic setup with manifests
|
||||
@subsection Basic setup with manifests
|
||||
|
||||
A Guix profile can be set up @i{via} a @dfn{manifest}. A manifest is a
|
||||
snippet of Scheme code that specifies the set of packages you want to
|
||||
have in your profile; it looks like this:
|
||||
A Guix profile can be set up @emph{via} a so-called @emph{manifest specification} that looks like
|
||||
this:
|
||||
|
||||
@lisp
|
||||
(specifications->manifest
|
||||
@@ -2548,8 +2500,8 @@ have in your profile; it looks like this:
|
||||
"package-N"))
|
||||
@end lisp
|
||||
|
||||
@xref{Writing Manifests,,, guix, GNU Guix Reference Manual}, for
|
||||
more information about the syntax.
|
||||
@pxref{Invoking guix package,,, guix, GNU Guix Reference Manual}, for
|
||||
the syntax details.
|
||||
|
||||
We can create a manifest specification per profile and install them this way:
|
||||
|
||||
|
||||
+1068
-7278
File diff suppressed because it is too large
Load Diff
@@ -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")))))))
|
||||
|
||||
+27
-52
@@ -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=2022-06-16.15; # 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/
|
||||
@@ -412,28 +397,18 @@ guile-gtk node ${GS}/guile-gtk/docs/guile-gtk/
|
||||
guile-rpc mono ${GS}/guile-rpc/manual/guile-rpc.html
|
||||
guile-rpc node ${GS}/guile-rpc/manual/html_node/
|
||||
|
||||
GUIX_ROOT = https://guix.gnu.org
|
||||
GUIX = ${GUIX_ROOT}/guix/manual
|
||||
guix.de mono ${GUIX}/de/guix.de.html
|
||||
guix.de node ${GUIX}/de/html_node/
|
||||
guix.es mono ${GUIX}/es/guix.es.html
|
||||
guix.es node ${GUIX}/es/html_node/
|
||||
guix.fr mono ${GUIX}/fr/guix.fr.html
|
||||
guix.fr node ${GUIX}/fr/html_node/
|
||||
guix.ru mono ${GUIX}/ru/guix.ru.html
|
||||
guix.ru node ${GUIX}/ru/html_node/
|
||||
guix.zh_CN mono ${GUIX}/zh-cn/guix.zh_CN.html
|
||||
guix.zh_CN node ${GUIX}/zh-cn/html_node/
|
||||
guix mono ${GUIX}/en/guix.html
|
||||
guix node ${GUIX}/en/html_node/
|
||||
|
||||
GUIX_COOKBOOK = ${GUIX_ROOT}/cookbook
|
||||
guix-cookbook.de mono ${GUIX_COOKBOOK}/de/guix-cookbook.html
|
||||
guix-cookbook.de node ${GUIX_COOKBOOK}/de/html_node/
|
||||
guix-cookbook.fr mono ${GUIX_COOKBOOK}/fr/guix-cookbook.html
|
||||
guix-cookbook.fr node ${GUIX_COOKBOOK}/fr/html_node/
|
||||
guix-cookbook mono ${GUIX_COOKBOOK}/en/guix-cookbook.html
|
||||
guix-cookbook node ${GUIX_COOKBOOK}/en/html_node/
|
||||
guix.de mono ${GS}/guix/manual/de/guix.de.html
|
||||
guix.de node ${GS}/guix/manual/de/html_node/
|
||||
guix.es mono ${GS}/guix/manual/es/guix.es.html
|
||||
guix.es node ${GS}/guix/manual/es/html_node/
|
||||
guix.fr mono ${GS}/guix/manual/fr/guix.fr.html
|
||||
guix.fr node ${GS}/guix/manual/fr/html_node/
|
||||
guix.ru mono ${GS}/guix/manual/ru/guix.ru.html
|
||||
guix.ru node ${GS}/guix/manual/ru/html_node/
|
||||
guix.zh_CN mono ${GS}/guix/manual/zh-cn/guix.zh_CN.html
|
||||
guix.zh_CN node ${GS}/guix/manual/zh-cn/html_node/
|
||||
guix mono ${GS}/guix/manual/en/guix.html
|
||||
guix node ${GS}/guix/manual/en/html_node/
|
||||
|
||||
gv mono ${GS}/gv/manual/gv.html
|
||||
gv node ${GS}/gv/manual/html_node/
|
||||
@@ -528,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
|
||||
|
||||
@@ -600,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
|
||||
@@ -657,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/
|
||||
@@ -665,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/
|
||||
|
||||
+34
-15
@@ -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
|
||||
|
||||
+94
-208
@@ -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)
|
||||
|
||||
+100
-148
@@ -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
|
||||
|
||||
+102
-309
@@ -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,112 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; This file returns a manifest that builds a directory containing Disarchive
|
||||
;;; metadata for all the tarballs packages refer to.
|
||||
|
||||
(use-modules (srfi srfi-1) (ice-9 match)
|
||||
(guix packages) (guix gexp) (guix profiles)
|
||||
(guix base16)
|
||||
(gnu packages))
|
||||
|
||||
(include "source-manifest.scm")
|
||||
|
||||
(define (tarball-origin? origin)
|
||||
(match (origin-actual-file-name origin)
|
||||
(#f #f)
|
||||
((? string? file)
|
||||
;; As of version 0.2.1, Disarchive can only deal with raw tarballs and
|
||||
;; gzip-compressed tarballs.
|
||||
(and (origin-hash origin)
|
||||
(or (string-suffix? ".tar.gz" file)
|
||||
(string-suffix? ".tgz" file)
|
||||
(string-suffix? ".tar" file))))))
|
||||
|
||||
(define (origin->disarchive origin)
|
||||
"Return a directory containing Disarchive metadata for ORIGIN, a tarball, or
|
||||
an empty directory if ORIGIN could not be disassembled."
|
||||
(define file-name
|
||||
(let ((hash (origin-hash origin)))
|
||||
(string-append (symbol->string (content-hash-algorithm hash))
|
||||
"/"
|
||||
(bytevector->base16-string
|
||||
(content-hash-value hash)))))
|
||||
|
||||
(define disarchive
|
||||
(specification->package "disarchive"))
|
||||
|
||||
(define build
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(srfi srfi-34))
|
||||
|
||||
(define tarball
|
||||
#+(upstream-origin origin))
|
||||
|
||||
(define file-name
|
||||
(string-append #$output "/" #$file-name))
|
||||
|
||||
(define profile
|
||||
#+(profile (content (packages->manifest (list disarchive)))))
|
||||
|
||||
(mkdir-p (dirname file-name))
|
||||
(setenv "PATH" (string-append profile "/bin"))
|
||||
(setenv "GUILE_LOAD_PATH"
|
||||
(string-append profile "/share/guile/site/"
|
||||
(effective-version)))
|
||||
(setenv "GUILE_LOAD_COMPILED_PATH"
|
||||
(string-append profile "/lib/guile/" (effective-version)
|
||||
"/site-ccache"))
|
||||
|
||||
(guard (c ((invoke-error? c)
|
||||
;; Sometimes Disarchive fails with "could not find Gzip
|
||||
;; compressor". When that happens, produce an empty
|
||||
;; directory instead of failing.
|
||||
(report-invoke-error c)
|
||||
(delete-file file-name)))
|
||||
(with-output-to-file file-name
|
||||
(lambda ()
|
||||
;; Disarchive records the tarball name in its output. Thus,
|
||||
;; strip the hash from TARBALL.
|
||||
(let ((short-name (strip-store-file-name tarball)))
|
||||
(symlink tarball short-name)
|
||||
(invoke "disarchive" "disassemble" short-name))))))))
|
||||
|
||||
(computed-file (match (origin-actual-file-name origin)
|
||||
((? string? str) (string-append str ".dis"))
|
||||
(#f "anonymous-tarball.dis"))
|
||||
build))
|
||||
|
||||
(define (disarchive-collection origins)
|
||||
"Return a directory containing all the Disarchive metadata for ORIGINS."
|
||||
(directory-union "disarchive-collection"
|
||||
(filter-map (lambda (origin)
|
||||
(and (tarball-origin? origin)
|
||||
(origin->disarchive origin)))
|
||||
origins)
|
||||
#:copy? #t))
|
||||
|
||||
|
||||
;; The manifest containing Disarchive data.
|
||||
(let ((origins (all-origins)))
|
||||
(manifest
|
||||
(list (manifest-entry
|
||||
(name "disarchive-collection")
|
||||
(version (number->string (length origins)))
|
||||
(item (disarchive-collection origins))))))
|
||||
@@ -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,8 +6,7 @@
|
||||
Description=Build daemon for GNU Guix
|
||||
|
||||
[Service]
|
||||
ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon \
|
||||
--build-users-group=guixbuild --discover=no
|
||||
ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon --build-users-group=guixbuild
|
||||
Environment='GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale' LC_ALL=en_US.utf8
|
||||
RemainAfterExit=yes
|
||||
StandardOutput=syslog
|
||||
|
||||
@@ -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
|
||||
+18
-36
@@ -96,7 +96,7 @@ _debug()
|
||||
# $1: The prompt question.
|
||||
prompt_yes_no() {
|
||||
while true; do
|
||||
read -rp "$1 " yn
|
||||
read -rp "$1" yn
|
||||
case $yn in
|
||||
[Yy]*) return 0;;
|
||||
[Nn]*) return 1;;
|
||||
@@ -139,12 +139,12 @@ chk_gpg_keyring()
|
||||
required to verify the Guix binary signature: $gpg_key_id.
|
||||
Would you like me to fetch it for you? (yes/no)"; then
|
||||
wget "https://sv.gnu.org/people/viewgpg.php?user_id=$user_id" \
|
||||
--no-verbose -O- | gpg --import -
|
||||
-qO - | gpg --import -
|
||||
else
|
||||
_err "${ERR}Missing OpenPGP public key ($gpg_key_id).
|
||||
Fetch it with this command:
|
||||
|
||||
wget \"https://sv.gnu.org/people/viewgpg.php?user_id=$user_id\" -O - | \
|
||||
wget \"https://sv.gnu.org/people/viewgpg.php?user_id=$user_id\" -qO - | \
|
||||
sudo -i gpg --import -"
|
||||
exit_flag=yes
|
||||
fi
|
||||
@@ -249,16 +249,6 @@ chk_sys_nscd()
|
||||
fi
|
||||
}
|
||||
|
||||
# Configure substitute discovery according to user's preferences.
|
||||
# $1 is the installed service file to edit.
|
||||
configure_substitute_discovery() {
|
||||
if grep -q -- '--discover=no' "$1" && \
|
||||
prompt_yes_no "Would you like the Guix daemon to automatically \
|
||||
discover substitute servers on the local network? (yes/no)"; then
|
||||
sed -i 's/--discover=no/--discover=yes/' "$1"
|
||||
fi
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
#+MAIN
|
||||
|
||||
@@ -272,7 +262,7 @@ guix_get_bin_list()
|
||||
_debug "--- [ ${FUNCNAME[0]} ] ---"
|
||||
|
||||
# Filter only version and architecture
|
||||
bin_ver_ls=("$(wget "$gnu_url" --no-verbose -O- \
|
||||
bin_ver_ls=("$(wget -qO- "$gnu_url" \
|
||||
| sed -n -e 's/.*guix-binary-\([0-9.]*[a-z0-9]*\)\..*.tar.xz.*/\1/p' \
|
||||
| sort -Vu)")
|
||||
|
||||
@@ -305,7 +295,7 @@ guix_get_bin()
|
||||
_msg "${INF}Downloading Guix release archive"
|
||||
|
||||
wget --help | grep -q '\--show-progress' \
|
||||
&& wget_args=("--no-verbose" "--show-progress")
|
||||
&& wget_args=("-q" "--show-progress")
|
||||
|
||||
if wget "${wget_args[@]}" -P "$dl_path" \
|
||||
"${url}/${bin_ver}.tar.xz" "${url}/${bin_ver}.tar.xz.sig"; then
|
||||
@@ -345,11 +335,11 @@ sys_create_store()
|
||||
mv "${tmp_path}/gnu" /
|
||||
|
||||
_msg "${INF}Linking the root user's profile"
|
||||
mkdir -p ~root/.config/guix
|
||||
mkdir -p "~root/.config/guix"
|
||||
ln -sf /var/guix/profiles/per-user/root/current-guix \
|
||||
~root/.config/guix/current
|
||||
"~root/.config/guix/current"
|
||||
|
||||
GUIX_PROFILE=~root/.config/guix/current
|
||||
GUIX_PROFILE="~root/.config/guix/current"
|
||||
# shellcheck disable=SC1090
|
||||
source "${GUIX_PROFILE}/etc/profile"
|
||||
_msg "${PAS}activated root profile at ${GUIX_PROFILE}"
|
||||
@@ -369,7 +359,7 @@ sys_create_build_user()
|
||||
|
||||
if getent group kvm > /dev/null; then
|
||||
_msg "${INF}group kvm exists and build users will be added to it"
|
||||
local KVMGROUP=,kvm
|
||||
local KVMGROUP=,kvm
|
||||
fi
|
||||
|
||||
for i in $(seq -w 1 10); do
|
||||
@@ -405,9 +395,8 @@ sys_enable_guix_daemon()
|
||||
case "$INIT_SYS" in
|
||||
upstart)
|
||||
{ initctl reload-configuration;
|
||||
cp ~root/.config/guix/current/lib/upstart/system/guix-daemon.conf \
|
||||
cp "~root/.config/guix/current/lib/upstart/system/guix-daemon.conf" \
|
||||
/etc/init/ &&
|
||||
configure_substitute_discovery /etc/init/guix-daemon.conf &&
|
||||
start guix-daemon; } &&
|
||||
_msg "${PAS}enabled Guix daemon via upstart"
|
||||
;;
|
||||
@@ -415,15 +404,15 @@ sys_enable_guix_daemon()
|
||||
{ # systemd .mount units must be named after the target directory.
|
||||
# Here we assume a hard-coded name of /gnu/store.
|
||||
# XXX Work around <https://issues.guix.gnu.org/41356> until next release.
|
||||
if [ -f ~root/.config/guix/current/lib/systemd/system/gnu-store.mount ]; then
|
||||
cp ~root/.config/guix/current/lib/systemd/system/gnu-store.mount \
|
||||
if [ -f "~root/.config/guix/current/lib/systemd/system/gnu-store.mount" ]; then
|
||||
cp "~root/.config/guix/current/lib/systemd/system/gnu-store.mount" \
|
||||
/etc/systemd/system/;
|
||||
chmod 664 /etc/systemd/system/gnu-store.mount;
|
||||
systemctl daemon-reload &&
|
||||
systemctl enable gnu-store.mount;
|
||||
fi
|
||||
|
||||
cp ~root/.config/guix/current/lib/systemd/system/guix-daemon.service \
|
||||
cp "~root/.config/guix/current/lib/systemd/system/guix-daemon.service" \
|
||||
/etc/systemd/system/;
|
||||
chmod 664 /etc/systemd/system/guix-daemon.service;
|
||||
|
||||
@@ -437,9 +426,6 @@ sys_enable_guix_daemon()
|
||||
-e 's/^Environment=\(.*\)$/Environment=\1 LC_ALL=en_US.UTF-8';
|
||||
fi;
|
||||
|
||||
configure_substitute_discovery \
|
||||
/etc/systemd/system/guix-daemon.service
|
||||
|
||||
systemctl daemon-reload &&
|
||||
systemctl enable guix-daemon &&
|
||||
systemctl start guix-daemon; } &&
|
||||
@@ -447,12 +433,10 @@ sys_enable_guix_daemon()
|
||||
;;
|
||||
sysv-init)
|
||||
{ mkdir -p /etc/init.d;
|
||||
cp ~root/.config/guix/current/etc/init.d/guix-daemon \
|
||||
cp "~root/.config/guix/current/etc/init.d/guix-daemon" \
|
||||
/etc/init.d/guix-daemon;
|
||||
chmod 775 /etc/init.d/guix-daemon;
|
||||
|
||||
configure_substitute_discovery /etc/init.d/guix-daemon
|
||||
|
||||
update-rc.d guix-daemon defaults &&
|
||||
update-rc.d guix-daemon enable &&
|
||||
service guix-daemon start; } &&
|
||||
@@ -460,12 +444,10 @@ sys_enable_guix_daemon()
|
||||
;;
|
||||
openrc)
|
||||
{ mkdir -p /etc/init.d;
|
||||
cp ~root/.config/guix/current/etc/openrc/guix-daemon \
|
||||
cp "~root/.config/guix/current/etc/openrc/guix-daemon" \
|
||||
/etc/init.d/guix-daemon;
|
||||
chmod 775 /etc/init.d/guix-daemon;
|
||||
|
||||
configure_substitute_discovery /etc/init.d/guix-daemon
|
||||
|
||||
rc-update add guix-daemon default &&
|
||||
rc-service guix-daemon start; } &&
|
||||
_msg "${PAS}enabled Guix daemon via OpenRC"
|
||||
@@ -490,9 +472,9 @@ sys_enable_guix_daemon()
|
||||
sys_authorize_build_farms()
|
||||
{ # authorize the public key of the build farm
|
||||
if prompt_yes_no "Permit downloading pre-built package binaries from the \
|
||||
project's build farm? (yes/no)"; then
|
||||
project's build farm? (yes/no) "; then
|
||||
guix archive --authorize \
|
||||
< ~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub \
|
||||
< "~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub" \
|
||||
&& _msg "${PAS}Authorized public key for ci.guix.gnu.org"
|
||||
else
|
||||
_msg "${INF}Skipped authorizing build farm public keys"
|
||||
@@ -517,7 +499,7 @@ export INFOPATH="$_GUIX_PROFILE/share/info:$INFOPATH"
|
||||
GUIX_PROFILE="$HOME/.guix-profile"
|
||||
[ -L $GUIX_PROFILE ] || return
|
||||
GUIX_LOCPATH="$GUIX_PROFILE/lib/locale"
|
||||
export GUIX_LOCPATH
|
||||
export GUIX_PROFILE GUIX_LOCPATH
|
||||
|
||||
[ -f "$GUIX_PROFILE/etc/profile" ] && . "$GUIX_PROFILE/etc/profile"
|
||||
|
||||
|
||||
Executable
+117
@@ -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)
|
||||
|
||||
+14
-929
@@ -1,22 +1,19 @@
|
||||
;; GNU Guix news, for use by 'guix pull'.
|
||||
;;
|
||||
;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
|
||||
;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
|
||||
;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||
;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
|
||||
;; Copyright © 2019, 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
|
||||
;; Copyright © 2019, 2020, 2021 Julien Lepiller <julien@lepiller.eu>
|
||||
;; Copyright © 2019–2022 Florian Pelz <pelzflorian@pelzflorian.de>
|
||||
;; Copyright © 2019, 2020, 2021 Florian Pelz <pelzflorian@pelzflorian.de>
|
||||
;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
|
||||
;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
;; Copyright © 2021 Leo Famulari <leo@famulari.name>
|
||||
;; Copyright © 2021 Zhu Zihao <all_but_last@163.com>
|
||||
;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
|
||||
;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
|
||||
;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;; Copyright © 2021 Jonathan Brielmaier <jonathan.brielmaier@web.de>
|
||||
;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
|
||||
;;
|
||||
;; Copying and distribution of this file, with or without modification, are
|
||||
;; permitted in any medium without royalty provided the copyright notice and
|
||||
@@ -25,918 +22,6 @@
|
||||
(channel-news
|
||||
(version 0)
|
||||
|
||||
(entry (commit "2ec7ab2610eb67e26dab52b671eb29e46f64ea0f")
|
||||
(title
|
||||
(en "Linux-libre kernel updated to 5.18")
|
||||
(de "Linux-libre-Kernel wird auf 5.18 aktualisiert"))
|
||||
(body
|
||||
(en "The default version of the linux-libre kernel has been
|
||||
updated to the 5.18 release series.")
|
||||
(de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
|
||||
jetzt auf der 5.18-Versionsreihe.")))
|
||||
|
||||
(entry (commit "bdf422176739b473add66eb8cac9fdd8c654f794")
|
||||
(title
|
||||
(en "@option{-L} option of @command{guix refresh} repurposed")
|
||||
(de "Option @option{-L} von @command{guix refresh} wechselt Bedeutung")
|
||||
(fr "Option @option{-L} de @command{guix refresh} réutilisée"))
|
||||
(body
|
||||
(en "The @option{-L} option of @command{guix refresh} has been
|
||||
repurposed: it used to be synonymous with @option{--list-updaters}; it is now
|
||||
synonymous with @option{--load-path} as is the case with most other commands.
|
||||
|
||||
Run @command{info \"(guix) Invoking guix refresh\"} for more info.")
|
||||
(de "Die Befehlszeilenoption @option{-L} von @command{guix refresh} hat
|
||||
einen anderen Zweck bekommen: Früher war sie gleichbedeutend mit
|
||||
@option{--list-updaters}; jetzt ist sie gleichbedeutend mit
|
||||
@option{--load-path}, wie bereits beim Großteil der anderen Befehle.
|
||||
|
||||
Führen Sie @command{info \"(guix.de) Aufruf von guix refresh\"} aus, wenn Sie
|
||||
mehr wissen möchten.")
|
||||
(fr "L'option @option{-L} de @command{guix refresh} a changé de
|
||||
signification : elle était auparavant synonyme de @option{--list-updaters} ;
|
||||
elle est maintenant synonyme de @option{--load-path} comme c'est le cas pour
|
||||
la plupart des autres commandes.
|
||||
|
||||
Lancer @command{info \"(guix.fr) Invoquer guix refresh\"} pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "35c1edb20ad07250728d3bdcd0296bd0cedaf6bb")
|
||||
(title
|
||||
(en "New @command{edit} sub-commands for services")
|
||||
(de "Neue @command{edit}-Unterbefehle für Dienste")
|
||||
(fr "Nouvelles commandes @command{edit} pour les services")
|
||||
(nl "Nieuwe deelopdracht @command{edit} voor diensten"))
|
||||
(body
|
||||
(en "The new @command{guix system edit} and @command{guix home edit} commands
|
||||
allow you to view or edit service types defined for Guix System or Guix Home.
|
||||
For example, here is how you would open the definition of the OpenSSH system
|
||||
service:
|
||||
|
||||
@example
|
||||
guix system edit openssh
|
||||
@end example
|
||||
|
||||
Run @command{info \"(guix) Invoking guix system\"} or @command{info \"(guix)
|
||||
Invoking guix home\"} for more info.")
|
||||
(de "Mit den neuen Befehlen @command{guix system edit} und
|
||||
@command{guix home edit} können Sie Diensttypen für Guix System oder Guix Home
|
||||
betrachten und bearbeiten. Zum Beispiel würden Sie die Definition des
|
||||
OpenSSH-Systemdienstes wie folgt öffnen:
|
||||
|
||||
@example
|
||||
guix system edit openssh
|
||||
@end example
|
||||
|
||||
Führen Sie @command{info \"(guix.de) Aufruf von guix system\"} oder
|
||||
@command{info \"(guix.de) Aufruf von guix home\"} aus, um mehr zu erfahren.")
|
||||
(fr "Les nouvelles commandes @command{guix system edit} et
|
||||
@command{guix home edit} permettent de visualiser ou d'éditer les types de
|
||||
services définis pour Guix System ou Guix Home. Par exemple, voici comment
|
||||
ouvrir la définition du service système OpenSSH :
|
||||
|
||||
@example
|
||||
guix system edit openssh
|
||||
@end example
|
||||
|
||||
Lancer @command{info \"(guix.fr) Invoquer guix system\"} ou @command{info
|
||||
\"(guix.fr) Invoquer guix home\"} pour plus d'informations.")
|
||||
;; TODO: pas verwijzingen naar de handleiding aan wanneer ze vertaald is
|
||||
(nl "Met de nieuwe bewerkingen @command{guix system edit} en
|
||||
@command{guix home edit} kan je dienstsoorten van Guix System en Guix
|
||||
Home bekijken en bewerken. Je kan bijvoorbeeld de definitie van de
|
||||
systeemdienst OpenSSH als volgt openen:
|
||||
|
||||
@example
|
||||
guix system edit openssh
|
||||
@end example
|
||||
|
||||
Voer @command{info \"(guix) Invoking guix system\"} of @command{info
|
||||
\"(guix)Invoking guix home\"} uit voor meer informatie.")))
|
||||
|
||||
(entry (commit "903c82583e1cec4c9ff09d5895c5cc646c37b661")
|
||||
(title
|
||||
(en "New @command{guix import elm} command")
|
||||
(de "Neuer Befehl @command{guix import elm}")
|
||||
(fr "Nouvelle commande @command{guix import elm}"))
|
||||
(body
|
||||
(en "The new @command{guix import elm} command allows packagers to
|
||||
generate a package definition or given the name of a package for Elm, a
|
||||
functional programming language for the Web:
|
||||
|
||||
@example
|
||||
guix import elm elm/bytes
|
||||
@end example
|
||||
|
||||
Run @command{info \"(guix) Invoking guix import\"} for more info.
|
||||
|
||||
This comes with a new build system for Elm packages---run @command{info
|
||||
\"(guix) Build Systems\"} for details.")
|
||||
(de "Mit dem neuen Befehl @command{guix import elm} können Paketautoren
|
||||
eine Paketdefinition anhand des Namens eines Pakets für Elm, einer funktionalen
|
||||
Programmiersprache für das Web, erzeugen:
|
||||
|
||||
@example
|
||||
guix import elm elm/bytes
|
||||
@end example
|
||||
|
||||
Führen Sie @command{info \"(guix.de) Aufruf von guix import\"} aus, um mehr
|
||||
Informationen zu bekommen.
|
||||
|
||||
Dazu kommt ein neues Erstellungssystem für Elm-Pakete. Führen Sie
|
||||
@command{info \"(guix.de) Erstellungssysteme\"} aus, um mehr zu erfahren.")
|
||||
(fr "La nouvelle commande @command{guix import elm} permet de générer
|
||||
une définition de paquet reposant sur Elm, un langage de programmation
|
||||
fonctionnelle pour le Web:
|
||||
|
||||
@example
|
||||
guix import elm elm/bytes
|
||||
@end example
|
||||
|
||||
Lancer @command{info \"(guix.fr) Invoquer guix import\"} pour plus
|
||||
d'informations.
|
||||
|
||||
Cela vient avec un nouveau système de construction pour paquets Elm---lancer
|
||||
@command{info \"(guix.fr) Systèmes de construction\"} pour plus de détails.")))
|
||||
|
||||
(entry (commit "b6b2de2a0d52530bc1ee128c61580bed662ee15c")
|
||||
(title (en "Linux-libre kernel updated to 5.17")
|
||||
(de "Linux-libre-Kernel wird auf 5.17 aktualisiert"))
|
||||
(body
|
||||
(en "The default version of the linux-libre kernel has been
|
||||
updated to the 5.17 release series.")
|
||||
(de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
|
||||
jetzt auf der 5.17-Versionsreihe.")))
|
||||
|
||||
(entry (commit "c42b7baf13c7633b4512e94da7445299c57b247d")
|
||||
(title
|
||||
(en "New @option{--export-manifest} option for @command{guix shell}")
|
||||
(de "Neue Option @option{--export-manifest} für @command{guix shell}")
|
||||
(fr "Nouvelle option @option{--export-manifest} de @command{guix shell}"))
|
||||
(body
|
||||
(en "If you use @command{guix shell}, you might wonder how to
|
||||
``translate'' a command line into a manifest file that you can keep under
|
||||
version control, share with others, and pass to @command{guix shell -m} and in
|
||||
fact to most @command{guix} commands. This is what the new
|
||||
@option{--export-manifest} option does.
|
||||
|
||||
For example, the command below prints a manifest for the given packages:
|
||||
|
||||
@lisp
|
||||
guix shell --export-manifest \\
|
||||
-D guile git emacs emacs-geiser emacs-geiser-guile
|
||||
@end lisp
|
||||
|
||||
Run @code{info \"(guix) Invoking guix shell\"} for more information.")
|
||||
(de "Wenn Sie @command{guix shell} benutzen, haben Sie sich vielleicht
|
||||
einmal gefragt, wie Sie eine Befehlszeile in eine Manifest-Datei „übersetzen“
|
||||
können, die Sie unter Versionskontrolle stellen können, mit anderen teilen
|
||||
können und an @command{guix shell -m} oder tatsächlich die meisten anderen
|
||||
@command{guix}-Befehle übergeben können. Die Antwort ist die neue
|
||||
Befehlszeilenoption @option{--export-manifest}.
|
||||
|
||||
Zum Beispiel gibt der folgende Befehl ein Manifest mit den genannten Paketen
|
||||
aus:
|
||||
|
||||
@lisp
|
||||
guix shell --export-manifest \\
|
||||
-D guile git emacs emacs-geiser emacs-geiser-guile
|
||||
@end lisp
|
||||
|
||||
Führen Sie @command{info \"(guix.de) Aufruf von guix shell\"} aus, um mehr
|
||||
zu erfahren.")
|
||||
(fr "Si tu utilises @command{guix shell}, tu t'es peut-être déjà
|
||||
demandé comment « traduire » une ligne de commande en un fichier manifeste que
|
||||
tu puisse garder en gestion de version, partager et passer à @command{guix
|
||||
shell -m} et autres commandes @command{guix}. C'est ce que la nouvelle option
|
||||
@option{--export-manifest} fait.
|
||||
|
||||
Par exemple, la commande ci-dessous affiche un manifeste pour les paquets
|
||||
donnés :
|
||||
|
||||
@lisp
|
||||
guix shell --export-manifest \\
|
||||
-D guile git emacs emacs-geiser emacs-geiser-guile
|
||||
@end lisp
|
||||
|
||||
Lancer @code{info \"(guix.fr) Invoquer guix shell\"} pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "094a2cfbe45c104d0da30ff9d975d052ca0c118c")
|
||||
(title
|
||||
(en "New @command{guix home container} command")
|
||||
(de "Neuer Befehl @command{guix home container}")
|
||||
(fr "Nouvelle commande @command{guix home container}"))
|
||||
(body
|
||||
(en "The new @command{guix home} tool, which lets you to manage
|
||||
entire \"home environments\" in a declarative fashion, has gained a
|
||||
@command{container} sub-command. The new @command{guix home container}
|
||||
command allows you to test your configuration in an isolated @dfn{container},
|
||||
without touching your home directory:
|
||||
|
||||
@example
|
||||
guix home container config.scm
|
||||
@end example
|
||||
|
||||
This provides a simple and safe way to test your configuration before
|
||||
deploying it with @command{guix home reconfigure}. Run @code{info \"(guix)
|
||||
Invoking guix home\"} for more information.")
|
||||
(de "Das neue Werkzeug @command{guix home}, womit Sie vollständige
|
||||
„Persönliche Umgebungen“ deklarativ verwalten können, hat einen neuen
|
||||
Unterbefehl @command{container} hinzubekommen. Mit dem neuen Befehl
|
||||
@command{guix home container} können Sie Ihre Konfiguration in einem isolierten
|
||||
@dfn{Container} ausprobieren, ohne Ihr Persönliches Verzeichnis anzutasten.
|
||||
|
||||
@example
|
||||
guix home container config.scm
|
||||
@end example
|
||||
|
||||
So ist es ein Leichtes, Ihre Konfiguration in einer sicheren Umgebung zu testen,
|
||||
bevor Sie mit @command{guix home reconfigure} auf sie umsteigen. Führen Sie
|
||||
@code{info \"(guix.de) Aufruf von guix home\"} aus, um mehr zu erfahren.")
|
||||
(fr "La nouvelle commande @command{guix home}, qui sert à gérer son
|
||||
« environnement d'accueil » de manière déclarative, dispose maintenant d'une
|
||||
sous-commande @command{container}. La nouvelle commande @command{guix home
|
||||
container} permet de tester sa configuration dans un @dfn{conteneur} isolé,
|
||||
sans toucher à son répertoire d'accueil :
|
||||
|
||||
@example
|
||||
guix home container config.scm
|
||||
@end example
|
||||
|
||||
C'est un moyen simple et sûr de tester sa configuration avant de la déployer
|
||||
avec @command{guix home reconfigure}. Lancer @code{info \"(guix.fr) Invoquer
|
||||
guix home\"} pour plus d'informations.")))
|
||||
|
||||
(entry (commit "f1d18adbed39a3bacae93be29346fd4c86b480ef")
|
||||
(title
|
||||
(en "More compact @samp{guix pull --news}")
|
||||
(de "@samp{guix pull --news} wird knapper")
|
||||
(nl "Meer beknopte @samp{guix pull --news}"))
|
||||
(body
|
||||
(en "The output of @samp{guix pull --news} has been shortened to
|
||||
display only fresh news items such as this one. It no longer includes the
|
||||
partial selection of new and updated packages, which was often long enough to
|
||||
be distracting whilst being too short to be useful.
|
||||
|
||||
The complete list of new and updated packages can now be obtained separately
|
||||
using @samp{guix pull --news --details}.")
|
||||
(de "Die Ausgabe von @samp{guix pull --news} wurde gekürzt
|
||||
und informiert nur mehr über ungezeigte Neuigkeiten wie diese. Es
|
||||
fehlt der unvollständige Bericht über neue und aktualisierte Pakete,
|
||||
der oft so lang war, dass er gestört hat, doch zu kurz war, um
|
||||
nützlich zu sein.
|
||||
|
||||
Die vollständige Liste neuer und aktualisierter Pakete bekommen Sie
|
||||
jetzt mit @samp{guix pull --news --details}.")
|
||||
(nl "De uitvoer van @samp{guix pull --news} is vanaf nu beperkt tot
|
||||
verse nieuwsberichten zoals dit, zonder de onvolledige bloemlezing van nieuwe
|
||||
en bijgewerkte pakketten. Die was vaak lang genoeg om de lezer af te leiden
|
||||
maar te kort om nuttig te zijn.
|
||||
|
||||
De volledige list van nieuwe en bijgewerkte pakketten is nu afzonderlijk
|
||||
beschikbaar met @samp{guix pull --news --details}.")))
|
||||
|
||||
(entry (commit "96d7535b030c65b2d8cb0bea52c4bd96cbdefaf0")
|
||||
(title
|
||||
(en "ci.guix.gnu.org to stop offering Gzip substitutes")
|
||||
(de "ci.guix.gnu.org wird keine Substitute mit Gzip mehr anbieten"))
|
||||
(body
|
||||
(en "This is a notice to let you know that starting next
|
||||
month (2022/03/01), Gzip-compressed substitutes will no longer be available,
|
||||
which means that Guix daemons from a revision older than commit
|
||||
@samp{3092f1b835d79655eecb2f8a79dda20ad9ba6bd6} (2019/06/02) will loose the
|
||||
ability to download binary substitutes. Starting next month, only lzip and
|
||||
zstd substitutes will be offered. Dropping Gzip substitutes will free about
|
||||
6.5 TiB of storage space from the build farm.")
|
||||
(de "Hiermit weisen wir Sie darauf hin, dass ab nächstem
|
||||
Monat (2022/03/01) keine Gzip-komprimierten Substitute mehr zur Verfügung
|
||||
stehen. Dadurch können Guix-Daemons, deren Version älter ist als Commit
|
||||
@samp{3092f1b835d79655eecb2f8a79dda20ad9ba6bd6} (2019/06/02), keine binären
|
||||
Substitute mehr beziehen. Ab kommendem Monat werden nur Substitute mit lzip
|
||||
und zstd angeboten. Indem wir auf Gzip-Substitute verzichten, sparen wir 6.5
|
||||
TiB Speicherplatz auf der Erstellungsfarm.")))
|
||||
|
||||
(entry (commit "5c13484646069064c834bbd3cd02c3bc80d94cb6")
|
||||
(title
|
||||
(en "New @option{--execute} option to @command{guix deploy}")
|
||||
(de "Neue Option @option{--execute} für @command{guix deploy}")
|
||||
(fr "Nouvelle option @option{--execute} pour @command{guix deploy}"))
|
||||
(body
|
||||
(en "The @command{guix deploy} command has a new @option{--execute}
|
||||
or @option{-x} option, which allows you to execute a command on all the
|
||||
machines that your configuration file specifies, as in this example:
|
||||
|
||||
@example
|
||||
guix deploy deploy.scm -x -- herd restart guix-daemon
|
||||
@end example
|
||||
|
||||
This is no substitute for full-featured tools such as pdsh but it is a useful
|
||||
helper.")
|
||||
(de "Der Befehl @command{guix deploy} verfügt über eine neue Option
|
||||
@option{--execute} oder @option{-x}, mit der Sie einen Befehl auf allen in der
|
||||
Konfigurationsdatei angegebenen Maschinen ausführen können. Zum Beispiel:
|
||||
|
||||
@example
|
||||
guix deploy deploy.scm -x -- herd restart guix-daemon
|
||||
@end example
|
||||
|
||||
Dies ist kein Ersatz für vollumfängliche Werkzeuge wie pdsh, aber es kann doch
|
||||
von Nutzen sein.")
|
||||
(fr "La commande @command{guix deploy} a une nouvelle option
|
||||
@option{--execute} ou @option{-x} qui permet d'exécuter une commande sur
|
||||
toutes les machines spécifiées dans son fichier de configuration, comme dans
|
||||
cet exemple :
|
||||
|
||||
@example
|
||||
guix deploy deploy.scm -x -- herd restart guix-daemon
|
||||
@end example
|
||||
|
||||
Ça ne remplace pas les outils sophistiqués comme pdsh mais c'est bien
|
||||
pratique.")))
|
||||
|
||||
(entry (commit "c4fe13c294cc1e31dd8a49ce3981f603fb169e0a")
|
||||
(title
|
||||
(en "@command{guix style} can format package definitions")
|
||||
(de "@command{guix style} kann Paketdefinitionen formatieren")
|
||||
(fr "@command{guix style} peut mettre en forme les définitions de paquets"))
|
||||
(body
|
||||
(en "The recently-introduced @command{guix style} command can now be
|
||||
used to automatically format package definitions according to the Guix
|
||||
project's formatting guidelines. If you contribute packages to Guix or to a
|
||||
third-party channel, you may find it useful.
|
||||
|
||||
The new @option{--styling} option can currently be passed one of the following
|
||||
@dfn{styling rules}: @code{format}, to format package definitions, or
|
||||
@code{inputs}, to remove labels from package inputs. Omitting
|
||||
@option{--styling} is equivalent to passing @samp{--styling=format};
|
||||
previously it was equivalent to @samp{--styling=inputs}.
|
||||
|
||||
Run @code{info \"(guix) Invoking guix style\"}, for more info.")
|
||||
(de "Der kürzlich eingeführte Befehl @command{guix style} kann jetzt
|
||||
benutzt werden, um Paketdefinitionen automatisch nach den
|
||||
Formatierungsrichtlinien des Guix-Projekts zu formatieren. Wenn Sie Pakete zu
|
||||
Guix oder zu einem Drittanbieterkanal beitragen, könnte Ihnen das helfen.
|
||||
|
||||
Für die neue Befehlszeilenoption @option{--styling} können Sie derzeit eine
|
||||
der folgenden @dfn{Stilregeln} angeben: @code{format}, wodurch
|
||||
Paketdefinitionen formatiert werden, oder @code{inputs}, wodurch die
|
||||
Bezeichnungen aus Paketeingaben entfernt werden. Wenn Sie {--styling}
|
||||
weglassen, passiert das Gleiche wie wenn Sie @samp{--styling=format} angeben;
|
||||
früher war es das Gleiche wie @samp{--styling=inputs}.
|
||||
|
||||
Führen Sie @command{info \"(guix) Invoking guix style\"} aus, um mehr
|
||||
Informationen zu erhalten.")
|
||||
(fr "La commande @command{guix style}, récemment introduite, peut
|
||||
désormais être utilisée pour mettre en forme des définitions de paquets
|
||||
suivant les règles de style du projet Guix. Si vous contribuez des paquets à
|
||||
Guix ou à un canal tiers, cela peut vous être utile.
|
||||
|
||||
La nouvelle option @option{--style} peut pour le moment recevoir une des deux
|
||||
@dfn{règles de style} suivantes : @code{format}, pour mettre en forme les
|
||||
définitions de paquet, ou @code{inputs}, pour retirer les étiquettes des
|
||||
champs @code{inputs} des paquets. Omettre @option{--styling} revient à passer
|
||||
@samp{--styling=format} ; auparavant c'était équivalent à
|
||||
@samp{--styling=inputs}.
|
||||
|
||||
Lancer @command{info \"(guix.fr) Invoquer guix style\"}, pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "d090e9c37d693f5a0f381482c17fb03462cb6a48")
|
||||
(title
|
||||
(en "New @option{--tune} option for CPU micro-architecture tuning")
|
||||
(de "Neue Option @option{--tune} ermöglicht mikroarchitekturspezifische Optimierungen")
|
||||
(fr "Nouvelle option @option{--tune} pour optimiser pour une
|
||||
micro-architecture"))
|
||||
(body
|
||||
(en "The new @option{--tune} package transformation option instructs
|
||||
Guix to tune relevant packages for the micro-architecture of the host CPU.
|
||||
This lets the compiler use single-instruction/multiple-data (SIMD)
|
||||
instructions beyond the baseline instruction set architecture (ISA), which can
|
||||
noticeably improve performance in some cases such as linear algebra code.
|
||||
|
||||
As an example, here is how you would install the GNU Astronomy Utilities
|
||||
against an optimized variant of the GNU Scientific Library (GSL):
|
||||
|
||||
@example
|
||||
guix install gnuastro --tune
|
||||
@end example
|
||||
|
||||
Run @command{info \"(guix) Package Transformation Options\"} for more
|
||||
information.")
|
||||
(de "Die neue Paketumwandlungsoption @option{--tune} lässt Guix die
|
||||
betroffenen Pakete an die im Prozessor dieses Rechners benutzte
|
||||
Mikroarchitektur anpassen. Dadurch kann der Compiler Befehle für
|
||||
Single-Instruction/Multiple-Data (SIMD) einsetzen, die über den gemeinsamen
|
||||
Befehlssatz hinausgehen. Das kann in manchen Fällen die Leistung beträchtlich
|
||||
steigern, etwa für Berechnungen der linearen Algebra.
|
||||
|
||||
Zum Beispiel würden Sie so die GNU-Astronomieprogramme unter Nutzung einer
|
||||
optimierten Variante der GNU Scientific Library (GSL) installieren:
|
||||
|
||||
@example
|
||||
guix install gnuastro --tune
|
||||
@end example
|
||||
|
||||
Führen Sie für mehr Informationen @command{info \"(guix.de)
|
||||
Paketumwandlungsoptionen\"} aus.")
|
||||
(fr "La nouvelle option de transformation de paquets @option{--tune}
|
||||
demande à Guix d'optimiser les paquets pour lesquels c'est pertinent pour la
|
||||
micro-architecture du processeur hôte. Cela permet au compilateur d'utiliser
|
||||
des instructions vectorielles (SIMD) en plus des instructions de base de
|
||||
l'architecture, ce qui peut sensiblement améliorer les performance dans
|
||||
certains cas tels que pour du code d'algèbre linéaire.
|
||||
|
||||
Par exemple, voici comment installer les Utilitaires d'astronomie GNU de
|
||||
manière à ce qu'ils utilisent une variante optimisée de la Bibliothèque
|
||||
scientifique GNU (GSL) :
|
||||
|
||||
@example
|
||||
guix install gnuastro --tune
|
||||
@end example
|
||||
|
||||
Lancer @command{info \"(guix.fr) Options de transformation de paquets\"} pour
|
||||
plus d'informations.")))
|
||||
|
||||
(entry (commit "ea2fd313d52dc62593b478acf5c3e7ea052c45de")
|
||||
(title
|
||||
(en "@samp{integer expected from stream}? Update your Guix daemon")
|
||||
(de "@samp{integer expected from stream}? Aktualisieren Sie Ihren Guix-Daemon")
|
||||
(nl "@samp{integer expected from stream}? Werk je Guix daemon bij"))
|
||||
(body
|
||||
(en "We recently fixed a bug where substitution would fail with
|
||||
@samp{error: integer expected from stream}. Be sure to update your system's
|
||||
Guix package that provides the @command{guix-daemon} if you haven't done so
|
||||
recently. Run @command{info \"(guix) Upgrading Guix\"} for instructions.")
|
||||
(de "Unlängst haben wir einen Fehler behoben, dass die Substitution
|
||||
mit der Fehlermeldung @samp{error: integer expected from stream}
|
||||
fehlschlägt. Bitte aktualisieren Sie daher Ihr systemweites Guix-Paket, das
|
||||
@command{guix-daemon} zur Verfügung stellt, wenn es noch nicht geschehen
|
||||
ist. Führen Sie @command{info \"(guix.de) Aktualisieren von Guix\"} aus für
|
||||
genaue Anweisungen.")
|
||||
(nl "Onlangs herstelden we een fout waarbij substitutie mislukt met
|
||||
een @samp{error: integer expected from stream}. Werk zeker je systeemwijde
|
||||
Guix-pakket bij, dat de @command{guix-daemon} levert, als dat nog niet is
|
||||
gebeurd. Voer @command{info \"(guix) Upgrading Guix\"} uit voor meer uitleg.")))
|
||||
|
||||
(entry (commit "223f1b1eb3707f1d3ef91200dd616ee6c8b77db0")
|
||||
(title
|
||||
(en "Improved static networking support on Guix System")
|
||||
(de "Bessere Unterstützung für statische Netzwerkanbindungen auf Guix System")
|
||||
(fr "Meilleure prise en charge des réseaux statiques sur Guix System"))
|
||||
(body
|
||||
(en "Support for declarative static networking setup on Guix System
|
||||
has been improved. It now allows you to list IPv4 and IPv6 addresses in
|
||||
routes in a flexible way, similar to what you would do with the @command{ip}
|
||||
command, but in a declarative fashion, as in this example:
|
||||
|
||||
@lisp
|
||||
;; Static networking for one NIC, IPv4-only.
|
||||
(service static-networking-service-type
|
||||
(list (static-networking
|
||||
(addresses
|
||||
(list (network-address
|
||||
(device \"eno1\")
|
||||
(value \"10.0.2.15/24\"))))
|
||||
(routes
|
||||
(list (network-route
|
||||
(destination \"default\")
|
||||
(gateway \"10.0.2.2\"))))
|
||||
(name-servers '(\"10.0.2.3\")))))
|
||||
@end lisp
|
||||
|
||||
The @code{static-networking-service} procedure remains available but is
|
||||
deprecated. Run @command{info \"(guix) Networking Setup\"} for more
|
||||
information.")
|
||||
(de "Die deklarative Konfiguration für statische Netzwerkanbindungen
|
||||
auf Guix System wurde verbessert. Sie können jetzt die IPv4- und
|
||||
IPv6-Adressen in Routen flexibel auflisten, ähnlich wie Sie es mit dem
|
||||
@command{ip}-Befehl tun würden, aber auf deklarative Weise wie in diesem
|
||||
Beispiel:
|
||||
|
||||
@lisp
|
||||
;; Statische Netzwerkkonfiguration mit einer Netzwerkkarte, nur IPv4.
|
||||
(service static-networking-service-type
|
||||
(list (static-networking
|
||||
(addresses
|
||||
(list (network-address
|
||||
(device \"eno1\")
|
||||
(value \"10.0.2.15/24\"))))
|
||||
(routes
|
||||
(list (network-route
|
||||
(destination \"default\")
|
||||
(gateway \"10.0.2.2\"))))
|
||||
(name-servers '(\"10.0.2.3\")))))
|
||||
@end lisp
|
||||
|
||||
Die Prozedur @code{static-networking-service} gibt es noch, aber sie gilt als
|
||||
veraltet. Führen Sie @command{info \"(guix) Networking Setup\"} aus für
|
||||
weitere Informationen.")
|
||||
(fr "La configuration déclarative et statique du réseau est mieux
|
||||
prise en charge sur Guix System. Il est maintenant possible d'énumérer des
|
||||
adresses IPv6 et IPv4 et les chemins avec plus de flexibilité, un peu comme ce
|
||||
qu'on peut faire avec la commande @command{ip} mais de manière déclarative,
|
||||
comme dans cet exemple :
|
||||
|
||||
@lisp
|
||||
;; Réseau statique à une seule interface, IPv4 seulement.
|
||||
(service static-networking-service-type
|
||||
(list (static-networking
|
||||
(addresses
|
||||
(list (network-address
|
||||
(device \"eno1\")
|
||||
(value \"10.0.2.15/24\"))))
|
||||
(routes
|
||||
(list (network-route
|
||||
(destination \"default\")
|
||||
(gateway \"10.0.2.2\"))))
|
||||
(name-servers '(\"10.0.2.3\")))))
|
||||
@end lisp
|
||||
|
||||
La procédure @code{static-networking-service} reste disponible mais elle est
|
||||
obsolète. Lancer @command{info \"(guix) Networking Setup\"} pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "52cb5cf5b852117b5151a67af187d80764849ad3")
|
||||
(title
|
||||
(en "Icedove 91: profile folder moved to @file{~/.thunderbird}")
|
||||
(de "Icedove 91: Profilordner jetzt unter @file{~/.thunderbird}"))
|
||||
(body
|
||||
(en "Icedove 91 expects your profile folder under @file{~/.thunderbird}.
|
||||
You need to manually copy your Icedove profiles from @file{~/.icedove} to
|
||||
@file{~./thunderbird}. It may be required to start Icedove with
|
||||
@option{--ProfileManager} for the first time after the migration.")
|
||||
(de "Icedove 91 erwartet Ihren Profilordner unter @file{~/.thunderbird}.
|
||||
Dafür müssen sie Ihre Icedove-Profile von @file{~/.icedove} nach
|
||||
@file{~/.thunderbird} kopieren. Eventuell muss Icedove das erste Mal nach der
|
||||
Migration mit @option{--ProfileManager} gestartet werden.")))
|
||||
|
||||
(entry (commit "746584e0ca200e7bf51b139ceb36c19ea81d6ef1")
|
||||
(title
|
||||
(en "New @command{guix shell} command supersedes @command{guix
|
||||
environment}")
|
||||
(de "Neuer Befehl @command{guix shell} löst @command{guix
|
||||
environment} ab")
|
||||
(fr "Nouvelle commande @command{guix shell} en remplacement de
|
||||
@command{guix environment}"))
|
||||
(body
|
||||
(en "A new @command{guix shell} command is now available. It is
|
||||
similar to @command{guix environment}, but with a more convenient interface
|
||||
(@command{guix environment} is deprecated but will remain available until May,
|
||||
1st 2023). The main difference compared to @command{guix environment} is that
|
||||
the \"ad hoc\" mode is the default. Thus, to create an interactive
|
||||
environment containing Python, NumPy, and SciPy, you would run:
|
||||
|
||||
@example
|
||||
guix shell python python-numpy python-scipy
|
||||
@end example
|
||||
|
||||
To get a development environment for, say, Inkscape, pass the @option{-D}
|
||||
flag:
|
||||
|
||||
@example
|
||||
guix shell -D inkscape
|
||||
@end example
|
||||
|
||||
Another difference is that running @command{guix shell} without arguments
|
||||
loads @file{manifest.scm} or @file{guix.scm} for the current directory or an
|
||||
ancestor, provided you allowed it. The command maintains a cache to speed up
|
||||
access to such environments.
|
||||
|
||||
Run @command{info \"(guix) Invoking guix shell\"} for more information.")
|
||||
(de "Ein neuer Befehl @command{guix shell} ist ab jetzt
|
||||
verfügbar. Er ähnelt @command{guix environment}, ist aber leichter zu
|
||||
benutzen (@command{guix environment} gilt als veraltet, bleibt aber
|
||||
bis zum 1.@: Mai 2023 verfügbar). Der größte Unterschied ist, dass das
|
||||
Verhalten mit @option{--ad-hoc} nun der Normalfall ist. D.h.@: um eine
|
||||
interaktive Umgebung mit Python, NumPy und SciPy zu bekommen, lautet
|
||||
der Befehl:
|
||||
|
||||
@example
|
||||
guix shell python python-numpy python-scipy
|
||||
@end example
|
||||
|
||||
Wenn Sie eine Entwicklungsumgebung für, sagen wir, Inkscape schaffen
|
||||
wollen, übergeben Sie die Option @option{-D}:
|
||||
|
||||
@example
|
||||
guix shell -D inkscape
|
||||
@end example
|
||||
|
||||
Noch ein Unterschied ist, dass wenn Sie @command{guix shell} ohne
|
||||
Argumente ausführen, @file{manifest.scm} oder @file{guix.scm} aus dem
|
||||
aktuellen Arbeitsverzeichnis oder einem übergeordneten Verzeichnis
|
||||
geladen wird, wenn Sie die Berechtigung dazu erteilt haben. Für den
|
||||
Befehl wird ein Zwischenspeicher vorgehalten, damit Sie schneller auf
|
||||
solche Umgebungen zugreifen können.
|
||||
|
||||
Führen Sie @command{info \"(guix) Invoking guix shell\"} aus, um mehr
|
||||
zu erfahren.")
|
||||
(fr "Une nouvelle commande, @command{guix shell}, est maintenant
|
||||
disponible. Elle est similaire à @command{guix environment}, mais avec une
|
||||
interface plus pratique (@command{guix environment} est désuet mais restera
|
||||
disponible jusqu'au 1er mai 2023). La principale différence par rapport à
|
||||
@command{guix environment} est que le mode par défaut est le mode \"ad hoc\".
|
||||
Pour créer un environnement interactif contenant Python, NumPy et SciPy, il
|
||||
faut donc lancer :
|
||||
|
||||
@example
|
||||
guix shell python python-numpy python-scipy
|
||||
@end example
|
||||
|
||||
Pour obtenir un environnement de développement pour Inkscape, par exemple,
|
||||
passer l'option @option{-D} :
|
||||
|
||||
@example
|
||||
guix shell -D inkscape
|
||||
@end example
|
||||
|
||||
Une autre différence est qu'en lançant @command{guix shell} sans argument, le
|
||||
fichier @file{manifest.scm} ou @file{guix.scm} du répertoire courant ou d'un
|
||||
parent est automatiquement chargé, à condition de l'avoir autorisé. La
|
||||
commande garde un cache pour accélérer l'accès à ces environnements.
|
||||
|
||||
Lancer @command{info \"(guix.fr) Invoquer guix shell\"} pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "a2324d8b56eabf8117bca220a507cc791edffd2e")
|
||||
(title
|
||||
(en "Guix Home is a part of GNU Guix")
|
||||
(de "Guix Home ist jetzt Teil von GNU Guix")
|
||||
(ru "Guix Home теперь поставляется в составе GNU Guix"))
|
||||
(body
|
||||
(en "Guix Home splitted out from rde project and now is a part of
|
||||
Guix proper. It is available as a @emph{technology preview} and thus subject
|
||||
to change.
|
||||
|
||||
The new @command{guix home} command with its actions allows users to
|
||||
manage their packages and configurations (aka. dotfiles) in a declarative way,
|
||||
similar to how many people manage their system with @command{guix system}.
|
||||
|
||||
Take a look at available actions and arguments:
|
||||
@example
|
||||
guix home --help
|
||||
@end example
|
||||
|
||||
See @command{info \"(guix) Home Configuration\"} for more information.")
|
||||
(de "Guix Home ist aus dem rde-Projekt ins offizielle Guix übernommen
|
||||
worden. Es ist als @emph{Technologievorschau} bereits verfügbar, aber die
|
||||
Schnittstelle kann sich in Zukunft noch ändern.
|
||||
|
||||
Der neue Befehl @command{guix home} ermöglicht es, die Pakete und
|
||||
Konfigurationsdateien (Dotfiles) für ein Benutzerkonto im deklarativen Stil zu
|
||||
verwalten. Es ist analog dazu, wie man @command{guix system} benutzen kann, um
|
||||
sein System zu verwalten.
|
||||
|
||||
Werfen Sie einen Blick auf die verfügbaren Aktionen und Argumente:
|
||||
@example
|
||||
guix home --help
|
||||
@end example
|
||||
|
||||
Führen Sie für mehr Informationen @command{info \"(guix) Home Configuration\"}
|
||||
aus.")
|
||||
(ru "Guix Home отделился от проекта rde и теперь является частью
|
||||
Guix. Новая команда @command{guix home} даёт возможность пользователям
|
||||
управлять их пакетами и конфигурациями (дотфайлами) для них в декларативном
|
||||
стиле, аналогично тому, как многие люди управляют своими системами с помощью
|
||||
@command{guix system}.
|
||||
|
||||
Чтобы получить список доступных действий и аргументов:
|
||||
@example
|
||||
guix home --help
|
||||
@end example
|
||||
|
||||
Смотрите @command{info \"(guix) Home Configuration\"} для получения более
|
||||
детальных сведений.")))
|
||||
|
||||
(entry (commit "5b32ad4f6f555d305659cee825879df075b06331")
|
||||
(title
|
||||
(en "New @option{--max-depth} option for @command{guix graph}")
|
||||
(de "Neue Option @option{--max-depth} für @command{guix graph}")
|
||||
(fr "Nouvelle option @option{--max-depth} pour @command{guix graph}"))
|
||||
(body
|
||||
(en "The @command{guix graph} command has a new @option{--max-depth}
|
||||
(or @option{-M}) option, which allows you to restrict a graph to the given
|
||||
depth---very useful when visualizing large graphs. For example, the command
|
||||
below displays, using the @code{xdot} package, the dependency graph of
|
||||
LibreOffice, including only nodes that are at most at distance 2 of
|
||||
LibreOffice itself:
|
||||
|
||||
@example
|
||||
guix graph -M 2 libreoffice | xdot -
|
||||
@end example
|
||||
|
||||
See @command{info \"(guix) Invoking guix graph\"} for more information.")
|
||||
(de "Der Befehl @command{guix graph} verfügt über eine neue
|
||||
Befehlszeilenoption @option{--max-depth} (oder @option{-M}), mit der
|
||||
Sie einen Graphen auf die angegebene Tiefe einschränken. Das ist vor
|
||||
allem bei großen Graphen nützlich; zum Beispiel zeigt der folgende
|
||||
Befehl, unter Verwendung des Pakets @code{xdot}, den
|
||||
Abhängigkeitsgraphen von LibreOffice unter Ausschluss der Knoten, die
|
||||
eine Distanz größer als 2 von LibreOffice selbst haben:
|
||||
|
||||
@example
|
||||
guix graph -M 2 libreoffice | xdot -
|
||||
@end example
|
||||
|
||||
Führen Sie @code{info \"(guix.de) Aufruf von guix graph\"} aus, um mehr zu
|
||||
erfahren.")
|
||||
(fr "La commande @command{guix graph} dispose d'une nouvelle option
|
||||
@option{--max-depth} (ou @option{-M}) pour restreindre la profondeur d'un
|
||||
graphe---très utile pour visualiser des gros graphes. Par exemple, la
|
||||
commande ci-dessous affiche, en utilisant @code{xdot}, le graphe de dépendance
|
||||
de LibreOffice en n'incluant que les nœuds qui sont au plus à distance 2 de
|
||||
LibreOffice soi-même :
|
||||
|
||||
@example
|
||||
guix graph -M 2 libreoffice | xdot -
|
||||
@end example
|
||||
|
||||
Voir @command{info \"(guix.fr) Invoquer guix graph\"} pour plus
|
||||
d'informations.")))
|
||||
|
||||
(entry (commit "05f44c2d858a1e7b13c90362c35fa86bdc4d5a24")
|
||||
(title
|
||||
(en "Channel clones fall back to Software Heritage")
|
||||
(de "Zum Klonen von Kanälen wird notfalls auf Software Heritage zurückgegriffen")
|
||||
(fr "Les clones de canaux peuvent recourir à Software Heritage"))
|
||||
(body
|
||||
(en "When @command{guix time-machine} or @command{guix pull} fetches
|
||||
a channel pinned to a specific commit, it now automatically falls back to
|
||||
cloning it from the Software Heritage archive if the original URL is
|
||||
unreachable. This contributes to long-term reproducibility. See
|
||||
@command{info \"(guix) Replicating Guix\"}.
|
||||
|
||||
Automatic fallback also works for other Git clones made on your behalf, such
|
||||
as when using @option{--with-commit} and related package transformation
|
||||
options.")
|
||||
(de "Wenn bei @command{guix time-machine} oder @command{guix
|
||||
pull} ein bestimmter Commit eines Kanals bezogen werden soll, wird
|
||||
jetzt für den Fall, dass die ursprüngliche URL unerreichbar ist,
|
||||
automatisch vom Software-Heritage-Archiv geklont. Das trägt zur
|
||||
langfristigen Reproduzierbarkeit bei. Siehe @command{info \"(guix.de)
|
||||
Guix nachbilden\"}.
|
||||
|
||||
Der automatische Rückgriff auf Software Heritage findet auch
|
||||
Verwendung bei anderen Arten von Git-Klon, die Guix durchführt, z.B.@:
|
||||
wenn Sie @option{--with-commit} und ähnliche Paketumwandlungsoptionen
|
||||
einsetzen.")
|
||||
(fr "Quand la commande @command{guix time-machine} ou @command{guix
|
||||
pull} récupère un canal fixé à une révision spécifique, elle est maintenant
|
||||
capable de le cloner depuis l'archive Software Heritage si l'URL initiale
|
||||
n'est plus disponible. Cela contribue à la reproductibilité à long terme.
|
||||
Voir @command{info \"(guix.fr) Répliquer Guix\"}.
|
||||
|
||||
Ce recours à Software Heritage fonctionne aussi pour les autres clones Git que
|
||||
Guix peut faire, comme lorsqu'on utilise @option{--with-commit} et les options
|
||||
de transformation de paquet similaires.")))
|
||||
|
||||
(entry (commit "db4681a4c17d282a661552f2f57e5c453d02e414")
|
||||
(title
|
||||
(en "@code{gdm-service-type} now supports Wayland")
|
||||
(de "@code{gdm-service-type} bietet nun Unterstützung für Wayland")
|
||||
(fr "@code{gdm-service-type} prend maintenant en charge Wayland"))
|
||||
(body
|
||||
(en "@code{gdm-service-type} has been updated to support being launched
|
||||
as a Wayland client, and to launch Wayland sessions. The @code{wayland?} boolean
|
||||
field in @code{gdm-configuration} controls whether GDM starts in Wayland or X
|
||||
mode. See @command{info \"(guix) X Window\"} for more information.
|
||||
|
||||
Wayland mode for GDM will soon become the default in Guix, so if your
|
||||
hardware doesn't support Wayland (Nvidia users are the most concerned here),
|
||||
please consider disabling it now.")
|
||||
(de "@code{gdm-service-type} wurde um Unterstützung dafür
|
||||
aktualisiert, als Wayland-Client gestartet zu werden und Wayland-Sitzungen zu
|
||||
starten. Der Boolesche Wert im Feld @code{wayland?} in
|
||||
@code{gdm-configuration} bestimmt, ob GDM im Wayland- oder X-Modus gestartet
|
||||
wird. Siehe @command{info \"(guix.de) X Window\"} für weitere Informationen.
|
||||
|
||||
Bald wird der Wayland-Modus für GDM die Vorgabeeinstellung in Guix werden,
|
||||
daher sollten Sie, wenn Ihre Hardware kein Wayland unterstützt (Nvidia-Nutzer
|
||||
betrifft dies am ehesten), ihn jetzt ausdrücklich abschalten.")
|
||||
(fr "@code{gdm-service-type} a été mis à jour et peut maintenant être
|
||||
lancé comme client Wayland, ainsi que lancer des sessions Wayland. Le champ
|
||||
booléen @code{wayland?} de @code{gdm-configuration} contrôle le mode dans lequel
|
||||
GDM est lancé (Wayland ou X). Pour plus d'informations, voir
|
||||
@command{info \"(guix) X Window\"} (en anglais).
|
||||
|
||||
GDM sera bientôt lancé en mode Wayland par défaut sur Guix, donc si votre matériel
|
||||
ne le prend pas en charge (les utilisateur·ices de cartes Nvidia sont les plus
|
||||
concerné·es), merci de le désactiver dès maintenant.")))
|
||||
|
||||
(entry (commit "f23803af2018a148fb088f2516d79c20d6bf95f0")
|
||||
(title
|
||||
(en "Input labels can now be omitted in package definitions")
|
||||
(de "Eingaben in Paketdefinitionen brauchen keine Bezeichnungen mehr"))
|
||||
(body
|
||||
(en "If you have written package definitions before, you may know
|
||||
that package inputs required a bit of boilerplate: each input needs to have an
|
||||
associated label (a string), which you can refer to in ``build-side code''.
|
||||
|
||||
Input labels are now unnecessary, meaning that you can write code like:
|
||||
|
||||
@lisp
|
||||
(package
|
||||
;; @dots{}
|
||||
(inputs (list libunistring libffi libgc)))
|
||||
@end lisp
|
||||
|
||||
Notice that the @code{inputs} field is simplified compared to the ``old
|
||||
style''. When needed, you can now use g-expressions (gexps) to refer to
|
||||
another package in build-side code. Additionally, the new
|
||||
@code{modify-inputs} macro facilitates common operations on inputs---deleting,
|
||||
replacing, adding inputs.
|
||||
|
||||
To ease transition to the ``new style'', a new @command{guix style} command is
|
||||
provided. Run @command{info \"(guix) Invoking guix style\"} for more info.")
|
||||
(de "Wenn Sie bereits Paketdefinitionen verfasst haben,
|
||||
erinnern Sie sich vielleicht, dass Sie für Paketeingaben manches
|
||||
doppelt schreiben mussten: Jede Eingabe wird assoziiert mit einer
|
||||
Bezeichnung (als Zeichenkette), auf die Sie sich in
|
||||
„erstellungsseitigem Code“ beziehen können.
|
||||
|
||||
Diese Eingabebezeichnungen sind @emph{nicht} mehr nötig. Sie können
|
||||
jetzt solchen Code schreiben:
|
||||
|
||||
@lisp
|
||||
(package
|
||||
;; …
|
||||
(inputs (list libunistring libffi libgc)))
|
||||
@end lisp
|
||||
|
||||
Achten Sie auf das gegenüber früher vereinfachte @code{inputs}-Feld.
|
||||
Wenn nötig können Sie in erstellungsseitigem Code G-Ausdrücke (gexps)
|
||||
benutzen, um andere Pakete zu referenzieren. Des Weiteren erleichtert
|
||||
das Makro @code{modify-inputs} geläufige Operationen auf Eingaben —
|
||||
das Löschen, Ersetzen, Hinzufügen von Eingaben.
|
||||
|
||||
Um den Übergang zum „neuen Stil“ zu erleichtern, steht ein neuer
|
||||
Befehl @command{guix style} zur Verfügung. Führen Sie @command{info
|
||||
\"(guix) Invoking guix style\"} aus, um mehr Informationen zu
|
||||
erhalten.")))
|
||||
|
||||
(entry (commit "82daab42811a2e3c7684ebdf12af75ff0fa67b99")
|
||||
(title
|
||||
(en "New @samp{deb} format for the @command{guix pack} command")
|
||||
(de "Neues Format @samp{deb} für den Befehl @command{guix pack}"))
|
||||
(body
|
||||
(en "Debian archives (with the .deb file extension) can now be
|
||||
produced via the @command{guix pack --format=deb} command, providing an
|
||||
alternative distribution path for software built with Guix. Here is a simple
|
||||
example that generates a Debian archive for the @code{hello} package:
|
||||
|
||||
@example
|
||||
guix pack --format=deb --symlink=/usr/bin/hello=bin/hello hello
|
||||
@end example
|
||||
|
||||
See @command{info \"(guix) Invoking guix pack\"} for more information.")
|
||||
(de "Debian-Archive (mit der Dateinamenserweiterung .deb) können
|
||||
jetzt auch mit dem Befehl @command{guix pack --format=deb} erzeugt werden, um
|
||||
mit Guix erstellte Software auf andere Art anzubieten. Hier sehen Sie ein
|
||||
einfaches Beispiel, wie ein Debian-Archiv für das Paket @code{hello} angelegt
|
||||
wird:
|
||||
|
||||
@example
|
||||
guix pack --format=deb --symlink=/usr/bin/hello=bin/hello hello
|
||||
@end example
|
||||
|
||||
Siehe @command{info \"(guix.de) Aufruf von guix pack\"} für mehr
|
||||
Informationen.")))
|
||||
|
||||
(entry (commit "bdc298ecee15283451d3aa20a849dd7bb22c8538")
|
||||
(title
|
||||
(en "New @command{guix import egg} command")
|
||||
(de "Neuer Befehl @command{guix import egg}")
|
||||
(zh "新的 @command{guix import egg} 命令"))
|
||||
(body
|
||||
(en "The new @command{guix import egg} command allows packagers to
|
||||
generate a package definition or a template thereof given the name of a
|
||||
CHICKEN egg package, like so:
|
||||
|
||||
@example
|
||||
guix import egg sourcehut
|
||||
@end example
|
||||
|
||||
Run @command{info \"(guix) Invoking guix import\"} for more info.")
|
||||
(de "Mit dem neuen Befehl @command{guix import egg} können
|
||||
Paketautoren eine Paketdefinition oder eine Vorlage dafür anhand des Namens
|
||||
eines „Egg“-Pakets für CHICKEN erzeugen, etwa so:
|
||||
|
||||
@example
|
||||
guix import egg sourcehut
|
||||
@end example
|
||||
|
||||
Führen Sie @command{info \"(guix.de) Aufruf von guix import\"} aus, um mehr
|
||||
Informationen zu bekommen.")
|
||||
(zh "新的 @command{guix import egg} 命令能让贡献者从一个CHICKEN egg生
|
||||
成一个包装或包装样板。
|
||||
|
||||
@example
|
||||
guix import egg sourcehut
|
||||
@end example
|
||||
|
||||
想了解更多可以运行 @command{info \"(guix) Invoking guix import\"}。")))
|
||||
|
||||
(entry (commit "2161820ebbbab62a5ce76c9101ebaec54dc61586")
|
||||
(title
|
||||
(en "Risk of local privilege escalation during user account creation")
|
||||
@@ -1161,7 +246,7 @@ Nous conseillons de mettre à jour @command{guix-daemon}. Lancer @command{info
|
||||
\"(guix.fr) Mettre à niveau Guix\"} pour voir comment faire. Voir
|
||||
@uref{https://issues.guix.gnu.org/47229} pour plus d'informations sur cette
|
||||
faille.")
|
||||
(nl "In @command{guix-daemon} werd een beveiligingsprobleem
|
||||
(nl "In @command{guix-daemon} werd een beveiligingsprobleem
|
||||
gevonden dat kan leiden tot de escalatie van lokale bevoegdheden. Het
|
||||
probleem doet zich voor bij installaties met meerdere gebruikers waarop een
|
||||
lokale @command{guix-daemon} draait.
|
||||
@@ -1251,7 +336,7 @@ guix import go golang.org/x/sys
|
||||
@end example
|
||||
|
||||
Lancez @command{info \"(guix.fr) Invoquer guix import\"} pour en savoir plus.")
|
||||
(nl "Met de nieuwe @command{guix import go}-opdracht kunnen
|
||||
(nl "Met de nieuwe @command{guix import go}-opdracht kunnen
|
||||
pakketschrijvers een pakketdefinitie of -sjabloon aanmaken, op basis van de
|
||||
naam van een Go-pakket te vinden op @url{https://proxy.golang.org}:
|
||||
|
||||
@@ -1264,28 +349,28 @@ informatie.")))
|
||||
|
||||
(entry (commit "1b5b882120daf7d111aa351a919a90e818324347")
|
||||
(title
|
||||
(en "The @code{linux-libre} kernel is updated to 5.11.2")
|
||||
(de "Der Kernel @code{linux-libre} wird auf 5.11.2 aktualisiert")
|
||||
(fr "Le noyau @code{linux-libre} est mis à jour vers la 5.11.2")
|
||||
(nl "De @code{linux-libre}-kernel werd bijgewertk naar 5.11.2"))
|
||||
(en "The @code{linux-libre} kernel is updated to 5.11.2")
|
||||
(de "Der Kernel @code{linux-libre} wird auf 5.11.2 aktualisiert")
|
||||
(fr "Le noyau @code{linux-libre} est mis à jour vers la 5.11.2")
|
||||
(nl "De @code{linux-libre}-kernel werd bijgewertk naar 5.11.2"))
|
||||
(body
|
||||
(en "The default @code{linux-libre} kernel is now based on the 5.11
|
||||
(en "The default @code{linux-libre} kernel is now based on the 5.11
|
||||
stable kernel series, beginning with version 5.11.2. Promiment features include
|
||||
improved Wine performance, unprivileged Overlayfs mounts, support for Intel SGX,
|
||||
support for new graphics hardware, and improved performance of the Btrfs
|
||||
file system.")
|
||||
(de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
|
||||
(de "Der standardmäßig verwendete @code{linux-libre}-Kernel basiert
|
||||
jetzt auf der 5.11-„stable“-Versionsreihe, angefangen mit Version 5.11.2. Zu
|
||||
den markanten Neuerungen gehören bessere Wine-Unterstützung, Einbinden per
|
||||
Overlayfs für Nutzer ohne erweiterte Rechte, Unterstützung für Intel SGX, für
|
||||
neue Grafikhardware und bessere Leistung beim Btrfs-Dateisystem.")
|
||||
(fr "Le noyau @code{linux-libre} par défaut est maintenant basé sur la
|
||||
(fr "Le noyau @code{linux-libre} par défaut est maintenant basé sur la
|
||||
lignée stable 5.11 du noyau, à commencer par la version 5.11.2. Parmi les
|
||||
fonctionnalités notables on trouve des performances améliorées pour Wine, le
|
||||
montage Overlayfs non privilégié, la prise en charge d'Intel SGX, celle des
|
||||
nouveaux périphériques graphiques et de meilleures performances du système de
|
||||
fichiers Btrfs.")
|
||||
(nl "De standaard @code{linux-libre}-kernel is nu geëent op de
|
||||
(nl "De standaard @code{linux-libre}-kernel is nu geëent op de
|
||||
stabiele 5.11-reeks, te beginnen met versie 5.11.2. Deze update biedt onder
|
||||
andere verbeterde prestaties voor Wine en het Btfrs-bestandssysteem, laat
|
||||
gewone gebruikers toe om met Overlayfs bestandssystemen te combineren, en
|
||||
|
||||
@@ -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"
|
||||
|
||||
|
||||
@@ -23,7 +23,7 @@
|
||||
(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)
|
||||
(srfi srfi-1)
|
||||
@@ -125,13 +125,8 @@ TARGET."
|
||||
(define %system-manifest
|
||||
(manifest
|
||||
(append-map (lambda (system)
|
||||
;; Some of %SYSTEM-PACKAGES are currently unsupported on some
|
||||
;; systems--e.g., GNOME on non-x86_64, due to Rust. Filter
|
||||
;; them out.
|
||||
(filter-map (lambda (package)
|
||||
(and (supported-package? package system)
|
||||
(package->manifest-entry* package system)))
|
||||
%system-packages))
|
||||
(map (cut package->manifest-entry* <> system)
|
||||
%system-packages))
|
||||
'("x86_64-linux" "i686-linux")))) ;Guix System
|
||||
|
||||
(define %cross-manifest
|
||||
@@ -144,7 +139,7 @@ TARGET."
|
||||
%packages-to-cross-build)))
|
||||
;; XXX: Important bits like libsigsegv and libffi don't support
|
||||
;; RISCV at the moment, so don't require RISCV support.
|
||||
(delete "riscv64-linux-gnu" (targets)))))
|
||||
(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
|
||||
|
||||
@@ -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.
|
||||
@@ -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,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#)
|
||||
)
|
||||
)
|
||||
+9
-30
@@ -18,8 +18,6 @@
|
||||
|
||||
(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))
|
||||
@@ -43,21 +41,6 @@ determined."
|
||||
(repository-close! repository))
|
||||
#f))))
|
||||
|
||||
(define-syntax mparameterize
|
||||
(syntax-rules ()
|
||||
"This form implements dynamic scoping, similar to 'parameterize', but in a
|
||||
monadic context."
|
||||
((_ monad ((parameter value) rest ...) body ...)
|
||||
(let ((old-value (parameter)))
|
||||
(mbegin monad
|
||||
;; XXX: Non-local exits are not correctly handled.
|
||||
(return (parameter value))
|
||||
(mlet monad ((result (mparameterize monad (rest ...) body ...)))
|
||||
(parameter old-value)
|
||||
(return result)))))
|
||||
((_ monad () body ...)
|
||||
(mbegin monad body ...))))
|
||||
|
||||
(define (tests-for-current-guix source commit)
|
||||
"Return a list of tests for perform, using Guix built from SOURCE, a channel
|
||||
instance."
|
||||
@@ -65,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,264 +0,0 @@
|
||||
#!@GUILE@ \
|
||||
--no-auto-compile -s
|
||||
!#
|
||||
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; 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.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(use-modules (srfi srfi-1)
|
||||
(srfi srfi-9)
|
||||
(ice-9 format)
|
||||
(ice-9 match)
|
||||
(guix ui))
|
||||
|
||||
(define-record-type <team>
|
||||
(make-team id name description members)
|
||||
team?
|
||||
(id team-id)
|
||||
(name team-name)
|
||||
(description team-description)
|
||||
(members team-members set-team-members!))
|
||||
|
||||
(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 '()))
|
||||
(make-team id
|
||||
(or name (symbol->string id))
|
||||
description
|
||||
members))
|
||||
|
||||
(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."))
|
||||
|
||||
(define-team haskell
|
||||
(team 'haskell
|
||||
#:name "Haskell team"
|
||||
#:description
|
||||
"GHC, Hugs, Haskell packages, the \"hackage\" and \"stackage\" importers, and
|
||||
the haskell-build-system."))
|
||||
|
||||
(define-team r
|
||||
(team 'r
|
||||
#:name "R team"
|
||||
#:description
|
||||
"The R language, CRAN and Bioconductor repositories, the \"cran\" importer,
|
||||
and the r-build-system."))
|
||||
|
||||
(define-team julia
|
||||
(team 'julia
|
||||
#:name "Julia team"
|
||||
#:description
|
||||
"The Julia language, Julia packages, and the julia-build-system."))
|
||||
|
||||
(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."))
|
||||
|
||||
(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."))
|
||||
|
||||
(define-team science
|
||||
(team 'science
|
||||
#:name "Science team"))
|
||||
|
||||
(define-team emacs
|
||||
(team 'emacs
|
||||
#:name "Emacs team"))
|
||||
|
||||
(define-team lisp
|
||||
(team 'lisp
|
||||
#:name "Lisp team"))
|
||||
|
||||
(define-team ruby
|
||||
(team 'ruby
|
||||
#:name "Ruby team"))
|
||||
|
||||
(define-team go
|
||||
(team 'go
|
||||
#:name "Go team"))
|
||||
|
||||
(define-team embedded-bootstrap
|
||||
(team 'embedded-bootstrap
|
||||
#:name "Embedded / Bootstrap"))
|
||||
|
||||
(define-team rust
|
||||
(team 'rust
|
||||
#:name "Rust"))
|
||||
|
||||
(define-team kernel
|
||||
(team 'kernel
|
||||
#:name "Linux-libre kernel team"))
|
||||
|
||||
(define-team core
|
||||
(team 'core
|
||||
#:name "Core / Tools / Internals"))
|
||||
|
||||
(define-team games
|
||||
(team 'games
|
||||
#:name "Games and Videos"))
|
||||
|
||||
(define-team translations
|
||||
(team 'translations
|
||||
#:name "Translations"))
|
||||
|
||||
(define-team installer
|
||||
(team 'installer
|
||||
#:name "Installer script and system installer"))
|
||||
|
||||
(define-team home
|
||||
(team 'home
|
||||
#:name "Team for \"guix home\""))
|
||||
|
||||
(define-team mentors
|
||||
(team 'mentors
|
||||
#:name "Mentors"
|
||||
#:description
|
||||
"A group of mentors who chaperone contributions by newcomers."))
|
||||
|
||||
|
||||
(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 "Liliana Marie Prikler"
|
||||
"liliana.prikler@gmail.com")
|
||||
emacs games)
|
||||
|
||||
(define-member (person "Ricardo Wurmus"
|
||||
"rekado@elephly.net")
|
||||
r core mentors)
|
||||
|
||||
|
||||
(define (find-team name)
|
||||
(or (hash-ref %teams (string->symbol name))
|
||||
(error (format #false
|
||||
"no such team: ~a~%" name))))
|
||||
|
||||
(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)))
|
||||
(team-members team)))
|
||||
|
||||
(define (list-teams)
|
||||
"Print all teams and their members."
|
||||
(define port* (current-output-port))
|
||||
(define width* (%text-width))
|
||||
(hash-for-each
|
||||
(lambda (key team)
|
||||
(format port*
|
||||
"\
|
||||
id: ~a
|
||||
name: ~a
|
||||
description: ~a
|
||||
members:
|
||||
"
|
||||
(team-id team)
|
||||
(team-name team)
|
||||
(or (and=> (team-description team)
|
||||
(lambda (text)
|
||||
(string->recutils
|
||||
(fill-paragraph text width*
|
||||
(string-length "description: ")))))
|
||||
"<none>"))
|
||||
(list-members team port* "+ ")
|
||||
(newline))
|
||||
%teams))
|
||||
|
||||
(define (main . args)
|
||||
(match args
|
||||
(("cc" . team-names)
|
||||
(apply cc (map find-team team-names)))
|
||||
(("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>]~%"))))
|
||||
|
||||
(apply main (cdr (command-line)))
|
||||
+4
-31
@@ -2,7 +2,7 @@
|
||||
;;; Copyright © 2017 David Craven <david@craven.ch>
|
||||
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
|
||||
;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
@@ -25,10 +25,7 @@
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix deprecation)
|
||||
#:use-module ((guix ui) #:select (warn-about-load-error))
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (menu-entry
|
||||
@@ -58,8 +55,7 @@
|
||||
bootloader-configuration
|
||||
bootloader-configuration?
|
||||
bootloader-configuration-bootloader
|
||||
bootloader-configuration-target ;deprecated
|
||||
bootloader-configuration-targets
|
||||
bootloader-configuration-target
|
||||
bootloader-configuration-menu-entries
|
||||
bootloader-configuration-default-entry
|
||||
bootloader-configuration-timeout
|
||||
@@ -183,22 +179,12 @@ record."
|
||||
;; The <bootloader-configuration> record contains bootloader independant
|
||||
;; configuration used to fill bootloader configuration file.
|
||||
|
||||
(define-with-syntax-properties (warn-target-field-deprecation
|
||||
(value properties))
|
||||
(when value
|
||||
(warning (source-properties->location properties)
|
||||
(G_ "the 'target' field is deprecated, please use 'targets' \
|
||||
instead~%")))
|
||||
value)
|
||||
|
||||
(define-record-type* <bootloader-configuration>
|
||||
bootloader-configuration make-bootloader-configuration
|
||||
bootloader-configuration?
|
||||
(bootloader bootloader-configuration-bootloader) ;<bootloader>
|
||||
(targets %bootloader-configuration-targets ;list of strings
|
||||
(target bootloader-configuration-target ;string
|
||||
(default #f))
|
||||
(target %bootloader-configuration-target ;deprecated
|
||||
(default #f) (sanitize warn-target-field-deprecation))
|
||||
(menu-entries bootloader-configuration-menu-entries ;list of <menu-entry>
|
||||
(default '()))
|
||||
(default-entry bootloader-configuration-default-entry ;integer
|
||||
@@ -218,19 +204,6 @@ instead~%")))
|
||||
(serial-speed bootloader-configuration-serial-speed ;integer | #f
|
||||
(default #f)))
|
||||
|
||||
(define-deprecated (bootloader-configuration-target config)
|
||||
bootloader-configuration-targets
|
||||
(%bootloader-configuration-target config))
|
||||
|
||||
(define (bootloader-configuration-targets config)
|
||||
(or (%bootloader-configuration-targets config)
|
||||
;; TODO: Remove after the deprecated 'target' field is removed.
|
||||
(list (%bootloader-configuration-target config))
|
||||
;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
|
||||
;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
|
||||
;; hence the default value of '(#f) rather than '().
|
||||
(list #f)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Bootloaders.
|
||||
|
||||
+32
-100
@@ -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)
|
||||
@@ -422,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))))
|
||||
@@ -613,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."
|
||||
@@ -701,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\")
|
||||
…))
|
||||
…)
|
||||
|
||||
@@ -787,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))
|
||||
|
||||
|
||||
+12
-30
@@ -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))))
|
||||
|
||||
|
||||
+13
-25
@@ -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,5 +1,5 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2020, 2021 Marius Bakke <marius@gnu.org>
|
||||
;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -17,8 +17,13 @@
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu build chromium-extension)
|
||||
#:use-module (gcrypt base16)
|
||||
#:use-module ((gcrypt hash) #:prefix hash:)
|
||||
#:use-module (ice-9 iconv)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (gnu packages base)
|
||||
#:use-module (gnu packages check)
|
||||
#:use-module (gnu packages chromium)
|
||||
#:use-module (gnu packages gnupg)
|
||||
#:use-module (gnu packages tls)
|
||||
@@ -34,30 +39,28 @@
|
||||
|
||||
(define (make-signing-key seed)
|
||||
"Return a derivation for a deterministic PKCS #8 private key using SEED."
|
||||
(computed-file
|
||||
(string-append seed "-signing-key.pem")
|
||||
(with-extensions (list guile-gcrypt)
|
||||
#~(begin
|
||||
(use-modules (gcrypt base16) (gcrypt hash) (ice-9 iconv))
|
||||
(let* ((sha256sum (bytevector->base16-string
|
||||
(sha256 (string->bytevector #$seed "UTF-8"))))
|
||||
;; certtool.c wants a 56 byte seed for a 2048 bit key.
|
||||
(key-size 2048)
|
||||
(normalized-seed (string-take sha256sum 56)))
|
||||
|
||||
(system* #$(file-append gnutls "/bin/certtool")
|
||||
"--generate-privkey"
|
||||
"--key-type=rsa"
|
||||
"--pkcs8"
|
||||
;; Use the provable FIPS-PUB186-4 algorithm for
|
||||
;; deterministic results.
|
||||
"--provable"
|
||||
"--password="
|
||||
"--no-text"
|
||||
(string-append "--bits=" (number->string key-size))
|
||||
(string-append "--seed=" normalized-seed)
|
||||
"--outfile" #$output))))
|
||||
#:local-build? #t))
|
||||
(define sha256sum
|
||||
(bytevector->base16-string (hash:sha256 (string->bytevector seed "UTF-8"))))
|
||||
|
||||
;; certtool.c wants a 56 byte seed for a 2048 bit key.
|
||||
(define size 2048)
|
||||
(define normalized-seed (string-take sha256sum 56))
|
||||
|
||||
(computed-file (string-append seed "-signing-key.pem")
|
||||
#~(system* #$(file-append gnutls "/bin/certtool")
|
||||
"--generate-privkey"
|
||||
"--key-type=rsa"
|
||||
"--pkcs8"
|
||||
;; Use the provable FIPS-PUB186-4 algorithm for
|
||||
;; deterministic results.
|
||||
"--provable"
|
||||
"--password="
|
||||
"--no-text"
|
||||
(string-append "--bits=" #$(number->string size))
|
||||
(string-append "--seed=" #$normalized-seed)
|
||||
"--outfile" #$output)
|
||||
#:local-build? #t))
|
||||
|
||||
(define* (make-crx signing-key package #:optional (package-output "out"))
|
||||
"Create a signed \".crx\" file from the unpacked Chromium extension residing
|
||||
@@ -65,9 +68,9 @@ in PACKAGE-OUTPUT of PACKAGE. The extension will be signed with SIGNING-KEY."
|
||||
(define name (package-name package))
|
||||
(define version (package-version package))
|
||||
|
||||
(computed-file
|
||||
(string-append name "-" version ".crx")
|
||||
(with-imported-modules '((guix build utils))
|
||||
(with-imported-modules '((guix build utils))
|
||||
(computed-file
|
||||
(string-append name "-" version ".crx")
|
||||
#~(begin
|
||||
;; This is not great. We pull Xorg and Chromium just to Zip and
|
||||
;; sign an extension. This should be implemented with something
|
||||
@@ -75,22 +78,27 @@ in PACKAGE-OUTPUT of PACKAGE. The extension will be signed with SIGNING-KEY."
|
||||
(use-modules (guix build utils))
|
||||
(let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
|
||||
(xvfb #$(file-append xorg-server "/bin/Xvfb"))
|
||||
(packdir (string-append (getcwd) "/extension")))
|
||||
(mkdir packdir)
|
||||
(copy-recursively (ungexp package package-output) packdir
|
||||
;; Ensure consistent file modification times.
|
||||
#:keep-mtime? #t)
|
||||
(packdir "/tmp/extension"))
|
||||
(mkdir-p (dirname packdir))
|
||||
(copy-recursively (ungexp package package-output) packdir)
|
||||
(system (string-append xvfb " :1 &"))
|
||||
(setenv "DISPLAY" ":1")
|
||||
(sleep 2) ;give Xorg some time to initialize...
|
||||
(invoke chromium
|
||||
"--user-data-dir=chromium-profile"
|
||||
;; Chromium stores the current time in the .crx Zip archive.
|
||||
;; Use a fixed timestamp for deterministic behavior.
|
||||
;; FIXME (core-updates): faketime is missing an absolute reference
|
||||
;; to 'date', hence the need to set PATH.
|
||||
(setenv "PATH" #$(file-append coreutils "/bin"))
|
||||
(invoke #$(file-append libfaketime "/bin/faketime")
|
||||
"2000-01-01 00:00:00"
|
||||
chromium
|
||||
"--user-data-dir=/tmp/signing-profile"
|
||||
(string-append "--pack-extension=" packdir)
|
||||
(string-append "--pack-extension-key=" #$signing-key))
|
||||
(copy-file (string-append packdir ".crx") #$output))))
|
||||
#:local-build? #t))
|
||||
(copy-file (string-append packdir ".crx") #$output)))
|
||||
#:local-build? #t)))
|
||||
|
||||
(define (crx->chromium-json crx version)
|
||||
(define* (crx->chromium-json crx version)
|
||||
"Return a derivation that creates a Chromium JSON settings file for the
|
||||
extension given as CRX. VERSION is used to signify the CRX version, and
|
||||
must match the version listed in the extension manifest.json."
|
||||
@@ -119,47 +127,66 @@ format."
|
||||
"--outder")
|
||||
#:local-build? #t))
|
||||
|
||||
(define (file-sha256sum file)
|
||||
(with-extensions (list guile-gcrypt)
|
||||
#~(begin
|
||||
(use-modules (gcrypt base16) (gcrypt hash))
|
||||
(bytevector->base16-string (file-sha256 #$file)))))
|
||||
(define (chromium-json->profile-object json signing-key)
|
||||
"Return a derivation that installs JSON to the directory searched by
|
||||
Chromium, using a file name (aka extension ID) derived from SIGNING-KEY."
|
||||
(define der (signing-key->public-der signing-key))
|
||||
|
||||
(define* (make-chromium-extension pkg #:optional (pkg-output "out"))
|
||||
"Create a Chromium extension from package PKG and return a package that,
|
||||
when installed, will make the extension contained in PKG available as a
|
||||
Chromium browser extension. PKG-OUTPUT specifies which output of PKG to use."
|
||||
(let* ((name (package-name pkg))
|
||||
(version (package-version pkg))
|
||||
(private-key (make-signing-key name))
|
||||
(public-key (signing-key->public-der private-key))
|
||||
(checksum (file-sha256sum public-key))
|
||||
(crx (make-crx private-key pkg pkg-output))
|
||||
(json (crx->chromium-json crx version)))
|
||||
(with-extensions (list guile-gcrypt)
|
||||
(with-imported-modules '((guix build utils))
|
||||
(computed-file
|
||||
"chromium-extension"
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(gcrypt base16)
|
||||
(gcrypt hash))
|
||||
(define (base16-string->chromium-base16 str)
|
||||
;; Translate STR, a hexadecimal string, to a Chromium-style
|
||||
;; representation using the letters a-p (where a=0, p=15).
|
||||
(define s1 "0123456789abcdef")
|
||||
(define s2 "abcdefghijklmnop")
|
||||
(let loop ((chars (string->list str))
|
||||
(converted '()))
|
||||
(if (null? chars)
|
||||
(list->string (reverse converted))
|
||||
(loop (cdr chars)
|
||||
(cons (string-ref s2 (string-index s1 (car chars)))
|
||||
converted)))))
|
||||
|
||||
(let* ((checksum (bytevector->base16-string (file-sha256 #$der)))
|
||||
(file-name (base16-string->chromium-base16
|
||||
(string-take checksum 32)))
|
||||
(extension-directory (string-append #$output
|
||||
"/share/chromium/extensions")))
|
||||
(mkdir-p extension-directory)
|
||||
(symlink #$json (string-append extension-directory "/"
|
||||
file-name ".json"))))
|
||||
#:local-build? #t))))
|
||||
|
||||
(define* (make-chromium-extension p #:optional (output "out"))
|
||||
"Create a Chromium extension from package P and return a package that,
|
||||
when installed, will make the extension contained in P available as a
|
||||
Chromium browser extension. OUTPUT specifies which output of P to use."
|
||||
(let* ((pname (package-name p))
|
||||
(version (package-version p))
|
||||
(signing-key (make-signing-key pname)))
|
||||
(package
|
||||
(inherit pkg)
|
||||
(name (string-append name "-chromium"))
|
||||
(inherit p)
|
||||
(name (string-append pname "-chromium"))
|
||||
(source #f)
|
||||
(build-system trivial-build-system)
|
||||
(native-inputs '())
|
||||
(inputs '())
|
||||
(inputs
|
||||
`(("extension" ,(chromium-json->profile-object
|
||||
(crx->chromium-json (make-crx signing-key p output)
|
||||
version)
|
||||
signing-key))))
|
||||
(propagated-inputs '())
|
||||
(outputs '("out"))
|
||||
(build-system trivial-build-system)
|
||||
(arguments
|
||||
(list #:modules '((guix build utils))
|
||||
#:builder
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
(define (base16-char->chromium-base16 char)
|
||||
;; Translate CHAR, a hexadecimal character, to a Chromium-style
|
||||
;; representation using the letters a-p (where a=0, p=15).
|
||||
(string-ref "abcdefghijklmnop"
|
||||
(string-index "0123456789abcdef" char)))
|
||||
(let ((file-name (string-map base16-char->chromium-base16
|
||||
(string-take #$checksum 32)))
|
||||
(extension-directory
|
||||
(string-append #$output
|
||||
"/share/chromium/extensions")))
|
||||
(mkdir-p extension-directory)
|
||||
(symlink #$json (string-append extension-directory "/"
|
||||
file-name ".json")))))))))
|
||||
'(#:modules ((guix build utils))
|
||||
#:builder
|
||||
(begin
|
||||
(use-modules (guix build utils))
|
||||
(copy-recursively (assoc-ref %build-inputs "extension")
|
||||
(assoc-ref %outputs "out"))))))))
|
||||
|
||||
@@ -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:
|
||||
+87
-332
@@ -1,9 +1,9 @@
|
||||
;;; 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>
|
||||
;;;
|
||||
@@ -29,8 +29,6 @@
|
||||
#:use-module (guix build bournish)
|
||||
#:use-module ((guix build syscalls)
|
||||
#:hide (file-system-type))
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 match)
|
||||
@@ -52,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:
|
||||
;;;
|
||||
@@ -70,33 +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 (bind-mount source target)
|
||||
"Bind-mount SOURCE at TARGET."
|
||||
(mount source target "" MS_BIND))
|
||||
@@ -195,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.
|
||||
@@ -283,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))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
@@ -334,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)
|
||||
@@ -351,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))))
|
||||
@@ -403,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)))
|
||||
|
||||
|
||||
;;;
|
||||
@@ -453,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)))
|
||||
@@ -493,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))
|
||||
@@ -554,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))
|
||||
@@ -586,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)
|
||||
@@ -656,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)))
|
||||
|
||||
@@ -755,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.
|
||||
@@ -923,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
|
||||
@@ -947,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))
|
||||
@@ -1043,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)
|
||||
@@ -1060,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)))
|
||||
@@ -1126,11 +885,7 @@ corresponds to the symbols listed in FLAGS."
|
||||
(()
|
||||
0))))
|
||||
|
||||
(define* (mount-file-system fs #:key (root "/root")
|
||||
(check? (file-system-check? fs))
|
||||
(skip-check-if-clean?
|
||||
(file-system-skip-check-if-clean? fs))
|
||||
(repair (file-system-repair fs)))
|
||||
(define* (mount-file-system fs #:key (root "/root"))
|
||||
"Mount the file system described by FS, a <file-system> object, under ROOT."
|
||||
|
||||
(define (mount-nfs source mount-point type flags options)
|
||||
@@ -1168,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 ()
|
||||
|
||||
+14
-10
@@ -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))
|
||||
|
||||
+26
-70
@@ -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
|
||||
@@ -83,7 +76,6 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
|
||||
(fs-options (partition-file-system-options partition))
|
||||
(label (partition-label partition))
|
||||
(uuid (partition-uuid partition))
|
||||
(flags (partition-flags partition))
|
||||
(journal-options "lazy_itable_init=1,lazy_journal_init=1"))
|
||||
(apply invoke
|
||||
`("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
|
||||
@@ -98,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
|
||||
@@ -125,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
|
||||
@@ -172,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)
|
||||
@@ -200,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,331 +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 USERNAME, the registered username associated with ACCOUNT, else its
|
||||
public key fingerprint."
|
||||
(or (assoc-ref account "Account.registeredName")
|
||||
(assoc-ref account "Account.username")))
|
||||
|
||||
(define (id->username id)
|
||||
"Return USERNAME, the registered username associated with ID, else its
|
||||
public key fingerprint, else #f."
|
||||
(account->username (id->account id)))
|
||||
|
||||
(define (get-accounts)
|
||||
"Return the list of all accounts, as a list of alists."
|
||||
(map id->account (get-account-ids)))
|
||||
|
||||
(define (get-usernames)
|
||||
"Return the list of the usernames associated with the present accounts."
|
||||
(map account->username (get-accounts)))
|
||||
|
||||
(define (username->account username)
|
||||
"Return the first account associated with USERNAME, else #f.
|
||||
USERNAME can be either the account 40 characters public key fingerprint or a
|
||||
registered username."
|
||||
(find (lambda (account)
|
||||
(member username
|
||||
(list (assoc-ref account "Account.username")
|
||||
(assoc-ref account "Account.registeredName"))))
|
||||
(get-accounts)))
|
||||
|
||||
(define (add-account archive)
|
||||
"Import the Jami account ARCHIVE and return its account ID. The archive
|
||||
should *not* be encrypted with a password. Return the username associated
|
||||
with the account."
|
||||
(invalidate-username-to-id-cache!)
|
||||
(let ((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"))
|
||||
+57
-105
@@ -1,9 +1,8 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2016, 2017, 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||
;;; Copyright © 2016, 2017, 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
|
||||
;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -26,7 +25,6 @@
|
||||
#:autoload (system repl repl) (start-repl)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
@@ -46,6 +44,7 @@
|
||||
make-static-device-nodes
|
||||
configure-qemu-networking
|
||||
|
||||
device-number
|
||||
boot-system))
|
||||
|
||||
;;; Commentary:
|
||||
@@ -94,7 +93,7 @@
|
||||
get-string-all)))
|
||||
|
||||
(define (find-long-option option arguments)
|
||||
"Find OPTION among ARGUMENTS, where OPTION is something like \"gnu.load\".
|
||||
"Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
|
||||
Return the value associated with OPTION, or #f on failure."
|
||||
(let ((opt (string-append option "=")))
|
||||
(and=> (find (cut string-prefix? opt <>)
|
||||
@@ -135,9 +134,14 @@ succeeds. Return nothing otherwise. The kernel logs any details to dmesg."
|
||||
;; is found on the command line; our canonicalize-device-spec gives
|
||||
;; up after 20 seconds. We could emulate the former by looping…
|
||||
(device (canonicalize-device-spec spec))
|
||||
(rdev (stat:rdev (stat device))))
|
||||
(let-values (((major minor) (device-number->major+minor rdev)))
|
||||
(format #f "~a:~a" major minor))))
|
||||
(rdev (stat:rdev (stat device)))
|
||||
;; For backwards compatibility, device numbering is a baroque affair.
|
||||
;; This is the full 64-bit scheme used by glibc's <sys/sysmacros.h>.
|
||||
(major (logior (ash (logand #x00000000000fff00 rdev) -8)
|
||||
(ash (logand #xfffff00000000000 rdev) -32)))
|
||||
(minor (logior (logand #x00000000000000ff rdev)
|
||||
(ash (logand #x00000ffffff00000 rdev) -12))))
|
||||
(format #f "~a:~a" major minor)))
|
||||
|
||||
;; Write the resume DEVICE to this magic file, using the MAJOR:MINOR device
|
||||
;; numbers if possible. The kernel will immediately try to resume from it.
|
||||
@@ -386,8 +390,17 @@ networking values.) Return #t if INTERFACE is up, #f otherwise."
|
||||
(set-network-interface-address sock interface address)
|
||||
(set-network-interface-flags sock interface (logior flags IFF_UP))
|
||||
|
||||
;; Hello! We used to create /etc/resolv.conf here, with "nameserver
|
||||
;; 10.0.2.3\n". However, with Linux-libre 3.16, we're getting ENOSPC.
|
||||
;; And since it's actually unnecessary, it's gone.
|
||||
|
||||
(logand (network-interface-flags sock interface) IFF_UP)))
|
||||
|
||||
(define (device-number major minor)
|
||||
"Return the device number for the device with MAJOR and MINOR, for use as
|
||||
the last argument of `mknod'."
|
||||
(+ (* major 256) minor))
|
||||
|
||||
(define (pidof program)
|
||||
"Return the PID of the first presumed instance of PROGRAM."
|
||||
(let ((program (basename program)))
|
||||
@@ -398,18 +411,11 @@ networking values.) Return #t if INTERFACE is up, #f otherwise."
|
||||
(filter-map string->number (scandir "/proc")))))
|
||||
|
||||
(define* (mount-root-file-system root type
|
||||
#:key volatile-root? (flags 0) options
|
||||
check? skip-check-if-clean? repair)
|
||||
#:key volatile-root? (flags 0) options)
|
||||
"Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is
|
||||
true, mount ROOT read-only and make it an overlay with a writable tmpfs using
|
||||
the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use
|
||||
to mount ROOT, and behave the same as for the `mount' procedure.
|
||||
|
||||
If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively.
|
||||
If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is
|
||||
marked as clean. If REPAIR is true, fsck may write to ROOT to perform repairs.
|
||||
If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it
|
||||
considers safe."
|
||||
to mount ROOT, and behave the same as for the `mount' procedure."
|
||||
|
||||
(if volatile-root?
|
||||
(begin
|
||||
@@ -430,8 +436,7 @@ considers safe."
|
||||
(mount "none" "/root" "overlay" 0
|
||||
"lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
|
||||
(begin
|
||||
(when check?
|
||||
(check-file-system root type (not skip-check-if-clean?) repair))
|
||||
(check-file-system root type)
|
||||
(mount root "/root" type flags options)))
|
||||
|
||||
;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
|
||||
@@ -500,12 +505,10 @@ LINUX-MODULE-DIRECTORY, then installing KEYMAP-FILE with 'loadkeys' (if
|
||||
KEYMAP-FILE is true), then setting up QEMU guest networking if
|
||||
QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
|
||||
specified in MOUNTS, and finally booting into the new root if any. The initrd
|
||||
supports the kernel command-line options 'gnu.load' and 'gnu.repl'. It also
|
||||
honors a subset of the Linux kernel command-line parameters such as
|
||||
'fsck.mode', 'resume', 'rootdelay', rootflags and rootfstype.
|
||||
supports kernel command-line options '--load', '--root', and '--repl'.
|
||||
|
||||
Mount the root file system, specified by the 'root' command-line argument, if
|
||||
any.
|
||||
Mount the root file system, specified by the '--root' command-line argument,
|
||||
if any.
|
||||
|
||||
MOUNTS must be a list of <file-system> objects.
|
||||
|
||||
@@ -518,71 +521,39 @@ upon error."
|
||||
(string=? (file-system-mount-point fs) "/"))
|
||||
|
||||
(define (device-string->file-system-device device-string)
|
||||
;; The "root=SPEC" kernel command-line option always provides a string,
|
||||
;; but the string can represent a device, an nfs-root, a UUID, or a label.
|
||||
;; So check for all four.
|
||||
;; The "--root=SPEC" kernel command-line option always provides a
|
||||
;; string, but the string can represent a device, an nfs-root, a UUID, or a
|
||||
;; label. So check for all four.
|
||||
(cond ((string-prefix? "/" device-string) device-string)
|
||||
((string-contains device-string ":/") device-string) ; nfs-root
|
||||
((uuid device-string) => identity)
|
||||
(else (file-system-label device-string))))
|
||||
|
||||
(display "Welcome, this is GNU's early boot Guile.\n")
|
||||
(display "Use 'gnu.repl' for an initrd REPL.\n\n")
|
||||
(display "Use '--repl' for an initrd REPL.\n\n")
|
||||
|
||||
(call-with-error-handling
|
||||
(lambda ()
|
||||
(mount-essential-file-systems)
|
||||
(let* ((args (linux-command-line))
|
||||
(to-load (find-long-option "gnu.load" args))
|
||||
;; If present, ‘root’ on the kernel command line takes precedence
|
||||
;; over the ‘device’ field of the root <file-system> record.
|
||||
(root-device (and=> (find-long-option "root" args)
|
||||
device-string->file-system-device))
|
||||
(rootfstype (find-long-option "rootfstype" args))
|
||||
(rootflags (find-long-option "rootflags" args))
|
||||
(root-fs* (find root-mount-point? mounts))
|
||||
(fsck.mode (find-long-option "fsck.mode" args)))
|
||||
(to-load (find-long-option "--load" args))
|
||||
(root-fs (find root-mount-point? mounts))
|
||||
(root-fs-type (or (and=> root-fs file-system-type)
|
||||
"ext4"))
|
||||
(root-fs-device (and=> root-fs file-system-device))
|
||||
(root-fs-flags (mount-flags->bit-mask
|
||||
(or (and=> root-fs file-system-flags)
|
||||
'())))
|
||||
(root-options (if root-fs
|
||||
(file-system-options root-fs)
|
||||
#f))
|
||||
;; --root takes precedence over the 'device' field of the root
|
||||
;; <file-system> record.
|
||||
(root-device (or (and=> (find-long-option "--root" args)
|
||||
device-string->file-system-device)
|
||||
root-fs-device)))
|
||||
|
||||
(unless (or root-fs* (and root-device rootfstype))
|
||||
(error "no root file system or 'root' and 'rootfstype' parameters"))
|
||||
|
||||
;; If present, ‘root’ on the kernel command line takes precedence over
|
||||
;; the ‘device’ field of the root <file-system> record; likewise for
|
||||
;; the 'rootfstype' and 'rootflags' arguments.
|
||||
(define root-fs
|
||||
(if root-fs*
|
||||
(file-system
|
||||
(inherit root-fs*)
|
||||
(device (or root-device (file-system-device root-fs*)))
|
||||
(type (or rootfstype (file-system-type root-fs*)))
|
||||
(options (or rootflags (file-system-options root-fs*))))
|
||||
(file-system
|
||||
(device root-device)
|
||||
(mount-point "/")
|
||||
(type rootfstype)
|
||||
(options rootflags))))
|
||||
|
||||
(define (check? fs)
|
||||
(match fsck.mode
|
||||
("skip" #f)
|
||||
("force" #t)
|
||||
(_ (file-system-check? fs)))) ; assume "auto"
|
||||
|
||||
(define (skip-check-if-clean? fs)
|
||||
(match fsck.mode
|
||||
("force" #f)
|
||||
(_ (file-system-skip-check-if-clean? fs))))
|
||||
|
||||
(define (repair fs)
|
||||
(let ((arg (find-long-option "fsck.repair" args)))
|
||||
(if arg
|
||||
(match arg
|
||||
("no" #f)
|
||||
("yes" #t)
|
||||
(_ 'preen))
|
||||
(file-system-repair fs))))
|
||||
|
||||
(when (member "gnu.repl" args)
|
||||
(when (member "--repl" args)
|
||||
(start-repl))
|
||||
|
||||
(display "loading kernel modules...\n")
|
||||
@@ -611,15 +582,6 @@ upon error."
|
||||
(unless (configure-qemu-networking)
|
||||
(display "network interface is DOWN\n")))
|
||||
|
||||
;; A big ugly hammer, to be used only for debugging and in desperate
|
||||
;; situations where no proper device synchonisation is possible.
|
||||
(let ((root-delay (and=> (find-long-option "rootdelay" args)
|
||||
string->number)))
|
||||
(when root-delay
|
||||
(format #t "Pausing for rootdelay=~a seconds before mounting \
|
||||
the root file system...\n" root-delay)
|
||||
(sleep root-delay)))
|
||||
|
||||
;; Prepare the real root file system under /root.
|
||||
(unless (file-exists? "/root")
|
||||
(mkdir "/root"))
|
||||
@@ -633,26 +595,16 @@ the root file system...\n" root-delay)
|
||||
|
||||
(setenv "EXT2FS_NO_MTAB_OK" "1")
|
||||
|
||||
;; Mount the root file system.
|
||||
(mount-root-file-system (canonicalize-device-spec
|
||||
(file-system-device root-fs))
|
||||
(file-system-type root-fs)
|
||||
#:volatile-root? volatile-root?
|
||||
#:flags (mount-flags->bit-mask
|
||||
(file-system-flags root-fs))
|
||||
#:options (file-system-options root-fs)
|
||||
#:check? (check? root-fs)
|
||||
#:skip-check-if-clean?
|
||||
(skip-check-if-clean? root-fs)
|
||||
#:repair (repair root-fs))
|
||||
(if root-device
|
||||
(mount-root-file-system (canonicalize-device-spec root-device)
|
||||
root-fs-type
|
||||
#:volatile-root? volatile-root?
|
||||
#:flags root-fs-flags
|
||||
#:options root-options)
|
||||
(mount "none" "/root" "tmpfs"))
|
||||
|
||||
;; Mount the specified non-root file systems.
|
||||
(for-each (lambda (fs)
|
||||
(mount-file-system fs
|
||||
#:check? (check? fs)
|
||||
#:skip-check-if-clean?
|
||||
(skip-check-if-clean? fs)
|
||||
#:repair (repair fs)))
|
||||
;; Mount the specified file systems.
|
||||
(for-each mount-file-system
|
||||
(remove root-mount-point? mounts))
|
||||
|
||||
(setenv "EXT2FS_NO_MTAB_OK" #f)
|
||||
@@ -670,7 +622,7 @@ the root file system...\n" root-delay)
|
||||
(sleep 2)
|
||||
(reboot))
|
||||
(begin
|
||||
(display "no boot file passed via 'gnu.load'\n")
|
||||
(display "no boot file passed via '--load'\n")
|
||||
(display "entering a warm and cozy REPL\n")
|
||||
(start-repl)))))
|
||||
#:on-error on-error))
|
||||
|
||||
@@ -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)
|
||||
@@ -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))))))
|
||||
|
||||
@@ -354,13 +354,11 @@ appears in BLACK-LIST are not loaded."
|
||||
(close-fdes fd)
|
||||
#t)
|
||||
(lambda args
|
||||
;; If this module was already loaded and we're in modprobe style, ignore
|
||||
;; the error.
|
||||
(when fd (close-fdes fd))
|
||||
(let ((errno (system-error-errno args)))
|
||||
(or (and recursive? ; we're operating in ‘modprobe’ style
|
||||
(member errno
|
||||
(list EEXIST ; already loaded
|
||||
EINVAL))) ; unsupported by hardware
|
||||
(apply throw args))))))))
|
||||
(or (and recursive? (= EEXIST (system-error-errno args)))
|
||||
(apply throw args)))))))
|
||||
|
||||
(define (load-linux-modules-from-directory modules directory)
|
||||
"Load MODULES and their dependencies from DIRECTORY, a directory containing
|
||||
|
||||
+20
-107
@@ -1,5 +1,5 @@
|
||||
;;; 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>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
@@ -20,11 +20,9 @@
|
||||
(define-module (gnu build marionette)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 regex)
|
||||
#:export (marionette?
|
||||
make-marionette
|
||||
marionette-eval
|
||||
@@ -35,10 +33,7 @@
|
||||
marionette-screen-text
|
||||
wait-for-screen-text
|
||||
%qwerty-us-keystrokes
|
||||
marionette-type
|
||||
|
||||
system-test-runner
|
||||
qemu-command))
|
||||
marionette-type))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
@@ -196,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))
|
||||
@@ -370,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))
|
||||
@@ -120,10 +74,7 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return
|
||||
|
||||
(log "sending secrets to ~a~%" port)
|
||||
(let ((sock (socket AF_INET 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)))
|
||||
(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.
|
||||
@@ -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
|
||||
|
||||
+38
-68
@@ -1,7 +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>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -25,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:
|
||||
@@ -100,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))
|
||||
@@ -121,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
|
||||
@@ -150,7 +123,6 @@ shepherd (PID 1)."
|
||||
(mappings '())
|
||||
(user #f)
|
||||
(group #f)
|
||||
(supplementary-groups '())
|
||||
(log-file #f)
|
||||
pid-file
|
||||
(pid-file-timeout 5)
|
||||
@@ -194,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
|
||||
@@ -231,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
|
||||
+55
-95
@@ -1,5 +1,5 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
|
||||
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
|
||||
@@ -28,7 +28,6 @@
|
||||
#:use-module (guix grafts)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module (guix packages)
|
||||
#:autoload (guix transformations) (tunable-package? tuned-package)
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix config)
|
||||
#:use-module (guix derivations)
|
||||
@@ -55,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)
|
||||
@@ -72,6 +70,7 @@
|
||||
image->job
|
||||
|
||||
%core-packages
|
||||
%cross-targets
|
||||
channel-source->package
|
||||
|
||||
arguments->systems
|
||||
@@ -86,7 +85,7 @@
|
||||
(define* (derivation->job name drv
|
||||
#:key
|
||||
(max-silent-time 3600)
|
||||
(timeout (* 5 3600)))
|
||||
(timeout 3600))
|
||||
"Return a Cuirass job called NAME and describing DRV.
|
||||
|
||||
MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
|
||||
@@ -108,9 +107,9 @@ building the derivation."
|
||||
(#:timeout . ,timeout)))
|
||||
|
||||
(define* (package-job store job-name package system
|
||||
#:key cross? target (suffix ""))
|
||||
#:key cross? target)
|
||||
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
|
||||
(let ((job-name (string-append job-name "." system suffix)))
|
||||
(let ((job-name (string-append job-name "." system)))
|
||||
(parameterize ((%graft? #f))
|
||||
(let* ((drv (if cross?
|
||||
(package-cross-derivation store package target system
|
||||
@@ -130,7 +129,7 @@ building the derivation."
|
||||
(define (package-cross-job store job-name package target system)
|
||||
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
|
||||
SYSTEM."
|
||||
(let ((name (string-append target "." job-name)))
|
||||
(let ((name (string-append target "." job-name "." system)))
|
||||
(package-job store name package system
|
||||
#:cross? #t
|
||||
#:target target)))
|
||||
@@ -139,9 +138,9 @@ SYSTEM."
|
||||
;; Note: Don't put the '-final' package variants because (1) that's
|
||||
;; implicit, and (2) they cannot be cross-built (due to the explicit input
|
||||
;; chain.)
|
||||
(list gcc-8 gcc-9 gcc-10 gcc-11 glibc binutils
|
||||
(list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
|
||||
gmp mpfr mpc coreutils findutils diffutils patch sed grep
|
||||
gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix
|
||||
gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
|
||||
%bootstrap-binaries-tarball
|
||||
%binutils-bootstrap-tarball
|
||||
(%glibc-bootstrap-tarball)
|
||||
@@ -149,19 +148,6 @@ SYSTEM."
|
||||
%guile-bootstrap-tarball
|
||||
%bootstrap-tarballs))
|
||||
|
||||
(define (commencement-packages system)
|
||||
"Return the list of bootstrap packages from the commencement module for
|
||||
SYSTEM."
|
||||
;; Only include packages supported on SYSTEM. For example, the Mes
|
||||
;; bootstrap graph is currently not supported on ARM so it should be
|
||||
;; excluded.
|
||||
(filter (lambda (obj)
|
||||
(and (package? obj)
|
||||
(supported-package? obj system)))
|
||||
(module-map (lambda (sym var)
|
||||
(variable-ref var))
|
||||
(resolve-module '(gnu packages commencement)))))
|
||||
|
||||
(define (packages-to-cross-build target)
|
||||
"Return the list of packages to cross-build for TARGET."
|
||||
;; Don't cross-build the bootstrap tarballs for MinGW.
|
||||
@@ -169,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)
|
||||
@@ -210,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."
|
||||
@@ -291,16 +288,20 @@ otherwise use the IMAGE name."
|
||||
|
||||
(define channel-build-system
|
||||
;; Build system used to "convert" a channel instance to a package.
|
||||
(let* ((build (lambda* (name inputs
|
||||
#:key source commit system
|
||||
#:allow-other-keys)
|
||||
(mlet* %store-monad ((source (if (string? source)
|
||||
(return source)
|
||||
(lower-object source)))
|
||||
(instance
|
||||
-> (checkout->channel-instance
|
||||
source #:commit commit)))
|
||||
(channel-instances->derivation (list instance)))))
|
||||
(let* ((build (lambda* (store name inputs
|
||||
#:key source commit system
|
||||
#:allow-other-keys)
|
||||
(run-with-store store
|
||||
;; SOURCE can be a lowerable object such as <local-file>
|
||||
;; or a file name. Adjust accordingly.
|
||||
(mlet* %store-monad ((source (if (string? source)
|
||||
(return source)
|
||||
(lower-object source)))
|
||||
(instance
|
||||
-> (checkout->channel-instance
|
||||
source #:commit commit)))
|
||||
(channel-instances->derivation (list instance)))
|
||||
#:system system)))
|
||||
(lower (lambda* (name #:key system source commit
|
||||
#:allow-other-keys)
|
||||
(bag
|
||||
@@ -385,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)
|
||||
@@ -451,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."
|
||||
@@ -535,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.
|
||||
@@ -552,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.
|
||||
@@ -603,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)))
|
||||
|
||||
-116
@@ -1,116 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu home services symlink-manager)
|
||||
#:use-module (gnu home services shells)
|
||||
#:use-module (gnu home services xdg)
|
||||
#:use-module (gnu home services fontutils)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix store)
|
||||
|
||||
#:export (home-environment
|
||||
home-environment?
|
||||
this-home-environment
|
||||
|
||||
home-environment-derivation
|
||||
home-environment-user-services
|
||||
home-environment-essential-services
|
||||
home-environment-services
|
||||
home-environment-location
|
||||
|
||||
home-environment-with-provenance))
|
||||
|
||||
;;; Comment:
|
||||
;;;
|
||||
;;; This module provides a <home-environment> record for managing
|
||||
;;; per-user packages and configuration files in the similar way as
|
||||
;;; <operating-system> do for system packages and configuration files.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-record-type* <home-environment> home-environment
|
||||
make-home-environment
|
||||
home-environment?
|
||||
this-home-environment
|
||||
|
||||
(packages home-environment-packages ; list of (PACKAGE OUTPUT...)
|
||||
(default '()))
|
||||
|
||||
(essential-services home-environment-essential-services ; list of services
|
||||
(thunked)
|
||||
(default (home-environment-default-essential-services
|
||||
this-home-environment)))
|
||||
|
||||
(services home-environment-user-services
|
||||
(default '()))
|
||||
|
||||
(location home-environment-location ; <location>
|
||||
(default (and=> (current-source-location)
|
||||
source-properties->location))
|
||||
(innate)))
|
||||
|
||||
(define (home-environment-default-essential-services he)
|
||||
"Return the list of essential services for home environment."
|
||||
(list
|
||||
(service home-run-on-first-login-service-type)
|
||||
(service home-activation-service-type)
|
||||
(service home-environment-variables-service-type)
|
||||
|
||||
(service home-symlink-manager-service-type)
|
||||
|
||||
(service home-fontconfig-service-type)
|
||||
(service home-xdg-base-directories-service-type)
|
||||
(service home-shell-profile-service-type)
|
||||
|
||||
(service home-service-type)
|
||||
(service home-profile-service-type (home-environment-packages he))))
|
||||
|
||||
(define* (home-environment-services he)
|
||||
"Return all the services of home environment."
|
||||
(instantiate-missing-services
|
||||
(append (home-environment-user-services he)
|
||||
(home-environment-essential-services he))))
|
||||
|
||||
(define* (home-environment-derivation he)
|
||||
"Return a derivation that builds OS."
|
||||
(let* ((services (home-environment-services he))
|
||||
(home (fold-services services
|
||||
#:target-type home-service-type)))
|
||||
(service-value home)))
|
||||
|
||||
(define* (home-environment-with-provenance he config-file)
|
||||
"Return a variant of HE that stores its own provenance information,
|
||||
including CONFIG-FILE, if available. This is achieved by adding an instance
|
||||
of HOME-PROVENANCE-SERVICE-TYPE to its services."
|
||||
(home-environment
|
||||
(inherit he)
|
||||
(services (cons (service home-provenance-service-type config-file)
|
||||
(home-environment-user-services he)))))
|
||||
|
||||
(define-gexp-compiler (home-environment-compiler (he <home-environment>)
|
||||
system target)
|
||||
((store-lift
|
||||
(lambda (store)
|
||||
(run-with-store store (home-environment-derivation he)
|
||||
#:system system
|
||||
#:target target)))))
|
||||
@@ -1,619 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services)
|
||||
#:use-module (gnu services)
|
||||
#:use-module ((gnu packages package-management) #:select (guix))
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module (guix sets)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (guix modules)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#: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
|
||||
|
||||
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-variables->setup-environment-script vars)
|
||||
"Return a file that can be sourced by a POSIX compliant shell which
|
||||
initializes the environment. The file will source the home
|
||||
environment profile, set some default environment variables, and set
|
||||
environment variables provided in @code{vars}. @code{vars} is a list
|
||||
of pairs (@code{(key . value)}), @code{key} is a string and
|
||||
@code{value} is a string or gexp.
|
||||
|
||||
If value is @code{#f} variable will be omitted.
|
||||
If value is @code{#t} variable will be just exported.
|
||||
For any other, value variable will be set to the @code{value} and
|
||||
exported."
|
||||
(define (warn-about-duplicate-defenitions)
|
||||
(fold
|
||||
(lambda (x acc)
|
||||
(when (equal? (car x) (car acc))
|
||||
(warning
|
||||
(G_ "duplicate definition for `~a' environment variable ~%") (car x)))
|
||||
x)
|
||||
(cons "" "")
|
||||
(sort vars (lambda (a b)
|
||||
(string<? (car a) (car b))))))
|
||||
|
||||
(warn-about-duplicate-defenitions)
|
||||
(with-monad
|
||||
%store-monad
|
||||
(return
|
||||
`(("setup-environment"
|
||||
;; TODO: It's necessary to source ~/.guix-profile too
|
||||
;; on foreign distros
|
||||
,(apply mixed-text-file "setup-environment"
|
||||
"\
|
||||
HOME_ENVIRONMENT=$HOME/.guix-home
|
||||
GUIX_PROFILE=\"$HOME_ENVIRONMENT/profile\"
|
||||
PROFILE_FILE=\"$HOME_ENVIRONMENT/profile/etc/profile\"
|
||||
[ -f $PROFILE_FILE ] && . $PROFILE_FILE
|
||||
|
||||
case $XDG_DATA_DIRS in
|
||||
*$HOME_ENVIRONMENT/profile/share*) ;;
|
||||
*) export XDG_DATA_DIRS=$HOME_ENVIRONMENT/profile/share:$XDG_DATA_DIRS ;;
|
||||
esac
|
||||
case $MANPATH in
|
||||
*$HOME_ENVIRONMENT/profile/share/man*) ;;
|
||||
*) export MANPATH=$HOME_ENVIRONMENT/profile/share/man:$MANPATH
|
||||
esac
|
||||
case $INFOPATH in
|
||||
*$HOME_ENVIRONMENT/profile/share/info*) ;;
|
||||
*) export INFOPATH=$HOME_ENVIRONMENT/profile/share/info:$INFOPATH ;;
|
||||
esac
|
||||
case $XDG_CONFIG_DIRS in
|
||||
*$HOME_ENVIRONMENT/profile/etc/xdg*) ;;
|
||||
*) export XDG_CONFIG_DIRS=$HOME_ENVIRONMENT/profile/etc/xdg:$XDG_CONFIG_DIRS ;;
|
||||
esac
|
||||
case $XCURSOR_PATH in
|
||||
*$HOME_ENVIRONMENT/profile/share/icons*) ;;
|
||||
*) export XCURSOR_PATH=$HOME_ENVIRONMENT/profile/share/icons:$XCURSOR_PATH ;;
|
||||
esac
|
||||
|
||||
"
|
||||
|
||||
(append-map
|
||||
(match-lambda
|
||||
((key . #f)
|
||||
'())
|
||||
((key . #t)
|
||||
(list "export " key "\n"))
|
||||
((key . value)
|
||||
(list "export " key "=" value "\n")))
|
||||
vars)))))))
|
||||
|
||||
(define home-environment-variables-service-type
|
||||
(service-type (name 'home-environment-variables)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-service-type
|
||||
environment-variables->setup-environment-script)))
|
||||
(compose concatenate)
|
||||
(extend append)
|
||||
(default-value '())
|
||||
(description "Set the environment variables.")))
|
||||
|
||||
(define (files->files-directory files)
|
||||
"Return a @code{files} directory that contains FILES."
|
||||
(define (assert-no-duplicates files)
|
||||
(let loop ((files files)
|
||||
(seen (set)))
|
||||
(match files
|
||||
(() #t)
|
||||
(((file _) rest ...)
|
||||
(when (set-contains? seen file)
|
||||
(raise (formatted-message (G_ "duplicate '~a' entry for files/")
|
||||
file)))
|
||||
(loop rest (set-insert file seen))))))
|
||||
|
||||
;; Detect duplicates early instead of letting them through, eventually
|
||||
;; leading to a build failure of "files.drv".
|
||||
(assert-no-duplicates files)
|
||||
|
||||
(file-union "files" files))
|
||||
|
||||
;; Used by symlink-manager
|
||||
(define home-files-directory "files")
|
||||
|
||||
(define (files-entry files)
|
||||
"Return an entry for the @file{~/.guix-home/files}
|
||||
directory containing FILES."
|
||||
(with-monad %store-monad
|
||||
(return `((,home-files-directory ,(files->files-directory files))))))
|
||||
|
||||
(define home-files-service-type
|
||||
(service-type (name 'home-files)
|
||||
(extensions
|
||||
(list (service-extension home-service-type
|
||||
files-entry)))
|
||||
(compose concatenate)
|
||||
(extend append)
|
||||
(default-value '())
|
||||
(description "Files that will be put in
|
||||
@file{~~/.guix-home/files}, and further processed during activation.")))
|
||||
|
||||
(define xdg-configuration-files-directory ".config")
|
||||
|
||||
(define (xdg-configuration-files files)
|
||||
"Add .config/ prefix to each file-path in FILES."
|
||||
(map (match-lambda
|
||||
((file-path . rest)
|
||||
(cons (string-append xdg-configuration-files-directory "/" file-path)
|
||||
rest)))
|
||||
files))
|
||||
|
||||
(define home-xdg-configuration-files-service-type
|
||||
(service-type (name 'home-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)))
|
||||
#~(begin
|
||||
(use-modules (guix i18n))
|
||||
#$%initialize-gettext
|
||||
|
||||
(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
|
||||
(format #f "/run/user/~a" (getuid))))
|
||||
(flag-file-path (string-append
|
||||
xdg-runtime-dir "/on-first-login-executed"))
|
||||
(touch (lambda (file-name)
|
||||
(call-with-output-file file-name (const #t)))))
|
||||
;; XDG_RUNTIME_DIR dissapears on logout, that means such trick
|
||||
;; allows to launch on-first-login script on first login only
|
||||
;; after complete logout/reboot.
|
||||
(if (file-exists? xdg-runtime-dir)
|
||||
(unless (file-exists? flag-file-path)
|
||||
(begin #$@gexps (touch flag-file-path)))
|
||||
;; TRANSLATORS: 'on-first-login' is the name of a service and
|
||||
;; shouldn't be translated
|
||||
(display (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
|
||||
won't execute anything. You can check if xdg runtime directory exists,
|
||||
XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the
|
||||
script by running '$HOME/.guix-home/on-first-login'"))))))))
|
||||
|
||||
(define (on-first-login-script-entry on-first-login)
|
||||
"Return, as a monadic value, an entry for the on-first-login script
|
||||
in the home environment directory."
|
||||
(with-monad %store-monad
|
||||
(return `(("on-first-login" ,on-first-login)))))
|
||||
|
||||
(define home-run-on-first-login-service-type
|
||||
(service-type (name 'home-run-on-first-login)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-service-type
|
||||
on-first-login-script-entry)))
|
||||
(compose identity)
|
||||
(extend compute-on-first-login-script)
|
||||
(default-value #f)
|
||||
(description "Run gexps on first user login. Can be
|
||||
extended with one gexp.")))
|
||||
|
||||
|
||||
(define (compute-activation-script init-gexp gexps)
|
||||
(gexp->script
|
||||
"activate"
|
||||
#~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment")))
|
||||
(he-path (string-append (getenv "HOME") "/.guix-home"))
|
||||
(new-home-env (getenv "GUIX_NEW_HOME"))
|
||||
(new-home (or new-home-env
|
||||
;; Path of the activation file if called interactively
|
||||
(dirname (car (command-line)))))
|
||||
(old-home-env (getenv "GUIX_OLD_HOME"))
|
||||
(old-home (or old-home-env
|
||||
(if (file-exists? (he-init-file he-path))
|
||||
(readlink he-path)
|
||||
#f))))
|
||||
(if (file-exists? (he-init-file new-home))
|
||||
(let* ((port ((@ (ice-9 popen) open-input-pipe)
|
||||
(format #f "source ~a && env -0"
|
||||
(he-init-file new-home))))
|
||||
(result ((@ (ice-9 rdelim) read-delimited) "" port))
|
||||
(vars (map (lambda (x)
|
||||
(let ((si (string-index x #\=)))
|
||||
(cons (string-take x si)
|
||||
(string-drop x (1+ si)))))
|
||||
((@ (srfi srfi-1) remove)
|
||||
string-null?
|
||||
(string-split result #\nul)))))
|
||||
(close-port port)
|
||||
(map (lambda (x) (setenv (car x) (cdr x))) vars)
|
||||
|
||||
(setenv "GUIX_NEW_HOME" new-home)
|
||||
(setenv "GUIX_OLD_HOME" old-home)
|
||||
|
||||
#$@gexps
|
||||
|
||||
;; Do not unset env variable if it was set outside.
|
||||
(unless new-home-env (setenv "GUIX_NEW_HOME" #f))
|
||||
(unless old-home-env (setenv "GUIX_OLD_HOME" #f)))
|
||||
(format #t "\
|
||||
Activation script was either called or loaded by file from this directory:
|
||||
~a
|
||||
It doesn't seem that home environment is somewhere around.
|
||||
Make sure that you call ./activate by symlink from -home store item.\n"
|
||||
new-home)))))
|
||||
|
||||
(define (activation-script-entry m-activation)
|
||||
"Return, as a monadic value, an entry for the activation script
|
||||
in the home environment directory."
|
||||
(mlet %store-monad ((activation m-activation))
|
||||
(return `(("activate" ,activation)))))
|
||||
|
||||
(define home-activation-service-type
|
||||
(service-type (name 'home-activation)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-service-type
|
||||
activation-script-entry)))
|
||||
(compose identity)
|
||||
(extend compute-activation-script)
|
||||
(default-value #f)
|
||||
(description "Run gexps to activate the current
|
||||
generation of home environment and update the state of the home
|
||||
directory. @command{activate} script automatically called during
|
||||
reconfiguration or generation switching. This service can be extended
|
||||
with one gexp, but many times, and all gexps must be idempotent.")))
|
||||
|
||||
|
||||
;;;
|
||||
;;; On-change.
|
||||
;;;
|
||||
|
||||
(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples)
|
||||
(with-imported-modules (source-module-closure '((guix i18n)))
|
||||
#~(begin
|
||||
(use-modules (guix i18n))
|
||||
|
||||
#$%initialize-gettext
|
||||
|
||||
(define (equal-regulars? file1 file2)
|
||||
"Check if FILE1 and FILE2 are bit for bit identical."
|
||||
(let* ((cmp-binary #$(file-append
|
||||
(@ (gnu packages base) diffutils) "/bin/cmp"))
|
||||
(stats1 (lstat file1))
|
||||
(stats2 (lstat file2)))
|
||||
(cond
|
||||
((= (stat:ino stats1) (stat:ino stats2)) #t)
|
||||
((not (= (stat:size stats1) (stat:size stats2))) #f)
|
||||
|
||||
(else (= (system* cmp-binary file1 file2) 0)))))
|
||||
|
||||
(define (equal-symlinks? symlink1 symlink2)
|
||||
"Check if SYMLINK1 and SYMLINK2 are pointing to the same target."
|
||||
(string=? (readlink symlink1) (readlink symlink2)))
|
||||
|
||||
(define (equal-directories? dir1 dir2)
|
||||
"Check if DIR1 and DIR2 have the same content."
|
||||
(define (ordinary-file file)
|
||||
(not (or (string=? file ".")
|
||||
(string=? file ".."))))
|
||||
(let* ((files1 (scandir dir1 ordinary-file))
|
||||
(files2 (scandir dir2 ordinary-file)))
|
||||
(if (equal? files1 files2)
|
||||
(map (lambda (file)
|
||||
(equal-files?
|
||||
(string-append dir1 "/" file)
|
||||
(string-append dir2 "/" file)))
|
||||
files1)
|
||||
#f)))
|
||||
|
||||
(define (equal-files? file1 file2)
|
||||
"Compares files, symlinks or directories of the same type."
|
||||
(case (file-type file1)
|
||||
((directory) (equal-directories? file1 file2))
|
||||
((symlink) (equal-symlinks? file1 file2))
|
||||
((regular) (equal-regulars? file1 file2))
|
||||
(else
|
||||
(display "The file type is unsupported by on-change service.\n")
|
||||
#f)))
|
||||
|
||||
(define (file-type file)
|
||||
(stat:type (lstat file)))
|
||||
|
||||
(define (something-changed? file1 file2)
|
||||
(cond
|
||||
((and (not (file-exists? file1))
|
||||
(not (file-exists? file2))) #f)
|
||||
((or (not (file-exists? file1))
|
||||
(not (file-exists? file2))) #t)
|
||||
|
||||
((not (eq? (file-type file1) (file-type file2))) #t)
|
||||
|
||||
(else
|
||||
(not (equal-files? file1 file2)))))
|
||||
|
||||
(define expressions-to-eval
|
||||
(map
|
||||
(lambda (x)
|
||||
(let* ((file1 (string-append
|
||||
(or (getenv "GUIX_OLD_HOME")
|
||||
"/gnu/store/non-existing-generation")
|
||||
"/" (car x)))
|
||||
(file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x)))
|
||||
(_ (format #t (G_ "Comparing ~a and\n~10t~a...") file1 file2))
|
||||
(any-changes? (something-changed? file1 file2))
|
||||
(_ (format #t (G_ " done (~a)\n")
|
||||
(if any-changes? "changed" "same"))))
|
||||
(if any-changes? (cadr x) "")))
|
||||
'#$pattern-gexp-tuples))
|
||||
|
||||
(if #$eval-gexps?
|
||||
(begin
|
||||
;;; TRANSLATORS: 'on-change' is the name of a service type, it
|
||||
;;; probably shouldn't be translated.
|
||||
(display (G_ "Evaluating on-change gexps.\n\n"))
|
||||
(for-each primitive-eval expressions-to-eval)
|
||||
(display (G_ "On-change gexps evaluation finished.\n\n")))
|
||||
(display "\
|
||||
On-change gexps won't be evaluated; evaluation has been disabled in the
|
||||
service configuration")))))
|
||||
|
||||
(define home-run-on-change-service-type
|
||||
(service-type (name 'home-run-on-change)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-activation-service-type
|
||||
identity)))
|
||||
(compose concatenate)
|
||||
(extend compute-on-change-gexp)
|
||||
(default-value #t)
|
||||
(description "\
|
||||
G-expressions to run if the specified files have changed since the
|
||||
last generation. The extension should be a list of lists where the
|
||||
first element is the pattern for file or directory that expected to be
|
||||
changed, and the second element is the G-expression to be evaluated.")))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Provenance tracking.
|
||||
;;;
|
||||
|
||||
(define home-provenance-service-type
|
||||
(service-type
|
||||
(name 'home-provenance)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-service-type
|
||||
(service-extension-compute
|
||||
(first (service-type-extensions provenance-service-type))))))
|
||||
(default-value #f) ;the HE config file
|
||||
(description "\
|
||||
Store provenance information about the home environment in the home
|
||||
environment itself: the channels used when building the home
|
||||
environment, and its configuration file, when available.")))
|
||||
|
||||
(define sexp->home-provenance sexp->system-provenance)
|
||||
(define home-provenance system-provenance)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Searching
|
||||
;;;
|
||||
|
||||
(define (parent-directory directory)
|
||||
"Get the parent directory of DIRECTORY"
|
||||
(string-join (drop-right (string-split directory #\/) 1) "/"))
|
||||
|
||||
(define %guix-home-root-directory
|
||||
;; Absolute file name of the module hierarchy.
|
||||
(parent-directory
|
||||
(dirname (dirname (search-path %load-path "gnu/home/services.scm")))))
|
||||
|
||||
(define %service-type-path
|
||||
;; Search path for service types.
|
||||
(make-parameter `((,%guix-home-root-directory . "gnu/home/services"))))
|
||||
|
||||
(define (all-home-service-modules)
|
||||
"Return the default set of `home service' modules."
|
||||
(cons (resolve-interface '(gnu home services))
|
||||
(all-modules (%service-type-path)
|
||||
#:warn warn-about-load-error)))
|
||||
|
||||
(define* (fold-home-service-types proc seed)
|
||||
(fold-service-types proc seed (all-home-service-modules)))
|
||||
|
||||
(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,174 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services desktop)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu home services shepherd)
|
||||
#:use-module (gnu services configuration)
|
||||
#:autoload (gnu packages xdisorg) (redshift)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (home-redshift-configuration
|
||||
home-redshift-configuration?
|
||||
|
||||
home-redshift-service-type))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Redshift.
|
||||
;;;
|
||||
|
||||
(define (serialize-integer field value)
|
||||
(string-append (match field
|
||||
('daytime-temperature "temp-day")
|
||||
('nighttime-temperature "temp-night")
|
||||
('daytime-brightness "brightness-day")
|
||||
('nighttime-brightness "brightness-night")
|
||||
('latitude "lat")
|
||||
('longitude "lon")
|
||||
(_ (symbol->string field)))
|
||||
"=" (number->string value) "\n"))
|
||||
|
||||
(define (serialize-symbol field value)
|
||||
(string-append (symbol->string field)
|
||||
"=" (symbol->string value) "\n"))
|
||||
|
||||
(define (serialize-string field value)
|
||||
(string-append (symbol->string field)
|
||||
"=" value "\n"))
|
||||
|
||||
(define serialize-inexact-number serialize-integer)
|
||||
|
||||
(define (inexact-number? n)
|
||||
(and (number? n) (inexact? n)))
|
||||
(define-maybe inexact-number)
|
||||
(define-maybe string)
|
||||
|
||||
(define (serialize-raw-configuration-string field value)
|
||||
value)
|
||||
(define raw-configuration-string? string?)
|
||||
|
||||
(define-configuration home-redshift-configuration
|
||||
(redshift
|
||||
(file-like redshift)
|
||||
"Redshift package to use.")
|
||||
|
||||
(location-provider
|
||||
(symbol 'geoclue2)
|
||||
"Geolocation provider---@code{'manual} or @code{'geoclue2}.
|
||||
|
||||
In the former case, you must also specify the @code{latitude} and
|
||||
@code{longitude} fields so Redshift can determine daytime at your place. In
|
||||
the latter case, the Geoclue system service must be running; it will be
|
||||
queried for location information.")
|
||||
(adjustment-method
|
||||
(symbol 'randr)
|
||||
"Color adjustment method.")
|
||||
|
||||
;; Default values from redshift(1).
|
||||
(daytime-temperature
|
||||
(integer 6500)
|
||||
"Daytime color temperature (kelvins).")
|
||||
(nighttime-temperature
|
||||
(integer 4500)
|
||||
"Nighttime color temperature (kelvins).")
|
||||
|
||||
(daytime-brightness
|
||||
maybe-inexact-number
|
||||
"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)))))
|
||||
|
||||
(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.")))
|
||||
@@ -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,115 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services mcron)
|
||||
#:use-module (gnu packages guile-xyz)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (gnu home services shepherd)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
|
||||
#:export (home-mcron-configuration
|
||||
home-mcron-service-type))
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Service for the GNU mcron cron job manager.
|
||||
;;
|
||||
;; Example configuration, the first job runs mbsync once every ten
|
||||
;; minutes, the second one writes "Mcron service" to ~/mcron-file once
|
||||
;; every minute.
|
||||
;;
|
||||
;; (service home-mcron-service-type
|
||||
;; (home-mcron-configuration
|
||||
;; (jobs (list #~(job '(next-minute
|
||||
;; (range 0 60 10))
|
||||
;; (lambda ()
|
||||
;; (system* "mbsync" "--all")))
|
||||
;; #~(job next-minute-from
|
||||
;; (lambda ()
|
||||
;; (call-with-output-file (string-append (getenv "HOME")
|
||||
;; "/mcron-file")
|
||||
;; (lambda (port)
|
||||
;; (display "Mcron service" port)))))))))
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(define-record-type* <home-mcron-configuration> home-mcron-configuration
|
||||
make-home-mcron-configuration
|
||||
home-mcron-configuration?
|
||||
(package home-mcron-configuration-package ; package
|
||||
(default mcron))
|
||||
(jobs home-mcron-configuration-jobs ; list of jobs
|
||||
(default '())))
|
||||
|
||||
(define job-files (@@ (gnu services mcron) job-files))
|
||||
(define shepherd-schedule-action
|
||||
(@@ (gnu services mcron) shepherd-schedule-action))
|
||||
|
||||
(define home-mcron-shepherd-services
|
||||
(match-lambda
|
||||
(($ <home-mcron-configuration> mcron '()) ; no jobs to run
|
||||
'())
|
||||
(($ <home-mcron-configuration> mcron jobs)
|
||||
(let ((files (job-files mcron jobs)))
|
||||
(list (shepherd-service
|
||||
(documentation "User cron jobs.")
|
||||
(provision '(mcron))
|
||||
(modules `((srfi srfi-1)
|
||||
(srfi srfi-26)
|
||||
(ice-9 popen) ; for the 'schedule' action
|
||||
(ice-9 rdelim)
|
||||
(ice-9 match)
|
||||
,@%default-modules))
|
||||
(start #~(make-forkexec-constructor
|
||||
(list #$(file-append mcron "/bin/mcron") #$@files)
|
||||
#:log-file (string-append
|
||||
(or (getenv "XDG_LOG_HOME")
|
||||
(format #f "~a/.local/var/log"
|
||||
(getenv "HOME")))
|
||||
"/mcron.log")))
|
||||
(stop #~(make-kill-destructor))
|
||||
(actions
|
||||
(list (shepherd-schedule-action mcron files)))))))))
|
||||
|
||||
(define home-mcron-profile (compose list home-mcron-configuration-package))
|
||||
|
||||
(define (home-mcron-extend config jobs)
|
||||
(home-mcron-configuration
|
||||
(inherit config)
|
||||
(jobs (append (home-mcron-configuration-jobs config)
|
||||
jobs))))
|
||||
|
||||
(define home-mcron-service-type
|
||||
(service-type (name 'home-mcron)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-shepherd-service-type
|
||||
home-mcron-shepherd-services)
|
||||
(service-extension
|
||||
home-profile-service-type
|
||||
home-mcron-profile)))
|
||||
(compose concatenate)
|
||||
(extend home-mcron-extend)
|
||||
(default-value (home-mcron-configuration))
|
||||
(description
|
||||
"Install and configure the GNU mcron cron job manager.")))
|
||||
@@ -1,699 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services shells)
|
||||
#:use-module (gnu services configuration)
|
||||
#:use-module (gnu home services utils)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu packages shells)
|
||||
#:use-module (gnu packages bash)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
|
||||
#:export (home-shell-profile-service-type
|
||||
home-shell-profile-configuration
|
||||
|
||||
home-bash-service-type
|
||||
home-bash-configuration
|
||||
home-bash-extension
|
||||
|
||||
home-zsh-service-type
|
||||
home-zsh-configuration
|
||||
home-zsh-extension
|
||||
|
||||
home-fish-service-type
|
||||
home-fish-configuration
|
||||
home-fish-extension))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module contains shell related services like Zsh.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
|
||||
;;;
|
||||
;;; Shell profile.
|
||||
;;;
|
||||
|
||||
(define path? string?)
|
||||
(define (serialize-path field-name val) val)
|
||||
|
||||
(define-configuration home-shell-profile-configuration
|
||||
(profile
|
||||
(text-config '())
|
||||
"\
|
||||
@code{home-shell-profile} is instantiated automatically by
|
||||
@code{home-environment}, DO NOT create this service manually, it can
|
||||
only be extended.
|
||||
|
||||
@code{profile} is a list of file-like objects, which will go to
|
||||
@file{~/.profile}. By default @file{~/.profile} contains the
|
||||
initialization code, which have to be evaluated by login shell to make
|
||||
home-environment's profile available to the user, but other commands
|
||||
can be added to the file if it is really necessary.
|
||||
|
||||
In most cases shell's configuration files are preferred places for
|
||||
user's customizations. Extend home-shell-profile service only if you
|
||||
really know what you do."))
|
||||
|
||||
(define (add-shell-profile-file config)
|
||||
`((".profile"
|
||||
,(mixed-text-file
|
||||
"shell-profile"
|
||||
"\
|
||||
HOME_ENVIRONMENT=$HOME/.guix-home
|
||||
. $HOME_ENVIRONMENT/setup-environment
|
||||
$HOME_ENVIRONMENT/on-first-login\n"
|
||||
(serialize-configuration
|
||||
config
|
||||
(filter-configuration-fields
|
||||
home-shell-profile-configuration-fields '(profile)))))))
|
||||
|
||||
(define (add-profile-extensions config extensions)
|
||||
(home-shell-profile-configuration
|
||||
(inherit config)
|
||||
(profile
|
||||
(append (home-shell-profile-configuration-profile config)
|
||||
extensions))))
|
||||
|
||||
(define home-shell-profile-service-type
|
||||
(service-type (name 'home-shell-profile)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-files-service-type
|
||||
add-shell-profile-file)))
|
||||
(compose concatenate)
|
||||
(extend add-profile-extensions)
|
||||
(default-value (home-shell-profile-configuration))
|
||||
(description "Create @file{~/.profile}, which is used
|
||||
for environment initialization of POSIX compliant login shells. This
|
||||
service type can be extended with a list of file-like objects.")))
|
||||
|
||||
(define (serialize-boolean field-name val) "")
|
||||
(define (serialize-posix-env-vars field-name val)
|
||||
#~(string-append
|
||||
#$@(map
|
||||
(match-lambda
|
||||
((key . #f)
|
||||
"")
|
||||
((key . #t)
|
||||
#~(string-append "export " #$key "\n"))
|
||||
((key . value)
|
||||
#~(string-append "export " #$key "=" #$value "\n")))
|
||||
val)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Zsh.
|
||||
;;;
|
||||
|
||||
(define-configuration home-zsh-configuration
|
||||
(package
|
||||
(package zsh)
|
||||
"The Zsh package to use.")
|
||||
(xdg-flavor?
|
||||
(boolean #t)
|
||||
"Place all the configs to @file{$XDG_CONFIG_HOME/zsh}. Makes
|
||||
@file{~/.zshenv} to set @env{ZDOTDIR} to @file{$XDG_CONFIG_HOME/zsh}.
|
||||
Shell startup process will continue with
|
||||
@file{$XDG_CONFIG_HOME/zsh/.zshenv}.")
|
||||
(environment-variables
|
||||
(alist '())
|
||||
"Association list of environment variables to set for the Zsh session."
|
||||
serialize-posix-env-vars)
|
||||
(zshenv
|
||||
(text-config '())
|
||||
"List of file-like objects, which will be added to @file{.zshenv}.
|
||||
Used for setting user's shell environment variables. Must not contain
|
||||
commands assuming the presence of tty or producing output. Will be
|
||||
read always. Will be read before any other file in @env{ZDOTDIR}.")
|
||||
(zprofile
|
||||
(text-config '())
|
||||
"List of file-like objects, which will be added to @file{.zprofile}.
|
||||
Used for executing user's commands at start of login shell (In most
|
||||
cases the shell started on tty just after login). Will be read before
|
||||
@file{.zlogin}.")
|
||||
(zshrc
|
||||
(text-config '())
|
||||
"List of file-like objects, which will be added to @file{.zshrc}.
|
||||
Used for executing user's commands at start of interactive shell (The
|
||||
shell for interactive usage started by typing @code{zsh} or by
|
||||
terminal app or any other program).")
|
||||
(zlogin
|
||||
(text-config '())
|
||||
"List of file-like objects, which will be added to @file{.zlogin}.
|
||||
Used for executing user's commands at the end of starting process of
|
||||
login shell.")
|
||||
(zlogout
|
||||
(text-config '())
|
||||
"List of file-like objects, which will be added to @file{.zlogout}.
|
||||
Used for executing user's commands at the exit of login shell. It
|
||||
won't be read in some cases (if the shell terminates by exec'ing
|
||||
another process for example)."))
|
||||
|
||||
(define (zsh-filter-fields field)
|
||||
(filter-configuration-fields home-zsh-configuration-fields (list field)))
|
||||
|
||||
(define (zsh-serialize-field config field)
|
||||
(serialize-configuration config (zsh-filter-fields field)))
|
||||
|
||||
(define* (zsh-field-not-empty? config field)
|
||||
(let ((file-name (symbol->string field))
|
||||
(field-obj (car (zsh-filter-fields field))))
|
||||
(not (null? ((configuration-field-getter field-obj) config)))))
|
||||
|
||||
(define (zsh-file-zshenv config)
|
||||
(mixed-text-file
|
||||
"zshenv"
|
||||
(zsh-serialize-field config 'zshenv)
|
||||
(zsh-serialize-field config 'environment-variables)))
|
||||
|
||||
(define (zsh-file-zprofile config)
|
||||
(mixed-text-file
|
||||
"zprofile"
|
||||
"\
|
||||
# Setups system and user profiles and related variables
|
||||
source /etc/profile
|
||||
# Setups home environment profile
|
||||
source ~/.profile
|
||||
|
||||
# It's only necessary if zsh is a login shell, otherwise profiles will
|
||||
# be already sourced by bash
|
||||
"
|
||||
(zsh-serialize-field config 'zprofile)))
|
||||
|
||||
(define (zsh-file-by-field config field)
|
||||
(match field
|
||||
('zshenv (zsh-file-zshenv config))
|
||||
('zprofile (zsh-file-zprofile config))
|
||||
(e (mixed-text-file
|
||||
(symbol->string field)
|
||||
(zsh-serialize-field config field)))))
|
||||
|
||||
(define (zsh-get-configuration-files config)
|
||||
`((".zprofile" ,(zsh-file-by-field config 'zprofile)) ;; Always non-empty
|
||||
,@(if (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"
|
||||
"\
|
||||
# Setups system and user profiles and related variables
|
||||
# /etc/profile will be sourced by bash automatically
|
||||
# Setups home environment profile
|
||||
if [ -f ~/.profile ]; then source ~/.profile; fi
|
||||
|
||||
# Honor per-interactive-shell startup file
|
||||
if [ -f ~/.bashrc ]; then source ~/.bashrc; fi
|
||||
"
|
||||
(serialize-field 'bash-profile)
|
||||
(serialize-field 'environment-variables)))
|
||||
|
||||
,@(list (file-if-not-empty
|
||||
'bashrc
|
||||
(if (home-bash-configuration-guix-defaults? config)
|
||||
(list (serialize-field 'aliases) guix-bashrc)
|
||||
(list (serialize-field 'aliases))))
|
||||
(file-if-not-empty 'bash-logout)))))
|
||||
|
||||
(define (add-bash-packages config)
|
||||
(list (home-bash-configuration-package config)))
|
||||
|
||||
(define-configuration/no-serialization home-bash-extension
|
||||
(environment-variables
|
||||
(alist '())
|
||||
"Additional environment variables to set. These will be combined with the
|
||||
environment variables from other extensions and the base service to form one
|
||||
coherent block of environment variables.")
|
||||
(aliases
|
||||
(alist '())
|
||||
"Additional aliases to set. These will be combined with the aliases from
|
||||
other extensions and the base service.")
|
||||
(bash-profile
|
||||
(text-config '())
|
||||
"Additional text blocks to add to @file{.bash_profile}, which will be combined
|
||||
with text blocks from other extensions and the base service.")
|
||||
(bashrc
|
||||
(text-config '())
|
||||
"Additional text blocks to add to @file{.bashrc}, which will be combined
|
||||
with text blocks from other extensions and the base service.")
|
||||
(bash-logout
|
||||
(text-config '())
|
||||
"Additional text blocks to add to @file{.bash_logout}, which will be combined
|
||||
with text blocks from other extensions and the base service."))
|
||||
|
||||
(define (home-bash-extensions original-config extension-configs)
|
||||
(match original-config
|
||||
(($ <home-bash-configuration> _ _ _ environment-variables aliases
|
||||
bash-profile bashrc bash-logout)
|
||||
(home-bash-configuration
|
||||
(inherit original-config)
|
||||
(environment-variables
|
||||
(append environment-variables
|
||||
(append-map
|
||||
home-bash-extension-environment-variables extension-configs)))
|
||||
(aliases
|
||||
(append aliases
|
||||
(append-map
|
||||
home-bash-extension-aliases extension-configs)))
|
||||
(bash-profile
|
||||
(append bash-profile
|
||||
(append-map
|
||||
home-bash-extension-bash-profile extension-configs)))
|
||||
(bashrc
|
||||
(append bashrc
|
||||
(append-map
|
||||
home-bash-extension-bashrc extension-configs)))
|
||||
(bash-logout
|
||||
(append bash-logout
|
||||
(append-map
|
||||
home-bash-extension-bash-logout extension-configs)))))))
|
||||
|
||||
(define home-bash-service-type
|
||||
(service-type (name 'home-bash)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-files-service-type
|
||||
add-bash-configuration)
|
||||
(service-extension
|
||||
home-profile-service-type
|
||||
add-bash-packages)))
|
||||
(compose identity)
|
||||
(extend home-bash-extensions)
|
||||
(default-value (home-bash-configuration))
|
||||
(description "Install and configure GNU Bash.")))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Fish.
|
||||
;;;
|
||||
|
||||
(define (serialize-fish-aliases field-name val)
|
||||
#~(string-append
|
||||
#$@(map (match-lambda
|
||||
((key . value)
|
||||
#~(string-append "alias " #$key " \"" #$value "\"\n"))
|
||||
(_ ""))
|
||||
val)))
|
||||
|
||||
(define (serialize-fish-abbreviations field-name val)
|
||||
#~(string-append
|
||||
#$@(map (match-lambda
|
||||
((key . value)
|
||||
#~(string-append "abbr --add " #$key " " #$value "\n"))
|
||||
(_ ""))
|
||||
val)))
|
||||
|
||||
(define (serialize-fish-env-vars field-name val)
|
||||
#~(string-append
|
||||
#$@(map (match-lambda
|
||||
((key . #f)
|
||||
"")
|
||||
((key . #t)
|
||||
#~(string-append "set -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,157 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services shepherd)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu packages admin)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (guix sets)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix records)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (home-shepherd-service-type
|
||||
|
||||
home-shepherd-configuration
|
||||
home-shepherd-configuration?
|
||||
home-shepherd-configuration-shepherd
|
||||
home-shepherd-configuration-auto-start?
|
||||
home-shepherd-configuration-services)
|
||||
#:re-export (shepherd-service
|
||||
shepherd-service?
|
||||
shepherd-service-documentation
|
||||
shepherd-service-provision
|
||||
shepherd-service-canonical-name
|
||||
shepherd-service-requirement
|
||||
shepherd-service-one-shot?
|
||||
shepherd-service-respawn?
|
||||
shepherd-service-start
|
||||
shepherd-service-stop
|
||||
shepherd-service-auto-start?
|
||||
shepherd-service-modules
|
||||
|
||||
shepherd-action))
|
||||
|
||||
(define-record-type* <home-shepherd-configuration>
|
||||
home-shepherd-configuration make-home-shepherd-configuration
|
||||
home-shepherd-configuration?
|
||||
(shepherd home-shepherd-configuration-shepherd
|
||||
(default shepherd-0.9)) ; package
|
||||
(auto-start? home-shepherd-configuration-auto-start?
|
||||
(default #t))
|
||||
(services home-shepherd-configuration-services
|
||||
(default '())))
|
||||
|
||||
(define (home-shepherd-configuration-file services shepherd)
|
||||
"Return the shepherd configuration file for SERVICES. SHEPHERD is used
|
||||
as shepherd package."
|
||||
(assert-valid-graph services)
|
||||
|
||||
(let ((files (map shepherd-service-file services))
|
||||
;; TODO: Add compilation of services, it can improve start
|
||||
;; time.
|
||||
;; (scm->go (cute scm->go <> shepherd))
|
||||
)
|
||||
(define config
|
||||
#~(begin
|
||||
(use-modules (srfi srfi-34)
|
||||
(system repl error-handling))
|
||||
(apply
|
||||
register-services
|
||||
(map
|
||||
(lambda (file) (load file))
|
||||
'#$files))
|
||||
(action 'root 'daemonize)
|
||||
(format #t "Starting services...~%")
|
||||
(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))
|
||||
(services (home-shepherd-configuration-services config)))
|
||||
(if (home-shepherd-configuration-auto-start? config)
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(unless (file-exists?
|
||||
(string-append
|
||||
(or (getenv "XDG_RUNTIME_DIR")
|
||||
(format #f "/run/user/~a" (getuid)))
|
||||
"/shepherd/socket"))
|
||||
(let ((log-dir (or (getenv "XDG_LOG_HOME")
|
||||
(format #f "~a/.local/var/log"
|
||||
(getenv "HOME")))))
|
||||
((@ (guix build utils) mkdir-p) log-dir)
|
||||
(system*
|
||||
#$(file-append shepherd "/bin/shepherd")
|
||||
"--logfile"
|
||||
(string-append log-dir "/shepherd.log")
|
||||
"--config"
|
||||
#$(home-shepherd-configuration-file services shepherd)))))
|
||||
#~"")))
|
||||
|
||||
(define (reload-configuration-gexp config)
|
||||
(let* ((shepherd (home-shepherd-configuration-shepherd config))
|
||||
(services (home-shepherd-configuration-services config)))
|
||||
#~(system*
|
||||
#$(file-append shepherd "/bin/herd")
|
||||
"load" "root"
|
||||
#$(home-shepherd-configuration-file services shepherd))))
|
||||
|
||||
(define (ensure-shepherd-gexp config)
|
||||
#~(if (file-exists?
|
||||
(string-append
|
||||
(or (getenv "XDG_RUNTIME_DIR")
|
||||
(format #f "/run/user/~a" (getuid)))
|
||||
"/shepherd/socket"))
|
||||
#$(reload-configuration-gexp config)
|
||||
#$(launch-shepherd-gexp config)))
|
||||
|
||||
(define-public home-shepherd-service-type
|
||||
(service-type (name 'home-shepherd)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-run-on-first-login-service-type
|
||||
launch-shepherd-gexp)
|
||||
(service-extension
|
||||
home-activation-service-type
|
||||
ensure-shepherd-gexp)
|
||||
(service-extension
|
||||
home-profile-service-type
|
||||
(lambda (config)
|
||||
`(,(home-shepherd-configuration-shepherd config))))))
|
||||
(compose concatenate)
|
||||
(extend
|
||||
(lambda (config extra-services)
|
||||
(home-shepherd-configuration
|
||||
(inherit config)
|
||||
(services
|
||||
(append (home-shepherd-configuration-services config)
|
||||
extra-services)))))
|
||||
(default-value (home-shepherd-configuration))
|
||||
(description "Configure and install userland Shepherd.")))
|
||||
|
||||
|
||||
@@ -1,254 +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 *unspecified* AF_INET AF_INET6)))
|
||||
|
||||
(define (serialize-address-family field family)
|
||||
(if (unspecified? 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
|
||||
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), or
|
||||
@code{*unspecified*} (allowing 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,481 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu home services xdg)
|
||||
#:use-module (gnu services configuration)
|
||||
#:use-module (gnu home services)
|
||||
#:use-module (gnu packages freedesktop)
|
||||
#:use-module (gnu home services utils)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (guix diagnostics)
|
||||
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (rnrs enums)
|
||||
|
||||
#:export (home-xdg-base-directories-service-type
|
||||
home-xdg-base-directories-configuration
|
||||
home-xdg-base-directories-configuration?
|
||||
|
||||
home-xdg-user-directories-service-type
|
||||
home-xdg-user-directories-configuration
|
||||
home-xdg-user-directories-configuration?
|
||||
|
||||
xdg-desktop-action
|
||||
xdg-desktop-entry
|
||||
home-xdg-mime-applications-service-type
|
||||
home-xdg-mime-applications-configuration))
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This module contains services related to XDG directories and
|
||||
;; applications.
|
||||
;;
|
||||
;; - XDG base directories
|
||||
;; - XDG user directories
|
||||
;; - XDG MIME applications
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
|
||||
;;;
|
||||
;;; XDG base directories.
|
||||
;;;
|
||||
|
||||
(define (serialize-path field-name val) "")
|
||||
(define path? string?)
|
||||
|
||||
(define-configuration home-xdg-base-directories-configuration
|
||||
(cache-home
|
||||
(path "$HOME/.cache")
|
||||
"Base directory for programs to store user-specific non-essential
|
||||
(cached) data. Files in this directory can be deleted anytime without
|
||||
loss of important data.")
|
||||
(config-home
|
||||
(path "$HOME/.config")
|
||||
"Base directory for programs to store configuration files.
|
||||
Some programs store here log or state files, but it's not desired,
|
||||
this directory should contain static configurations.")
|
||||
(data-home
|
||||
(path "$HOME/.local/share")
|
||||
"Base directory for programs to store architecture independent
|
||||
read-only shared data, analogus to @file{/usr/share}, but for user.")
|
||||
(runtime-dir
|
||||
(path "${XDG_RUNTIME_DIR:-/run/user/$UID}")
|
||||
"Base directory for programs to store user-specific runtime files,
|
||||
like sockets.")
|
||||
(log-home
|
||||
(path "$HOME/.local/var/log")
|
||||
"Base directory for programs to store log files, analogus to
|
||||
@file{/var/log}, but for user. It is not a part of XDG Base Directory
|
||||
Specification, but helps to make implementation of home services more
|
||||
consistent.")
|
||||
(state-home
|
||||
(path "$HOME/.local/var/lib")
|
||||
"Base directory for programs to store state files, like databases,
|
||||
analogus to @file{/var/lib}, but for user. It is not a part of XDG
|
||||
Base Directory Specification, but helps to make implementation of home
|
||||
services more consistent."))
|
||||
|
||||
(define (home-xdg-base-directories-environment-variables-service config)
|
||||
(map
|
||||
(lambda (field)
|
||||
(cons (format
|
||||
#f "XDG_~a"
|
||||
(object->snake-case-string (configuration-field-name field) 'upper))
|
||||
((configuration-field-getter field) config)))
|
||||
home-xdg-base-directories-configuration-fields))
|
||||
|
||||
(define (ensure-xdg-base-dirs-on-activation config)
|
||||
#~(map (lambda (xdg-base-dir-variable)
|
||||
((@@ (guix build utils) mkdir-p)
|
||||
(getenv
|
||||
xdg-base-dir-variable)))
|
||||
'#$(map (lambda (field)
|
||||
(format
|
||||
#f "XDG_~a"
|
||||
(object->snake-case-string
|
||||
(configuration-field-name field) 'upper)))
|
||||
home-xdg-base-directories-configuration-fields)))
|
||||
|
||||
(define (last-extension-or-cfg config extensions)
|
||||
"Picks configuration value from last provided extension. If there
|
||||
are no extensions use configuration instead."
|
||||
(or (and (not (null? extensions)) (last extensions)) config))
|
||||
|
||||
(define home-xdg-base-directories-service-type
|
||||
(service-type (name 'home-xdg-base-directories)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-environment-variables-service-type
|
||||
home-xdg-base-directories-environment-variables-service)
|
||||
(service-extension
|
||||
home-activation-service-type
|
||||
ensure-xdg-base-dirs-on-activation)))
|
||||
(default-value (home-xdg-base-directories-configuration))
|
||||
(compose identity)
|
||||
(extend last-extension-or-cfg)
|
||||
(description "Configure XDG base directories. This
|
||||
service introduces two additional variables @env{XDG_STATE_HOME},
|
||||
@env{XDG_LOG_HOME}. They are not a part of XDG specification, at
|
||||
least yet, but are convenient to have, it improves the consistency
|
||||
between different home services. The services of this service-type is
|
||||
instantiated by default, to provide non-default value, extend the
|
||||
service-type (using @code{simple-service} for example).")))
|
||||
|
||||
(define (generate-home-xdg-base-directories-documentation)
|
||||
(generate-documentation
|
||||
`((home-xdg-base-directories-configuration
|
||||
,home-xdg-base-directories-configuration-fields))
|
||||
'home-xdg-base-directories-configuration))
|
||||
|
||||
|
||||
;;;
|
||||
;;; XDG user directories.
|
||||
;;;
|
||||
|
||||
(define (serialize-string field-name val)
|
||||
;; The path has to be quoted
|
||||
(format #f "XDG_~a_DIR=\"~a\"\n"
|
||||
(object->snake-case-string field-name 'upper) val))
|
||||
|
||||
(define-configuration home-xdg-user-directories-configuration
|
||||
(desktop
|
||||
(string "$HOME/Desktop")
|
||||
"Default ``desktop'' directory, this is what you see on your
|
||||
desktop when using a desktop environment,
|
||||
e.g. GNOME (@pxref{XWindow,,,guix.info}).")
|
||||
(documents
|
||||
(string "$HOME/Documents")
|
||||
"Default directory to put documents like PDFs.")
|
||||
(download
|
||||
(string "$HOME/Downloads")
|
||||
"Default directory downloaded files, this is where your Web-broser
|
||||
will put downloaded files in.")
|
||||
(music
|
||||
(string "$HOME/Music")
|
||||
"Default directory for audio files.")
|
||||
(pictures
|
||||
(string "$HOME/Pictures")
|
||||
"Default directory for pictures and images.")
|
||||
(publicshare
|
||||
(string "$HOME/Public")
|
||||
"Default directory for shared files, which can be accessed by other
|
||||
users on local machine or via network.")
|
||||
(templates
|
||||
(string "$HOME/Templates")
|
||||
"Default directory for templates. They can be used by graphical
|
||||
file manager or other apps for creating new files with some
|
||||
pre-populated content.")
|
||||
(videos
|
||||
(string "$HOME/Videos")
|
||||
"Default directory for videos."))
|
||||
|
||||
(define (home-xdg-user-directories-files-service config)
|
||||
`(("user-dirs.conf"
|
||||
,(mixed-text-file
|
||||
"user-dirs.conf"
|
||||
"enabled=False\n"))
|
||||
("user-dirs.dirs"
|
||||
,(mixed-text-file
|
||||
"user-dirs.dirs"
|
||||
(serialize-configuration
|
||||
config
|
||||
home-xdg-user-directories-configuration-fields)))))
|
||||
|
||||
(define (home-xdg-user-directories-activation-service config)
|
||||
(let ((dirs (map (lambda (field)
|
||||
((configuration-field-getter field) config))
|
||||
home-xdg-user-directories-configuration-fields)))
|
||||
#~(let ((ensure-dir
|
||||
(lambda (path)
|
||||
(mkdir-p
|
||||
((@@ (ice-9 string-fun) string-replace-substring)
|
||||
path "$HOME" (getenv "HOME"))))))
|
||||
(display "Creating XDG user directories...")
|
||||
(map ensure-dir '#$dirs)
|
||||
(display " done\n"))))
|
||||
|
||||
(define home-xdg-user-directories-service-type
|
||||
(service-type (name 'home-xdg-user-directories)
|
||||
(extensions
|
||||
(list (service-extension
|
||||
home-xdg-configuration-files-service-type
|
||||
home-xdg-user-directories-files-service)
|
||||
(service-extension
|
||||
home-activation-service-type
|
||||
home-xdg-user-directories-activation-service)))
|
||||
(default-value (home-xdg-user-directories-configuration))
|
||||
(description "Configure XDG user directories. To
|
||||
disable a directory, point it to the $HOME.")))
|
||||
|
||||
(define (generate-home-xdg-user-directories-documentation)
|
||||
(generate-documentation
|
||||
`((home-xdg-user-directories-configuration
|
||||
,home-xdg-user-directories-configuration-fields))
|
||||
'home-xdg-user-directories-configuration))
|
||||
|
||||
|
||||
;;;
|
||||
;;; XDG MIME applications.
|
||||
;;;
|
||||
|
||||
;; Example config
|
||||
;;
|
||||
;; (home-xdg-mime-applications-configuration
|
||||
;; (added '((x-scheme-handler/magnet . torrent.desktop)))
|
||||
;; (default '((inode/directory . file.desktop)))
|
||||
;; (removed '((inode/directory . thunar.desktop)))
|
||||
;; (desktop-entries
|
||||
;; (list (xdg-desktop-entry
|
||||
;; (file "file")
|
||||
;; (name "File manager")
|
||||
;; (type 'application)
|
||||
;; (config
|
||||
;; '((exec . "emacsclient -c -a emacs %u"))))
|
||||
;; (xdg-desktop-entry
|
||||
;; (file "text")
|
||||
;; (name "Text editor")
|
||||
;; (type 'application)
|
||||
;; (config
|
||||
;; '((exec . "emacsclient -c -a emacs %u")))
|
||||
;; (actions
|
||||
;; (list (xdg-desktop-action
|
||||
;; (action 'create)
|
||||
;; (name "Create an action")
|
||||
;; (config
|
||||
;; '((exec . "echo hi"))))))))))
|
||||
|
||||
;; See
|
||||
;; <https://specifications.freedesktop.org/shared-mime-info-spec/shared-mime-info-spec-latest.html>
|
||||
;; <https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-latest.html>
|
||||
|
||||
(define (serialize-alist field-name val)
|
||||
(define (serialize-mimelist-entry key val)
|
||||
(let ((val (cond
|
||||
((list? val)
|
||||
(string-join (map maybe-object->string val) ";"))
|
||||
((or (string? val) (symbol? val))
|
||||
val)
|
||||
(else (raise (formatted-message
|
||||
(G_ "\
|
||||
The value of an XDG MIME entry must be a list, string or symbol, was given ~a")
|
||||
val))))))
|
||||
(format #f "~a=~a\n" key val)))
|
||||
|
||||
(define (merge-duplicates alist acc)
|
||||
"Merge values that have the same key.
|
||||
|
||||
@example
|
||||
(merge-duplicates '((key1 . value1)
|
||||
(key2 . value2)
|
||||
(key1 . value3)
|
||||
(key1 . value4)) '())
|
||||
|
||||
@result{} ((key1 . (value4 value3 value1)) (key2 . value2))
|
||||
@end example"
|
||||
(cond
|
||||
((null? alist) acc)
|
||||
(else (let* ((head (first alist))
|
||||
(tail (cdr alist))
|
||||
(key (first head))
|
||||
(value (cdr head))
|
||||
(duplicate? (assoc key acc))
|
||||
(ensure-list (lambda (x)
|
||||
(if (list? x) x (list x)))))
|
||||
(if duplicate?
|
||||
;; XXX: This will change the order of things,
|
||||
;; though, it shouldn't be a problem for XDG MIME.
|
||||
(merge-duplicates
|
||||
tail
|
||||
(alist-cons key
|
||||
(cons value (ensure-list (cdr duplicate?)))
|
||||
(alist-delete key acc)))
|
||||
(merge-duplicates tail (cons head acc)))))))
|
||||
|
||||
(string-append (if (equal? field-name 'default)
|
||||
"\n[Default Applications]\n"
|
||||
(format #f "\n[~a Associations]\n"
|
||||
(string-capitalize (symbol->string field-name))))
|
||||
(generic-serialize-alist string-append
|
||||
serialize-mimelist-entry
|
||||
(merge-duplicates val '()))))
|
||||
|
||||
(define xdg-desktop-types (make-enumeration
|
||||
'(application
|
||||
link
|
||||
directory)))
|
||||
|
||||
(define (xdg-desktop-type? type)
|
||||
(unless (enum-set-member? type xdg-desktop-types)
|
||||
(raise (formatted-message
|
||||
(G_ "XDG desktop type must be of of ~a, was given: ~a")
|
||||
(list->human-readable-list (enum-set->list xdg-desktop-types))
|
||||
type))))
|
||||
|
||||
;; TODO: Add proper docs for this
|
||||
;; XXX: 'define-configuration' require that fields have a default
|
||||
;; value.
|
||||
(define-record-type* <xdg-desktop-action>
|
||||
xdg-desktop-action make-xdg-desktop-action
|
||||
xdg-desktop-action?
|
||||
(action xdg-desktop-action-action) ; symbol
|
||||
(name xdg-desktop-action-name) ; string
|
||||
(config xdg-desktop-action-config ; alist
|
||||
(default '())))
|
||||
|
||||
(define-record-type* <xdg-desktop-entry>
|
||||
xdg-desktop-entry make-xdg-desktop-entry
|
||||
xdg-desktop-entry?
|
||||
;; ".desktop" will automatically be added
|
||||
(file xdg-desktop-entry-file) ; string
|
||||
(name xdg-desktop-entry-name) ; string
|
||||
(type xdg-desktop-entry-type) ; xdg-desktop-type
|
||||
(config xdg-desktop-entry-config ; alist
|
||||
(default '()))
|
||||
(actions xdg-desktop-entry-actions ; list of <xdg-desktop-action>
|
||||
(default '())))
|
||||
|
||||
(define desktop-entries? (list-of xdg-desktop-entry?))
|
||||
(define (serialize-desktop-entries field-name val) "")
|
||||
|
||||
(define (serialize-xdg-desktop-entry entry)
|
||||
"Return a tuple of the file name for ENTRY and the serialized
|
||||
configuration."
|
||||
(define (format-config key val)
|
||||
(let ((val (cond
|
||||
((list? val)
|
||||
(string-join (map maybe-object->string val) ";"))
|
||||
((boolean? val)
|
||||
(if val "true" "false"))
|
||||
(else val)))
|
||||
(key (string-capitalize (maybe-object->string key))))
|
||||
(list (if (string-suffix? key "?")
|
||||
(string-drop-right key (- (string-length key) 1))
|
||||
key)
|
||||
"=" val "\n")))
|
||||
|
||||
(define (serialize-alist config)
|
||||
(generic-serialize-alist append format-config config))
|
||||
|
||||
(define (serialize-xdg-desktop-action action)
|
||||
(match action
|
||||
(($ <xdg-desktop-action> action name config)
|
||||
`(,(format #f "[Desktop Action ~a]\n"
|
||||
(string-capitalize (maybe-object->string action)))
|
||||
,(format #f "Name=~a\n" name)
|
||||
,@(serialize-alist config)))))
|
||||
|
||||
(match entry
|
||||
(($ <xdg-desktop-entry> file name type config actions)
|
||||
(list (if (string-suffix? file ".desktop")
|
||||
file
|
||||
(string-append file ".desktop"))
|
||||
`("[Desktop Entry]\n"
|
||||
,(format #f "Name=~a\n" name)
|
||||
,(format #f "Type=~a\n"
|
||||
(string-capitalize (symbol->string type)))
|
||||
,@(serialize-alist config)
|
||||
,@(append-map serialize-xdg-desktop-action actions))))))
|
||||
|
||||
(define-configuration home-xdg-mime-applications-configuration
|
||||
(added
|
||||
(alist '())
|
||||
"An association list of MIME types and desktop entries which indicate
|
||||
that the application should used to open the specified MIME type. The
|
||||
value has to be string, symbol, or list of strings or symbols, this
|
||||
applies to the `@code{default}', and `@code{removed}' fields as well.")
|
||||
(default
|
||||
(alist '())
|
||||
"An association list of MIME types and desktop entries which indicate
|
||||
that the application should be the default for opening the specified
|
||||
MIME type.")
|
||||
(removed
|
||||
(alist '())
|
||||
"An association list of MIME types and desktop entries which indicate
|
||||
that the application cannot open the specified MIME type.")
|
||||
(desktop-entries
|
||||
(desktop-entries '())
|
||||
"A list of XDG desktop entries to create. See
|
||||
@code{xdg-desktop-entry}."))
|
||||
|
||||
(define (home-xdg-mime-applications-files config)
|
||||
(define (add-xdg-desktop-entry-file entry)
|
||||
(let ((file (first entry))
|
||||
(config (second entry)))
|
||||
;; 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.")))
|
||||
+5
-45
@@ -17,12 +17,7 @@
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu image)
|
||||
#:use-module (guix platform)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:export (partition
|
||||
partition?
|
||||
partition-device
|
||||
@@ -39,15 +34,12 @@
|
||||
image?
|
||||
image-name
|
||||
image-format
|
||||
image-platform
|
||||
image-target
|
||||
image-size
|
||||
image-operating-system
|
||||
image-partition-table-type
|
||||
image-partitions
|
||||
image-compression?
|
||||
image-volatile-root?
|
||||
image-shared-store?
|
||||
image-shared-network?
|
||||
image-substitutable?
|
||||
|
||||
image-type
|
||||
@@ -55,8 +47,7 @@
|
||||
image-type-name
|
||||
image-type-constructor
|
||||
|
||||
os->image
|
||||
os+platform->image))
|
||||
os->image))
|
||||
|
||||
|
||||
;;;
|
||||
@@ -74,57 +65,31 @@
|
||||
(label partition-label (default #f))
|
||||
(uuid partition-uuid (default #f))
|
||||
(flags partition-flags (default '()))
|
||||
(initializer partition-initializer (default #f))) ;gexp | #f
|
||||
(initializer partition-initializer (default #f)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Image record.
|
||||
;;;
|
||||
|
||||
(define-syntax-rule (define-set-sanitizer name field set)
|
||||
"Define NAME as a procedure or macro that raises an error if passed a value
|
||||
that is not in SET, mentioning FIELD in the error message."
|
||||
(define-with-syntax-properties (name (value properties))
|
||||
(unless (memq value 'set)
|
||||
(raise
|
||||
(make-compound-condition
|
||||
(condition
|
||||
(&error-location
|
||||
(location (source-properties->location properties))))
|
||||
(formatted-message (G_ "~s: invalid '~a' value") value 'field))))
|
||||
value))
|
||||
|
||||
(define-set-sanitizer validate-image-format format
|
||||
(disk-image compressed-qcow2 docker iso9660))
|
||||
(define-set-sanitizer validate-partition-table-type partition-table-type
|
||||
(mbr gpt))
|
||||
|
||||
(define-record-type* <image>
|
||||
image make-image
|
||||
image?
|
||||
(name image-name ;symbol
|
||||
(default #f))
|
||||
(format image-format ;symbol
|
||||
(sanitize validate-image-format))
|
||||
(platform image-platform ;<platform>
|
||||
(format image-format) ;symbol
|
||||
(target image-target
|
||||
(default #f))
|
||||
(size image-size ;size in bytes as integer
|
||||
(default 'guess))
|
||||
(operating-system image-operating-system ;<operating-system>
|
||||
(default #f))
|
||||
(partition-table-type image-partition-table-type ; 'mbr or 'gpt
|
||||
(default 'mbr)
|
||||
(sanitize validate-partition-table-type))
|
||||
(partitions image-partitions ;list of <partition>
|
||||
(default '()))
|
||||
(compression? image-compression? ;boolean
|
||||
(default #t))
|
||||
(volatile-root? image-volatile-root? ;boolean
|
||||
(default #t))
|
||||
(shared-store? image-shared-store? ;boolean
|
||||
(default #f))
|
||||
(shared-network? image-shared-network? ;boolean
|
||||
(default #f))
|
||||
(substitutable? image-substitutable? ;boolean
|
||||
(default #t)))
|
||||
|
||||
@@ -147,8 +112,3 @@ that is not in SET, mentioning FIELD in the error message."
|
||||
(define* (os->image os #:key type)
|
||||
(let ((constructor (image-type-constructor type)))
|
||||
(constructor os)))
|
||||
|
||||
(define* (os+platform->image os platform #:key type)
|
||||
(image
|
||||
(inherit (os->image os #:type type))
|
||||
(platform platform)))
|
||||
|
||||
+37
-59
@@ -33,7 +33,6 @@
|
||||
#:use-module (gnu packages admin)
|
||||
#:use-module (gnu packages base)
|
||||
#:use-module (gnu packages bash)
|
||||
#:use-module (gnu packages compression)
|
||||
#:use-module (gnu packages connman)
|
||||
#:use-module (gnu packages cryptsetup)
|
||||
#:use-module (gnu packages disk)
|
||||
@@ -43,10 +42,8 @@
|
||||
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
||||
#:use-module (gnu packages iso-codes)
|
||||
#:use-module (gnu packages linux)
|
||||
#:use-module (gnu packages nano)
|
||||
#:use-module (gnu packages ncurses)
|
||||
#:use-module (gnu packages package-management)
|
||||
#:use-module (gnu packages tls)
|
||||
#:use-module (gnu packages xorg)
|
||||
#:use-module (gnu system locale)
|
||||
#:use-module (ice-9 match)
|
||||
@@ -333,13 +330,10 @@ selected keymap."
|
||||
btrfs-progs
|
||||
jfsutils ;jfs_mkfs
|
||||
ntfs-3g ;mkfs.ntfs
|
||||
xfsprogs ;mkfs.xfs
|
||||
kbd ;chvt
|
||||
guix ;guix system init call
|
||||
util-linux ;mkwap
|
||||
nano
|
||||
shadow
|
||||
tar ;dump
|
||||
gzip ;dump
|
||||
coreutils)))
|
||||
(with-output-to-port (%make-void-port "w")
|
||||
(lambda ()
|
||||
@@ -356,8 +350,7 @@ selected keymap."
|
||||
;; packages …), etc. modules.
|
||||
(with-extensions (list guile-gcrypt guile-newt
|
||||
guile-parted guile-bytestructures
|
||||
guile-json-3 guile-git guile-webutils
|
||||
guix gnutls)
|
||||
guile-json-3 guile-git guix)
|
||||
(with-imported-modules `(,@(source-module-closure
|
||||
`(,@modules
|
||||
(gnu services herd)
|
||||
@@ -368,7 +361,6 @@ selected keymap."
|
||||
(use-modules (gnu installer record)
|
||||
(gnu installer keymap)
|
||||
(gnu installer steps)
|
||||
(gnu installer dump)
|
||||
(gnu installer final)
|
||||
(gnu installer hostname)
|
||||
(gnu installer locale)
|
||||
@@ -385,8 +377,7 @@ selected keymap."
|
||||
(guix build utils)
|
||||
((system repl debug)
|
||||
#:select (terminal-width))
|
||||
(ice-9 match)
|
||||
(ice-9 textual-ports))
|
||||
(ice-9 match))
|
||||
|
||||
;; Initialize gettext support so that installers can use
|
||||
;; (guix i18n) module.
|
||||
@@ -414,56 +405,43 @@ selected keymap."
|
||||
;; verbose.
|
||||
(terminal-width 200)
|
||||
|
||||
(define current-installer newt-installer)
|
||||
(define steps (#$steps current-installer))
|
||||
(let* ((current-installer newt-installer)
|
||||
(steps (#$steps current-installer)))
|
||||
((installer-init current-installer))
|
||||
|
||||
(dynamic-wind
|
||||
(installer-init current-installer)
|
||||
(lambda ()
|
||||
(parameterize
|
||||
((run-command-in-installer
|
||||
(installer-run-command current-installer)))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(define results
|
||||
(run-installer-steps
|
||||
#:rewind-strategy 'menu
|
||||
#:menu-proc (installer-menu-page current-installer)
|
||||
#:steps steps))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(define results
|
||||
(run-installer-steps
|
||||
#:rewind-strategy 'menu
|
||||
#:menu-proc (installer-menu-page current-installer)
|
||||
#:steps steps))
|
||||
|
||||
(match (result-step results 'final)
|
||||
('success
|
||||
;; We did it! Let's reboot!
|
||||
(sync)
|
||||
(stop-service 'root))
|
||||
(_
|
||||
;; The installation failed, exit so that it is
|
||||
;; restarted by login.
|
||||
#f)))
|
||||
(const #f)
|
||||
(lambda (key . args)
|
||||
(installer-log-line "crashing due to uncaught exception: ~s ~s"
|
||||
key args)
|
||||
(define dump-dir
|
||||
(prepare-dump key args #:result %current-result))
|
||||
(define action
|
||||
((installer-exit-error current-installer)
|
||||
(get-string-all
|
||||
(open-input-file
|
||||
(string-append dump-dir "/installer-backtrace")))))
|
||||
(match action
|
||||
('dump
|
||||
(let* ((dump-files
|
||||
((installer-dump-page current-installer)
|
||||
dump-dir))
|
||||
(dump-archive
|
||||
(make-dump dump-dir dump-files)))
|
||||
((installer-report-page current-installer)
|
||||
dump-archive)))
|
||||
(_ #f))
|
||||
(exit 1)))))
|
||||
(match (result-step results 'final)
|
||||
('success
|
||||
;; We did it! Let's reboot!
|
||||
(sync)
|
||||
(stop-service 'root))
|
||||
(_
|
||||
;; The installation failed, exit so that it is restarted
|
||||
;; by login.
|
||||
#f)))
|
||||
(const #f)
|
||||
(lambda (key . args)
|
||||
(syslog "crashing due to uncaught exception: ~s ~s~%"
|
||||
key args)
|
||||
(let ((error-file "/tmp/last-installer-error"))
|
||||
(call-with-output-file error-file
|
||||
(lambda (port)
|
||||
(display-backtrace (make-stack #t) port)
|
||||
(print-exception port
|
||||
(stack-ref (make-stack #t) 1)
|
||||
key args)))
|
||||
((installer-exit-error current-installer)
|
||||
error-file key args))
|
||||
(primitive-exit 1)))
|
||||
|
||||
(installer-exit current-installer))))))
|
||||
((installer-exit current-installer)))))))
|
||||
|
||||
(program-file
|
||||
"installer"
|
||||
|
||||
@@ -287,7 +287,7 @@ list so that each keys of a given technology are gathered in a separate list."
|
||||
|
||||
(define (connman-online?)
|
||||
(let ((state (connman-state)))
|
||||
(memq state '(ready online))))
|
||||
(eq? state 'online)))
|
||||
|
||||
(define (connman-connect-with-auth service password-proc)
|
||||
"Connect to the given SERVICE with the password returned by calling
|
||||
|
||||
@@ -1,118 +0,0 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu installer dump)
|
||||
#:use-module (gnu installer utils)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (ice-9 iconv)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (web client)
|
||||
#:use-module (web http)
|
||||
#:use-module (web response)
|
||||
#:use-module (webutils multipart)
|
||||
#:export (prepare-dump
|
||||
make-dump
|
||||
send-dump-report))
|
||||
|
||||
;; The installer crash dump type.
|
||||
(define %dump-type "installer-dump")
|
||||
|
||||
(define (result->list result)
|
||||
"Return the alist for the given RESULT."
|
||||
(hash-map->list (lambda (k v)
|
||||
(cons k v))
|
||||
result))
|
||||
|
||||
(define* (prepare-dump key args #:key result)
|
||||
"Create a crash dump directory. KEY and ARGS represent the thrown error.
|
||||
RESULT is the installer result hash table. Returns the created directory path."
|
||||
(define now (localtime (current-time)))
|
||||
(define dump-dir
|
||||
(format #f "/tmp/dump.~a"
|
||||
(strftime "%F.%H.%M.%S" now)))
|
||||
(mkdir-p dump-dir)
|
||||
(with-directory-excursion dump-dir
|
||||
;; backtrace
|
||||
(call-with-output-file "installer-backtrace"
|
||||
(lambda (port)
|
||||
(display-backtrace (make-stack #t) port)
|
||||
(print-exception port
|
||||
(stack-ref (make-stack #t) 1)
|
||||
key args)))
|
||||
|
||||
;; installer result
|
||||
(call-with-output-file "installer-result"
|
||||
(lambda (port)
|
||||
(write (result->list result) port)))
|
||||
|
||||
;; syslog
|
||||
(copy-file "/var/log/messages" "syslog")
|
||||
|
||||
;; dmesg
|
||||
(let ((pipe (open-pipe* OPEN_READ "dmesg")))
|
||||
(call-with-output-file "dmesg"
|
||||
(lambda (port)
|
||||
(dump-port pipe port)
|
||||
(close-pipe pipe)))))
|
||||
dump-dir)
|
||||
|
||||
(define* (make-dump dump-dir file-choices)
|
||||
"Create a crash dump archive from DUMP-DIR containing FILE-CHOICES.
|
||||
Returns the archive path."
|
||||
(define output (string-append (basename dump-dir) ".tar.gz"))
|
||||
(with-directory-excursion (dirname dump-dir)
|
||||
(apply system* "tar" "-zcf" output
|
||||
(map (lambda (f)
|
||||
(string-append (basename dump-dir) "/" f))
|
||||
file-choices)))
|
||||
(canonicalize-path (string-append (dirname dump-dir) "/" output)))
|
||||
|
||||
(define* (send-dump-report dump
|
||||
#:key
|
||||
(url "https://dump.guix.gnu.org"))
|
||||
"Turn the DUMP archive into a multipart body and send it to the Guix crash
|
||||
dump server at URL."
|
||||
(define (match-boundary kont)
|
||||
(match-lambda
|
||||
(('boundary . (? string? b))
|
||||
(kont b))
|
||||
(x #f)))
|
||||
|
||||
(define (response->string response)
|
||||
(bytevector->string
|
||||
(read-response-body response)
|
||||
"UTF-8"))
|
||||
|
||||
(let-values (((body boundary)
|
||||
(call-with-input-file dump
|
||||
(lambda (port)
|
||||
(format-multipart-body
|
||||
`((,%dump-type . ,port)))))))
|
||||
(false-if-exception
|
||||
(response->string
|
||||
(http-post
|
||||
(string-append url "/upload")
|
||||
#:keep-alive? #t
|
||||
#:streaming? #t
|
||||
#:headers `((content-type
|
||||
. (multipart/form-data
|
||||
(boundary . ,boundary))))
|
||||
#:body body)))))
|
||||
+44
-32
@@ -85,9 +85,8 @@ USERS."
|
||||
(uid (if root? 0 #f))
|
||||
(home-directory
|
||||
(user-home-directory user))
|
||||
(password (crypt
|
||||
(secret-content (user-password user))
|
||||
(salt)))
|
||||
(password (crypt (user-password user)
|
||||
(salt)))
|
||||
|
||||
;; We need a string here, not a file-like, hence
|
||||
;; this choice.
|
||||
@@ -106,6 +105,36 @@ USERS."
|
||||
(write-passwd password (string-append etc "/passwd"))
|
||||
(write-shadow shadow (string-append etc "/shadow")))
|
||||
|
||||
(define* (kill-cow-users cow-path #:key (spare '("udevd")))
|
||||
"Kill all processes that have references to the given COW-PATH in their
|
||||
'maps' file. The process whose names are in SPARE list are spared."
|
||||
(define %not-nul
|
||||
(char-set-complement (char-set #\nul)))
|
||||
|
||||
(let ((pids
|
||||
(filter-map (lambda (pid)
|
||||
(false-if-exception
|
||||
(call-with-input-file
|
||||
(string-append "/proc/" pid "/maps")
|
||||
(lambda (port)
|
||||
(and (string-contains (get-string-all port)
|
||||
cow-path)
|
||||
(string->number pid))))))
|
||||
(scandir "/proc" string->number))))
|
||||
(for-each (lambda (pid)
|
||||
;; cmdline does not always exist.
|
||||
(false-if-exception
|
||||
(call-with-input-file
|
||||
(string-append "/proc/" (number->string pid) "/cmdline")
|
||||
(lambda (port)
|
||||
(match (string-tokenize (read-string port) %not-nul)
|
||||
((argv0 _ ...)
|
||||
(unless (member (basename argv0) spare)
|
||||
(syslog "Killing process ~a (~a)~%" pid argv0)
|
||||
(kill pid SIGKILL)))
|
||||
(_ #f))))))
|
||||
pids)))
|
||||
|
||||
(define (call-with-mnt-container thunk)
|
||||
"This is a variant of call-with-container. Run THUNK in a new container
|
||||
process, within a separate MNT namespace. The container is not jailed so that
|
||||
@@ -120,28 +149,6 @@ it can interact with the rest of the system."
|
||||
(match (waitpid pid)
|
||||
((_ . status) status))))
|
||||
|
||||
(define (install-locale locale)
|
||||
"Install the given LOCALE or the en_US.utf8 locale as a fallback."
|
||||
(let ((supported? (false-if-exception
|
||||
(setlocale LC_ALL locale))))
|
||||
(if supported?
|
||||
(begin
|
||||
(installer-log-line "install supported locale ~a." locale)
|
||||
(setenv "LC_ALL" locale))
|
||||
(begin
|
||||
;; If the selected locale is not supported, install a default UTF-8
|
||||
;; locale. This is required to copy some files with UTF-8
|
||||
;; characters, in the nss-certs package notably. Set LANGUAGE
|
||||
;; anyways, to have translated messages if possible.
|
||||
(installer-log-line "~a locale is not supported, installing \
|
||||
en_US.utf8 locale instead." locale)
|
||||
(setlocale LC_ALL "en_US.utf8")
|
||||
(setenv "LC_ALL" "en_US.utf8")
|
||||
(setenv "LANGUAGE"
|
||||
(string-take locale
|
||||
(or (string-index locale #\_)
|
||||
(string-length locale))))))))
|
||||
|
||||
(define* (install-system locale #:key (users '()))
|
||||
"Create /etc/shadow and /etc/passwd on the installation target for USERS.
|
||||
Start COW-STORE service on target directory and launch guix install command in
|
||||
@@ -192,10 +199,6 @@ or #f. Return #t on success and #f on failure."
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
;; Install the locale before mounting the cow-store, otherwise
|
||||
;; the loaded cow-store locale files will prevent umounting.
|
||||
(install-locale locale)
|
||||
|
||||
;; Save the database, so that it can be restored once the
|
||||
;; cow-store is umounted.
|
||||
(copy-file database-file saved-database)
|
||||
@@ -209,9 +212,18 @@ or #f. Return #t on success and #f on failure."
|
||||
(setvbuf (current-output-port) 'none)
|
||||
(setvbuf (current-error-port) 'none)
|
||||
|
||||
(setenv "PATH" "/run/current-system/profile/bin/")
|
||||
|
||||
(set! ret (run-command install-command)))
|
||||
;; If there are any connected clients, assume that we are running
|
||||
;; installation tests. In that case, dump the standard and error
|
||||
;; outputs to syslog.
|
||||
(set! ret
|
||||
(if (not (null? (current-clients)))
|
||||
(with-output-to-file "/dev/console"
|
||||
(lambda ()
|
||||
(with-error-to-file "/dev/console"
|
||||
(lambda ()
|
||||
(run-command install-command
|
||||
#:locale locale)))))
|
||||
(run-command install-command #:locale locale))))
|
||||
(lambda ()
|
||||
;; Restart guix-daemon so that it does no keep the MNT namespace
|
||||
;; alive.
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2018, 2021 Mathieu Othacehe <othacehe@gnu.org>
|
||||
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
@@ -79,11 +79,6 @@
|
||||
"Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
|
||||
and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
|
||||
Configuration Database, describing possible XKB configurations."
|
||||
(define maybe-empty
|
||||
(match-lambda
|
||||
((x) x)
|
||||
(#f "")))
|
||||
|
||||
(define (model m)
|
||||
(sxml-match m
|
||||
[(model
|
||||
@@ -113,7 +108,7 @@ Configuration Database, describing possible XKB configurations."
|
||||
. ,rest-variant))
|
||||
(x11-keymap-variant
|
||||
(name name)
|
||||
(description (maybe-empty
|
||||
(description (car
|
||||
(assoc-ref rest-variant 'description))))]))
|
||||
|
||||
(define (layout l)
|
||||
@@ -125,9 +120,9 @@ Configuration Database, describing possible XKB configurations."
|
||||
(variantList ,[variant -> v] ...))
|
||||
(x11-keymap-layout
|
||||
(name name)
|
||||
(synopsis (maybe-empty
|
||||
(synopsis (car
|
||||
(assoc-ref rest-layout 'shortDescription)))
|
||||
(description (maybe-empty
|
||||
(description (car
|
||||
(assoc-ref rest-layout 'description)))
|
||||
(variants (list v ...)))]
|
||||
[(layout
|
||||
@@ -136,9 +131,9 @@ Configuration Database, describing possible XKB configurations."
|
||||
. ,rest-layout))
|
||||
(x11-keymap-layout
|
||||
(name name)
|
||||
(synopsis (maybe-empty
|
||||
(synopsis (car
|
||||
(assoc-ref rest-layout 'shortDescription)))
|
||||
(description (maybe-empty
|
||||
(description (car
|
||||
(assoc-ref rest-layout 'description)))
|
||||
(variants '()))]))
|
||||
|
||||
|
||||
+18
-104
@@ -19,7 +19,6 @@
|
||||
(define-module (gnu installer newt)
|
||||
#:use-module (gnu installer record)
|
||||
#:use-module (gnu installer utils)
|
||||
#:use-module (gnu installer dump)
|
||||
#:use-module (gnu installer newt ethernet)
|
||||
#:use-module (gnu installer newt final)
|
||||
#:use-module (gnu installer newt parameters)
|
||||
@@ -40,12 +39,7 @@
|
||||
#:use-module (guix config)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (newt)
|
||||
#:export (newt-installer))
|
||||
|
||||
@@ -53,7 +47,7 @@
|
||||
(newt-init)
|
||||
(clear-screen)
|
||||
(set-screen-size!)
|
||||
(installer-log-line "Display is ~ax~a." (screen-columns) (screen-rows))
|
||||
(syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows))
|
||||
(push-help-line
|
||||
(format #f (G_ "Press <F1> for installation parameters."))))
|
||||
|
||||
@@ -61,102 +55,25 @@
|
||||
(newt-finish)
|
||||
(clear-screen))
|
||||
|
||||
(define (exit-error error)
|
||||
(define (exit-error file key args)
|
||||
(newt-set-color COLORSET-ROOT "white" "red")
|
||||
(define action
|
||||
(run-textbox-page
|
||||
#:info-text (G_ "The installer has encountered an unexpected problem. \
|
||||
The backtrace is displayed below. You may choose to exit or create a dump \
|
||||
archive.")
|
||||
(let ((width (nearest-exact-integer
|
||||
(* (screen-columns) 0.8)))
|
||||
(height (nearest-exact-integer
|
||||
(* (screen-rows) 0.7))))
|
||||
(run-file-textbox-page
|
||||
#:info-text (format #f (G_ "The installer has encountered an unexpected \
|
||||
problem. The backtrace is displayed below. Please report it by email to \
|
||||
<~a>.") %guix-bug-report-address)
|
||||
#:title (G_ "Unexpected problem")
|
||||
#:content error
|
||||
#:buttons-spec
|
||||
(list
|
||||
(cons (G_ "Dump") (const 'dump))
|
||||
(cons (G_ "Exit") (const 'exit)))))
|
||||
#:file file
|
||||
#:exit-button? #f
|
||||
#:info-textbox-width width
|
||||
#:file-textbox-width width
|
||||
#:file-textbox-height height))
|
||||
(newt-set-color COLORSET-ROOT "white" "blue")
|
||||
action)
|
||||
|
||||
(define (report-page dump-archive)
|
||||
(define text
|
||||
(format #f (G_ "The dump archive was created as ~a. Would you like to \
|
||||
send this archive to the Guix servers?") dump-archive))
|
||||
(define title (G_ "Dump archive created"))
|
||||
(when (run-confirmation-page text title)
|
||||
(let* ((uploaded-name (send-dump-report dump-archive))
|
||||
(text (if uploaded-name
|
||||
(format #f (G_ "The dump was uploaded as ~a. Please \
|
||||
report it by email to ~a.") uploaded-name %guix-bug-report-address)
|
||||
(G_ "The dump could not be uploaded."))))
|
||||
(run-error-page
|
||||
text
|
||||
(G_ "Dump upload result")))))
|
||||
|
||||
(define (dump-page dump-dir)
|
||||
(define files
|
||||
(scandir dump-dir (lambda (x)
|
||||
(not (or (string=? x ".")
|
||||
(string=? x ".."))))))
|
||||
(fold (match-lambda*
|
||||
(((file . enable?) acc)
|
||||
(if enable?
|
||||
(cons file acc)
|
||||
acc)))
|
||||
'()
|
||||
(run-dump-page
|
||||
dump-dir
|
||||
(map (lambda (x)
|
||||
(cons x #f))
|
||||
files))))
|
||||
|
||||
(define (newt-run-command . args)
|
||||
(define command-output "")
|
||||
(define (line-accumulator line)
|
||||
(set! command-output
|
||||
(string-append/shared command-output line "\n")))
|
||||
(define displayed-command
|
||||
(string-join
|
||||
(map (lambda (s) (string-append "\"" s "\"")) args)
|
||||
" "))
|
||||
(define result (run-external-command-with-line-hooks (list line-accumulator)
|
||||
args))
|
||||
(define exit-val (status:exit-val result))
|
||||
(define term-sig (status:term-sig result))
|
||||
(define stop-sig (status:stop-sig result))
|
||||
|
||||
(if (and exit-val (zero? exit-val))
|
||||
#t
|
||||
(let ((info-text
|
||||
(cond
|
||||
(exit-val
|
||||
(format #f (G_ "External command ~s exited with code ~a")
|
||||
args exit-val))
|
||||
(term-sig
|
||||
(format #f (G_ "External command ~s terminated by signal ~a")
|
||||
args term-sig))
|
||||
(stop-sig
|
||||
(format #f (G_ "External command ~s stopped by signal ~a")
|
||||
args stop-sig)))))
|
||||
(run-textbox-page #:title (G_ "External command error")
|
||||
#:info-text info-text
|
||||
#:content command-output
|
||||
#:buttons-spec
|
||||
(list
|
||||
(cons "Ignore" (const #t))
|
||||
(cons "Abort"
|
||||
(lambda ()
|
||||
(abort-to-prompt 'installer-step 'abort)))
|
||||
(cons "Report"
|
||||
(lambda ()
|
||||
(raise
|
||||
(condition
|
||||
((@@ (guix build utils)
|
||||
&invoke-error)
|
||||
(program (car args))
|
||||
(arguments (cdr args))
|
||||
(exit-status exit-val)
|
||||
(term-signal term-sig)
|
||||
(stop-signal stop-sig)))))))))))
|
||||
(newt-finish)
|
||||
(clear-screen))
|
||||
|
||||
(define (final-page result prev-steps)
|
||||
(run-final-page result prev-steps))
|
||||
@@ -225,7 +142,4 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address)
|
||||
(services-page services-page)
|
||||
(welcome-page welcome-page)
|
||||
(parameters-menu parameters-menu)
|
||||
(parameters-page parameters-page)
|
||||
(dump-page dump-page)
|
||||
(run-command newt-run-command)
|
||||
(report-page report-page)))
|
||||
(parameters-page parameters-page)))
|
||||
|
||||
@@ -65,7 +65,9 @@ connection is pending."
|
||||
(run-error-page
|
||||
(G_ "No ethernet service available, please try again.")
|
||||
(G_ "No service"))
|
||||
(abort-to-prompt 'installer-step 'abort))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
((service)
|
||||
;; Only one service is available so return it directly.
|
||||
service)
|
||||
@@ -79,5 +81,7 @@ connection is pending."
|
||||
#:button-text (G_ "Exit")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
#:listbox-callback-procedure connect-ethernet-service))))
|
||||
|
||||
@@ -59,7 +59,9 @@ This will take a few minutes.")
|
||||
#:file-textbox-height height
|
||||
#:exit-button-callback-procedure
|
||||
(lambda ()
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-install-success-page)
|
||||
(match (current-clients)
|
||||
@@ -86,7 +88,9 @@ press the button to reboot.")))
|
||||
(G_ "Restart the installer")
|
||||
(G_ "The final system installation step failed. You can resume from \
|
||||
a specific step, or restart the installer."))
|
||||
(1 (abort-to-prompt 'installer-step 'abort))
|
||||
(1 (raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
(2
|
||||
;; Keep going, the installer will be restarted later on.
|
||||
#t)))
|
||||
@@ -105,7 +109,7 @@ a specific step, or restart the installer."))
|
||||
(define (run-final-page result prev-steps)
|
||||
(define (wait-for-clients)
|
||||
(unless (null? (current-clients))
|
||||
(installer-log-line "waiting with clients before starting final step")
|
||||
(syslog "waiting with clients before starting final step~%")
|
||||
(send-to-clients '(starting-final-step))
|
||||
(match (select (current-clients) '() '())
|
||||
(((port _ ...) _ _)
|
||||
@@ -115,7 +119,7 @@ a specific step, or restart the installer."))
|
||||
;; things such as changing the swap partition label.
|
||||
(wait-for-clients)
|
||||
|
||||
(installer-log-line "proceeding with final step")
|
||||
(syslog "proceeding with final step~%")
|
||||
(let* ((configuration (format-configuration prev-steps result))
|
||||
(user-partitions (result-step result 'partition))
|
||||
(locale (result-step result 'locale))
|
||||
|
||||
@@ -59,7 +59,9 @@ different layout at any time from the parameters menu.")))
|
||||
((param) (const #f))
|
||||
(else
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))))
|
||||
|
||||
(define (run-variant-page variants variant->text)
|
||||
(let ((title (G_ "Variant")))
|
||||
@@ -72,7 +74,9 @@ different layout at any time from the parameters menu.")))
|
||||
#:button-text (G_ "Back")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (sort-layouts layouts)
|
||||
"Sort LAYOUTS list by putting the US layout ahead and return it."
|
||||
|
||||
@@ -43,7 +43,9 @@ installation process and for the installed system.")
|
||||
#:button-text (G_ "Exit")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))))
|
||||
|
||||
;; Immediately install the chosen language so that the territory page that
|
||||
;; comes after (optionally) is displayed in the chosen language.
|
||||
@@ -61,7 +63,9 @@ installation process and for the installed system.")
|
||||
#:button-text (G_ "Back")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-codeset-page codesets)
|
||||
(let ((title (G_ "Locale codeset")))
|
||||
@@ -74,7 +78,9 @@ installation process and for the installed system.")
|
||||
#:button-text (G_ "Back")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-modifier-page modifiers modifier->text)
|
||||
(let ((title (G_ "Locale modifier")))
|
||||
@@ -88,7 +94,9 @@ symbol.")
|
||||
#:button-text (G_ "Back")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define* (run-locale-page #:key
|
||||
supported-locales
|
||||
@@ -102,10 +110,11 @@ associating a territory code with a territory name. The formatted locale, under
|
||||
glibc format is returned."
|
||||
|
||||
(define (break-on-locale-found locales)
|
||||
"Break to the installer step if LOCALES contains exactly one
|
||||
"Raise the &installer-step-break condition if LOCALES contains exactly one
|
||||
element."
|
||||
(and (= (length locales) 1)
|
||||
(abort-to-prompt 'installer-step 'break)))
|
||||
(raise
|
||||
(condition (&installer-step-break)))))
|
||||
|
||||
(define (filter-locales locales result)
|
||||
"Filter the list of locale records LOCALES using the RESULT returned by
|
||||
@@ -209,8 +218,8 @@ glibc locale string and return it."
|
||||
|
||||
;; If run-installer-steps returns locally, it means that the user had to go
|
||||
;; through all steps (language, territory, codeset and modifier) to select a
|
||||
;; locale. In that case, like if we exited by breaking to the installer
|
||||
;; step, turn the result into a glibc locale string and return it.
|
||||
;; locale. In that case, like if we exited by raising &installer-step-break
|
||||
;; condition, turn the result into a glibc locale string and return it.
|
||||
(result->locale-string
|
||||
supported-locales
|
||||
(run-installer-steps #:steps locale-steps)))
|
||||
|
||||
@@ -30,8 +30,6 @@
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (web client)
|
||||
#:use-module (web response)
|
||||
#:use-module (newt)
|
||||
#:export (run-network-page))
|
||||
|
||||
@@ -65,8 +63,12 @@ Internet and return the selected technology. For now, only technologies with
|
||||
(G_ "Exit")
|
||||
(G_ "The install process requires Internet access but no \
|
||||
network devices were found. Do you want to continue anyway?"))
|
||||
((1) (abort-to-prompt 'installer-step 'break))
|
||||
((2) (abort-to-prompt 'installer-step 'abort))))
|
||||
((1) (raise
|
||||
(condition
|
||||
(&installer-step-break))))
|
||||
((2) (raise
|
||||
(condition
|
||||
(&installer-step-abort))))))
|
||||
((technology)
|
||||
;; Since there's only one technology available, skip the selection
|
||||
;; screen.
|
||||
@@ -82,7 +84,9 @@ network devices were found. Do you want to continue anyway?"))
|
||||
#:button-text (G_ "Exit")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort))))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))))))
|
||||
|
||||
(define (find-technology-by-type technologies type)
|
||||
"Find and return a technology with the given TYPE in TECHNOLOGIES list."
|
||||
@@ -115,23 +119,8 @@ network devices were found. Do you want to continue anyway?"))
|
||||
(define (wait-service-online)
|
||||
"Display a newt scale until connman detects an Internet access. Do
|
||||
FULL-VALUE tentatives, spaced by 1 second."
|
||||
(define (ci-available?)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(sigaction SIGALRM
|
||||
(lambda _ #f))
|
||||
(alarm 3))
|
||||
(lambda ()
|
||||
(false-if-exception
|
||||
(= (response-code
|
||||
(http-request "https://ci.guix.gnu.org"))
|
||||
200)))
|
||||
(lambda ()
|
||||
(alarm 0))))
|
||||
|
||||
(define (online?)
|
||||
(or (and (connman-online?)
|
||||
(ci-available?))
|
||||
(or (connman-online?)
|
||||
(file-exists? "/tmp/installer-assume-online")))
|
||||
|
||||
(let* ((full-value 5))
|
||||
@@ -148,9 +137,11 @@ FULL-VALUE tentatives, spaced by 1 second."
|
||||
(unless (online?)
|
||||
(run-error-page
|
||||
(G_ "The selected network does not provide access to the \
|
||||
Internet and the Guix substitute server, please try again.")
|
||||
Internet, please try again.")
|
||||
(G_ "Connection error"))
|
||||
(abort-to-prompt 'installer-step 'abort))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))))
|
||||
|
||||
(define (run-network-page)
|
||||
"Run a page to allow the user to configure connman so that it can access the
|
||||
|
||||
+10
-160
@@ -22,7 +22,6 @@
|
||||
#:use-module (gnu installer steps)
|
||||
#:use-module (gnu installer utils)
|
||||
#:use-module (gnu installer newt utils)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (ice-9 i18n)
|
||||
#:use-module (ice-9 match)
|
||||
@@ -44,10 +43,6 @@
|
||||
run-scale-page
|
||||
run-checkbox-tree-page
|
||||
run-file-textbox-page
|
||||
%ok-button
|
||||
%exit-button
|
||||
run-textbox-page
|
||||
run-dump-page
|
||||
|
||||
run-form-with-clients))
|
||||
|
||||
@@ -98,9 +93,9 @@ disconnect.
|
||||
Like 'run-form', return two values: the exit reason, and an \"argument\"."
|
||||
(define* (discard-client! port #:optional errno)
|
||||
(if errno
|
||||
(installer-log-line "removing client ~d due to ~s"
|
||||
(syslog "removing client ~d due to ~s~%"
|
||||
(fileno port) (strerror errno))
|
||||
(installer-log-line "removing client ~d due to EOF"
|
||||
(syslog "removing client ~d due to EOF~%"
|
||||
(fileno port)))
|
||||
|
||||
;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we
|
||||
@@ -129,7 +124,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
|
||||
(send-to-clients exp)
|
||||
|
||||
(let loop ()
|
||||
(installer-log-line "running form ~s (~s) with ~d clients"
|
||||
(syslog "running form ~s (~s) with ~d clients~%"
|
||||
form title (length (current-clients)))
|
||||
|
||||
;; Call 'watch-clients!' within the loop because there might be new
|
||||
@@ -151,7 +146,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
|
||||
(discard-client! port)
|
||||
(loop))
|
||||
(obj
|
||||
(installer-log-line "form ~s (~s): client ~d replied ~s"
|
||||
(syslog "form ~s (~s): client ~d replied ~s~%"
|
||||
form title (fileno port) obj)
|
||||
(values 'exit-fd-ready obj))))
|
||||
(lambda args
|
||||
@@ -161,9 +156,8 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
|
||||
;; Accept a new client and send it EXP.
|
||||
(match (accept port)
|
||||
((client . _)
|
||||
(installer-log-line
|
||||
"accepting new client ~d while on form ~s"
|
||||
(fileno client) form)
|
||||
(syslog "accepting new client ~d while on form ~s~%"
|
||||
(fileno client) form)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(write exp client)
|
||||
@@ -492,7 +486,7 @@ the current listbox item has to be selected by key."
|
||||
(string=? str (listbox-item->text item))))
|
||||
keys)
|
||||
((key . item) item)
|
||||
(#f (abort-to-prompt 'installer-step 'abort))))
|
||||
(#f (raise (condition (&installer-step-abort))))))
|
||||
|
||||
;; On every listbox element change, check if we need to skip it. If yes,
|
||||
;; depending on the 'last-listbox-key', jump forward or backward. If no,
|
||||
@@ -694,7 +688,7 @@ ITEMS when 'Ok' is pressed."
|
||||
(string=? str (item->text item))))
|
||||
keys)
|
||||
((key . item) item)
|
||||
(#f (abort-to-prompt 'installer-step 'abort))))
|
||||
(#f (raise (condition (&installer-step-abort))))))
|
||||
|
||||
(add-form-to-grid grid form #t)
|
||||
(make-wrapped-grid-window grid title)
|
||||
@@ -732,7 +726,8 @@ ITEMS when 'Ok' is pressed."
|
||||
(newt-suspend)
|
||||
;; Use Nano because it syntax-highlights Scheme by default.
|
||||
;; TODO: Add a menu to choose an editor?
|
||||
(invoke "nano" file)
|
||||
(run-command (list "/run/current-system/profile/bin/nano" file)
|
||||
#:locale locale)
|
||||
(newt-resume))
|
||||
|
||||
(define* (run-file-textbox-page #:key
|
||||
@@ -816,151 +811,6 @@ ITEMS when 'Ok' is pressed."
|
||||
(destroy-form-and-pop form))))
|
||||
|
||||
(if (and (eq? exit-reason 'exit-component)
|
||||
edit-button
|
||||
(components=? argument edit-button))
|
||||
(loop) ;recurse in tail position
|
||||
result)))))
|
||||
|
||||
(define %ok-button
|
||||
(cons (G_ "Ok") (lambda () #t)))
|
||||
|
||||
(define %exit-button
|
||||
(cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort))))
|
||||
|
||||
(define %default-buttons
|
||||
(list %ok-button %exit-button))
|
||||
|
||||
(define (make-newt-buttons buttons-spec)
|
||||
(map
|
||||
(match-lambda ((title . proc)
|
||||
(cons (make-button -1 -1 title) proc)))
|
||||
buttons-spec))
|
||||
|
||||
(define* (run-textbox-page #:key
|
||||
title
|
||||
info-text
|
||||
content
|
||||
(buttons-spec %default-buttons))
|
||||
"Run a page to display INFO-TEXT followed by CONTENT to the user, who has to
|
||||
choose an action among the buttons specified by BUTTONS-SPEC.
|
||||
|
||||
BUTTONS-SPEC is an association list with button labels as keys, and callback
|
||||
procedures as values.
|
||||
|
||||
This procedure returns the result of the callback procedure of the button
|
||||
chosen by the user."
|
||||
(define info-textbox
|
||||
(make-reflowed-textbox -1 -1 info-text
|
||||
50
|
||||
#:flags FLAG-BORDER))
|
||||
(define content-textbox
|
||||
(make-textbox -1 -1
|
||||
50
|
||||
30
|
||||
(logior FLAG-SCROLL FLAG-BORDER)))
|
||||
(define buttons
|
||||
(make-newt-buttons buttons-spec))
|
||||
(define grid
|
||||
(vertically-stacked-grid
|
||||
GRID-ELEMENT-COMPONENT info-textbox
|
||||
GRID-ELEMENT-COMPONENT content-textbox
|
||||
GRID-ELEMENT-SUBGRID
|
||||
(apply
|
||||
horizontal-stacked-grid
|
||||
(append-map (match-lambda ((button . proc)
|
||||
(list GRID-ELEMENT-COMPONENT button)))
|
||||
buttons))))
|
||||
(define form (make-form #:flags FLAG-NOF12))
|
||||
(add-form-to-grid grid form #t)
|
||||
(make-wrapped-grid-window grid title)
|
||||
(set-textbox-text content-textbox
|
||||
(receive (_w _h text)
|
||||
(reflow-text content
|
||||
50
|
||||
0 0)
|
||||
text))
|
||||
|
||||
(receive (exit-reason argument)
|
||||
(run-form-with-clients form
|
||||
`(contents-dialog (title ,title)
|
||||
(text ,info-text)
|
||||
(content ,content)))
|
||||
(destroy-form-and-pop form)
|
||||
(match exit-reason
|
||||
('exit-component
|
||||
(let ((proc (assq-ref buttons argument)))
|
||||
(if proc
|
||||
(proc)
|
||||
(raise
|
||||
(condition
|
||||
(&serious)
|
||||
(&message
|
||||
(message (format #f "Unable to find corresponding PROC for \
|
||||
component ~a." argument))))))))
|
||||
;; TODO
|
||||
('exit-fd-ready
|
||||
(raise (condition (&serious)))))))
|
||||
|
||||
(define* (run-dump-page base-dir file-choices)
|
||||
(define info-textbox
|
||||
(make-reflowed-textbox -1 -1 "Please select files you wish to include in \
|
||||
the dump."
|
||||
50
|
||||
#:flags FLAG-BORDER))
|
||||
(define components
|
||||
(map (match-lambda ((file . enabled)
|
||||
(list
|
||||
(make-compact-button -1 -1 "Edit")
|
||||
(make-checkbox -1 -1 file (if enabled #\x #\ ) " x")
|
||||
file)))
|
||||
file-choices))
|
||||
|
||||
(define sub-grid (make-grid 2 (length components)))
|
||||
|
||||
(for-each
|
||||
(match-lambda* (((button checkbox _) index)
|
||||
(set-grid-field sub-grid 0 index
|
||||
GRID-ELEMENT-COMPONENT checkbox
|
||||
#:anchor ANCHOR-LEFT)
|
||||
(set-grid-field sub-grid 1 index
|
||||
GRID-ELEMENT-COMPONENT button
|
||||
#:anchor ANCHOR-LEFT)))
|
||||
components (iota (length components)))
|
||||
|
||||
(define grid
|
||||
(vertically-stacked-grid
|
||||
GRID-ELEMENT-COMPONENT info-textbox
|
||||
GRID-ELEMENT-SUBGRID sub-grid
|
||||
GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create")))
|
||||
|
||||
(define form (make-form #:flags FLAG-NOF12))
|
||||
|
||||
(add-form-to-grid grid form #t)
|
||||
(make-wrapped-grid-window grid "Installer dump")
|
||||
|
||||
(define prompt-tag (make-prompt-tag))
|
||||
|
||||
(let loop ()
|
||||
(call-with-prompt prompt-tag
|
||||
(lambda ()
|
||||
(receive (exit-reason argument)
|
||||
(run-form-with-clients form
|
||||
`(dump-page))
|
||||
(match exit-reason
|
||||
('exit-component
|
||||
(let ((result
|
||||
(map (match-lambda
|
||||
((edit checkbox filename)
|
||||
(if (components=? edit argument)
|
||||
(abort-to-prompt prompt-tag filename)
|
||||
(cons filename (eq? #\x
|
||||
(checkbox-value checkbox))))))
|
||||
components)))
|
||||
(destroy-form-and-pop form)
|
||||
result))
|
||||
;; TODO
|
||||
('exit-fd-ready
|
||||
(raise (condition (&serious)))))))
|
||||
(lambda (k file)
|
||||
(edit-file (string-append base-dir "/" file))
|
||||
(loop)))))
|
||||
|
||||
@@ -36,8 +36,10 @@
|
||||
#:export (run-partitioning-page))
|
||||
|
||||
(define (button-exit-action)
|
||||
"Abort the installer step."
|
||||
(abort-to-prompt 'installer-step 'abort))
|
||||
"Raise the &installer-step-abort condition."
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
|
||||
(define (run-scheme-page)
|
||||
"Run a page asking the user for a partitioning scheme."
|
||||
@@ -81,8 +83,7 @@ DEVICES list."
|
||||
devices))
|
||||
|
||||
(let* ((result (run-listbox-selection-page
|
||||
#:info-text (G_ "Please select a \
|
||||
disk. The installation device as well as the small devices are filtered.")
|
||||
#:info-text (G_ "Please select a disk.")
|
||||
#:title (G_ "Disk")
|
||||
#:listbox-items (device-items)
|
||||
#:listbox-item->text cdr
|
||||
@@ -130,11 +131,7 @@ Be careful, all data on the disk will be lost.")
|
||||
(run-listbox-selection-page
|
||||
#:info-text (G_ "Please select the file-system type for this partition.")
|
||||
#:title (G_ "File-system type")
|
||||
#:listbox-items '(btrfs ext4 jfs xfs
|
||||
swap
|
||||
;; These lack basic Unix features. Their only use
|
||||
;; on GNU is for interoperation, e.g., with UEFI.
|
||||
fat32 fat16 ntfs)
|
||||
#:listbox-items '(ext4 btrfs fat16 fat32 jfs ntfs swap)
|
||||
#:listbox-item->text user-fs-type-name
|
||||
#:sort-listbox-items? #f
|
||||
#:button-text (G_ "Exit")
|
||||
@@ -646,10 +643,8 @@ edit it."
|
||||
default-result))))
|
||||
((partition? item)
|
||||
(if (freespace-partition? item)
|
||||
(begin
|
||||
(run-error-page (G_ "You cannot delete a free space area.")
|
||||
(G_ "Delete partition"))
|
||||
default-result)
|
||||
(run-error-page (G_ "You cannot delete a free space area.")
|
||||
(G_ "Delete partition"))
|
||||
(let* ((disk (partition-disk item))
|
||||
(number-str (partition-print-number item))
|
||||
(info-text
|
||||
@@ -714,13 +709,6 @@ by pressing the Exit button.~%~%")))
|
||||
(run-error-page
|
||||
(G_ "No root mount point found.")
|
||||
(G_ "Missing mount point"))
|
||||
#f)
|
||||
((cannot-read-uuid? c)
|
||||
(run-error-page
|
||||
(format #f (G_ "Cannot read the ~a partition UUID.\
|
||||
You may need to format it.")
|
||||
(cannot-read-uuid-partition c))
|
||||
(G_ "Wrong partition format"))
|
||||
#f))
|
||||
(check-user-partitions user-partitions))))
|
||||
(if user-partitions-ok?
|
||||
@@ -791,17 +779,16 @@ by pressing the Exit button.~%~%")))
|
||||
result-user-partitions)))))
|
||||
|
||||
(init-parted)
|
||||
(let* ((eligible-devices (eligible-devices))
|
||||
(user-partitions (run-page eligible-devices))
|
||||
(let* ((non-install-devices (non-install-devices))
|
||||
(user-partitions (run-page non-install-devices))
|
||||
(user-partitions-with-pass (prompt-luks-passwords
|
||||
user-partitions))
|
||||
(form (draw-formatting-page user-partitions)))
|
||||
;; Make sure the disks are not in use before proceeding to formatting.
|
||||
(free-parted eligible-devices)
|
||||
(free-parted non-install-devices)
|
||||
(format-user-partitions user-partitions-with-pass)
|
||||
(installer-log-line "formatted ~a user partitions"
|
||||
(syslog "formatted ~a user partitions~%"
|
||||
(length user-partitions-with-pass))
|
||||
(installer-log-line "user-partitions: ~a" user-partitions)
|
||||
|
||||
(destroy-form-and-pop form)
|
||||
user-partitions))
|
||||
|
||||
@@ -3,7 +3,6 @@
|
||||
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||
;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -46,7 +45,9 @@ to choose from them later when you log in.")
|
||||
#:checkbox-tree-height 9
|
||||
#:exit-button-callback-procedure
|
||||
(lambda ()
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-networking-cbt-page)
|
||||
"Run a page allowing the user to select networking services."
|
||||
@@ -63,46 +64,9 @@ system.")
|
||||
#:checkbox-tree-height 5
|
||||
#:exit-button-callback-procedure
|
||||
(lambda ()
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
|
||||
(define (run-printing-services-cbt-page)
|
||||
"Run a page allowing the user to select document services such as CUPS."
|
||||
(let ((items (filter (lambda (service)
|
||||
(eq? 'document
|
||||
(system-service-type service)))
|
||||
%system-services)))
|
||||
(run-checkbox-tree-page
|
||||
#:info-text (G_ "You can now select the CUPS printing service to run on your \
|
||||
system.")
|
||||
#:title (G_ "Printing and document services")
|
||||
#:items items
|
||||
#:selection (map system-service-recommended? items)
|
||||
#:item->text (compose G_ system-service-name)
|
||||
#:checkbox-tree-height 9
|
||||
#:exit-button-callback-procedure
|
||||
(lambda ()
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
|
||||
(define (run-console-services-cbt-page)
|
||||
"Run a page to select various system adminstration services for non-graphical
|
||||
systems."
|
||||
(let ((items (filter (lambda (service)
|
||||
(eq? 'administration
|
||||
(system-service-type service)))
|
||||
%system-services)))
|
||||
(run-checkbox-tree-page
|
||||
#:title (G_ "Console services")
|
||||
#:info-text (G_ "Select miscellaneous services to run on your \
|
||||
non-graphical system.")
|
||||
#:items items
|
||||
#:selection (map system-service-recommended? items)
|
||||
#:item->text (compose G_ system-service-name)
|
||||
#:checkbox-tree-height 5
|
||||
#:exit-button-callback-procedure
|
||||
(lambda ()
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-network-management-page)
|
||||
"Run a page to select among several network management methods."
|
||||
@@ -124,7 +88,9 @@ client may be enough for a server.")
|
||||
#:button-text (G_ "Exit")
|
||||
#:button-callback-procedure
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort)))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort)))))))
|
||||
|
||||
(define (run-services-page)
|
||||
(let ((desktop (run-desktop-environments-cbt-page)))
|
||||
@@ -133,7 +99,5 @@ client may be enough for a server.")
|
||||
(append desktop
|
||||
(run-networking-cbt-page)
|
||||
(if (null? desktop)
|
||||
(cons (run-network-management-page)
|
||||
(run-console-services-cbt-page))
|
||||
'())
|
||||
(run-printing-services-cbt-page))))
|
||||
(list (run-network-management-page))
|
||||
'()))))
|
||||
|
||||
@@ -65,7 +65,9 @@ returned."
|
||||
#:button-callback-procedure
|
||||
(if (null? path)
|
||||
(lambda _
|
||||
(abort-to-prompt 'installer-step 'abort))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
(lambda _
|
||||
(loop (all-but-last path))))
|
||||
#:listbox-callback-procedure
|
||||
|
||||
+24
-34
@@ -20,6 +20,7 @@
|
||||
|
||||
(define-module (gnu installer newt user)
|
||||
#:use-module (gnu installer user)
|
||||
#:use-module ((gnu installer steps) #:select (&installer-step-abort))
|
||||
#:use-module (gnu installer newt page)
|
||||
#:use-module (gnu installer newt utils)
|
||||
#:use-module (gnu installer utils)
|
||||
@@ -40,9 +41,6 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
|
||||
(define (pad-label label)
|
||||
(string-pad-right label 25))
|
||||
|
||||
(define (root-account? name)
|
||||
(string=? name "root"))
|
||||
|
||||
(let* ((label-name
|
||||
(make-label -1 -1 (pad-label (G_ "Name"))))
|
||||
(label-real-name
|
||||
@@ -119,14 +117,10 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
|
||||
GRID-ELEMENT-SUBGRID button-grid)
|
||||
title)
|
||||
|
||||
(let ((error-empty-field-page
|
||||
(let ((error-page
|
||||
(lambda ()
|
||||
(run-error-page (G_ "Empty inputs are not allowed.")
|
||||
(G_ "Empty input"))))
|
||||
(error-root-page
|
||||
(lambda ()
|
||||
(run-error-page (G_ "Root account is automatically created.")
|
||||
(G_ "Root account")))))
|
||||
(G_ "Empty input")))))
|
||||
(receive (exit-reason argument)
|
||||
(run-form form)
|
||||
(dynamic-wind
|
||||
@@ -139,28 +133,22 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
|
||||
(real-name (entry-value entry-real-name))
|
||||
(home-directory (entry-value entry-home-directory))
|
||||
(password (entry-value entry-password)))
|
||||
(cond
|
||||
;; Empty field.
|
||||
((or (string=? name "")
|
||||
(string=? home-directory ""))
|
||||
(error-empty-field-page)
|
||||
(run-user-add-page))
|
||||
;; Reject root account.
|
||||
((root-account? name)
|
||||
(error-root-page)
|
||||
(run-user-add-page))
|
||||
(else
|
||||
(let ((password (confirm-password password)))
|
||||
(if password
|
||||
(user
|
||||
(name name)
|
||||
(real-name real-name)
|
||||
(home-directory home-directory)
|
||||
(password (make-secret password)))
|
||||
(run-user-add-page #:name name
|
||||
#:real-name real-name
|
||||
#:home-directory
|
||||
home-directory))))))))))
|
||||
(if (or (string=? name "")
|
||||
(string=? home-directory ""))
|
||||
(begin
|
||||
(error-page)
|
||||
(run-user-add-page))
|
||||
(let ((password (confirm-password password)))
|
||||
(if password
|
||||
(user
|
||||
(name name)
|
||||
(real-name real-name)
|
||||
(home-directory home-directory)
|
||||
(password password))
|
||||
(run-user-add-page #:name name
|
||||
#:real-name real-name
|
||||
#:home-directory
|
||||
home-directory)))))))))
|
||||
(lambda ()
|
||||
(destroy-form-and-pop form)))))))
|
||||
|
||||
@@ -269,7 +257,9 @@ administrator (\"root\").")
|
||||
(run users))
|
||||
(reverse users))
|
||||
((components=? argument exit-button)
|
||||
(abort-to-prompt 'installer-step 'abort))))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))))
|
||||
('exit-fd-ready
|
||||
;; Read the complete user list at once.
|
||||
(match argument
|
||||
@@ -279,7 +269,7 @@ administrator (\"root\").")
|
||||
(map (lambda (name real-name home password)
|
||||
(user (name name) (real-name real-name)
|
||||
(home-directory home)
|
||||
(password (make-secret password))))
|
||||
(password password)))
|
||||
names real-names homes passwords))))))
|
||||
(lambda ()
|
||||
(destroy-form-and-pop form))))))
|
||||
@@ -287,5 +277,5 @@ administrator (\"root\").")
|
||||
;; Add a "root" user simply to convey the root password.
|
||||
(cons (user (name "root")
|
||||
(home-directory "/root")
|
||||
(password (make-secret (run-root-password-page))))
|
||||
(password (run-root-password-page)))
|
||||
(run '())))
|
||||
|
||||
@@ -84,7 +84,7 @@ we want this page to occupy all the screen space available."
|
||||
(string=? str (listbox-item->text item))))
|
||||
keys)
|
||||
((key . item) item)
|
||||
(#f (abort-to-prompt 'installer-step 'abort))))
|
||||
(#f (raise (condition (&installer-step-abort))))))
|
||||
|
||||
(set-textbox-text logo-textbox (read-all logo))
|
||||
|
||||
|
||||
@@ -237,7 +237,9 @@ force a wifi scan."
|
||||
(run-wifi-scan-page)
|
||||
(run-wifi-page))
|
||||
((components=? argument exit-button)
|
||||
(abort-to-prompt 'installer-step 'abort))
|
||||
(raise
|
||||
(condition
|
||||
(&installer-step-abort))))
|
||||
((components=? argument listbox)
|
||||
(let ((result (connect-wifi-service listbox service-items)))
|
||||
(unless result
|
||||
|
||||
+82
-171
@@ -24,14 +24,8 @@
|
||||
#:use-module (gnu installer newt page)
|
||||
#:use-module (gnu system uuid)
|
||||
#:use-module ((gnu build file-systems)
|
||||
#:select (canonicalize-device-spec
|
||||
find-partition-by-label
|
||||
find-partition-by-uuid
|
||||
read-partition-uuid
|
||||
#:select (read-partition-uuid
|
||||
read-luks-partition-uuid))
|
||||
#:use-module ((gnu build linux-boot)
|
||||
#:select (linux-command-line
|
||||
find-long-option))
|
||||
#:use-module ((gnu build linux-modules)
|
||||
#:select (missing-modules))
|
||||
#:use-module ((gnu system linux-initrd)
|
||||
@@ -81,7 +75,7 @@
|
||||
|
||||
with-delay-device-in-use?
|
||||
force-device-sync
|
||||
eligible-devices
|
||||
non-install-devices
|
||||
partition-user-type
|
||||
user-fs-type-name
|
||||
partition-filesystem-user-type
|
||||
@@ -113,9 +107,6 @@
|
||||
|
||||
&no-root-mount-point
|
||||
no-root-mount-point?
|
||||
&cannot-read-uuid
|
||||
cannot-read-uuid?
|
||||
cannot-read-uuid-partition
|
||||
|
||||
check-user-partitions
|
||||
set-user-partitions-file-name
|
||||
@@ -232,7 +223,6 @@ inferior to MAX-SIZE, #f otherwise."
|
||||
((fat32) "fat32")
|
||||
((jfs) "jfs")
|
||||
((ntfs) "ntfs")
|
||||
((xfs) "xfs")
|
||||
((swap) "linux-swap")))
|
||||
|
||||
(define (user-fs-type->mount-type fs-type)
|
||||
@@ -240,11 +230,10 @@ inferior to MAX-SIZE, #f otherwise."
|
||||
(case fs-type
|
||||
((ext4) "ext4")
|
||||
((btrfs) "btrfs")
|
||||
((fat16) "vfat")
|
||||
((fat16) "fat")
|
||||
((fat32) "vfat")
|
||||
((jfs) "jfs")
|
||||
((ntfs) "ntfs")
|
||||
((xfs) "xfs")))
|
||||
((ntfs) "ntfs")))
|
||||
|
||||
(define (partition-filesystem-user-type partition)
|
||||
"Return the filesystem type of PARTITION, to be stored in the FS-TYPE field
|
||||
@@ -259,7 +248,6 @@ of <user-partition> record."
|
||||
((string=? name "fat32") 'fat32)
|
||||
((string=? name "jfs") 'jfs)
|
||||
((string=? name "ntfs") 'ntfs)
|
||||
((string=? name "xfs") 'xfs)
|
||||
((or (string=? name "swsusp")
|
||||
(string=? name "linux-swap(v0)")
|
||||
(string=? name "linux-swap(v1)"))
|
||||
@@ -343,63 +331,19 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation."
|
||||
|
||||
(define (remove-logical-devices)
|
||||
"Remove all active logical devices."
|
||||
((run-command-in-installer) "dmsetup" "remove_all"))
|
||||
(with-null-output-ports
|
||||
(invoke "dmsetup" "remove_all")))
|
||||
|
||||
(define (installer-root-partition-path)
|
||||
"Return the root partition path, or #f if it could not be detected."
|
||||
(let* ((cmdline (linux-command-line))
|
||||
(root (find-long-option "root" cmdline)))
|
||||
(and root
|
||||
(or (and (access? root F_OK) root)
|
||||
(find-partition-by-label root)
|
||||
(and=> (uuid root)
|
||||
find-partition-by-uuid)))))
|
||||
|
||||
;; Minimal installation device size.
|
||||
(define %min-device-size
|
||||
(* 2 GIBIBYTE-SIZE)) ;2GiB
|
||||
|
||||
(define (eligible-devices)
|
||||
"Return all the available devices except the install device and the devices
|
||||
which are smaller than %MIN-DEVICE-SIZE."
|
||||
|
||||
(define the-installer-root-partition-path
|
||||
(installer-root-partition-path))
|
||||
|
||||
(define (small-device? device)
|
||||
(let ((length (device-length device))
|
||||
(sector-size (device-sector-size device)))
|
||||
(and (< (* length sector-size) %min-device-size)
|
||||
(installer-log-line "~a is not eligible because it is smaller than \
|
||||
~a."
|
||||
(device-path device)
|
||||
(unit-format-custom-byte device
|
||||
%min-device-size
|
||||
UNIT-GIGABYTE)))))
|
||||
|
||||
;; Read partition table of device and compare each path to the one
|
||||
;; we're booting from to determine if it is the installation
|
||||
;; device.
|
||||
(define (installation-device? device)
|
||||
;; When using CDROM based installation, the root partition path may be the
|
||||
;; device path.
|
||||
(and (or (string=? the-installer-root-partition-path
|
||||
(device-path device))
|
||||
(let ((disk (disk-new device)))
|
||||
(and disk
|
||||
(any (lambda (partition)
|
||||
(string=? the-installer-root-partition-path
|
||||
(partition-get-path partition)))
|
||||
(disk-partitions disk)))))
|
||||
(installer-log-line "~a is not eligible because it is the \
|
||||
installation device."
|
||||
(device-path device))))
|
||||
|
||||
(remove
|
||||
(lambda (device)
|
||||
(or (installation-device? device)
|
||||
(small-device? device)))
|
||||
(devices)))
|
||||
(define (non-install-devices)
|
||||
"Return all the available devices, except the busy one, allegedly the
|
||||
install device. DEVICE-IS-BUSY? is a parted call, checking if the device is
|
||||
mounted."
|
||||
;; FIXME: The install image uses an overlayfs so the install device does not
|
||||
;; appear as mounted and won't be considered as busy.
|
||||
(remove (lambda (device)
|
||||
(let ((file-name (device-path device)))
|
||||
(device-is-busy? device)))
|
||||
(devices)))
|
||||
|
||||
|
||||
;;
|
||||
@@ -635,14 +579,8 @@ determined by MAX-LENGTH-COLUMN procedure."
|
||||
(define (mklabel device type-name)
|
||||
"Create a partition table on DEVICE. TYPE-NAME is the type of the partition
|
||||
table, \"msdos\" or \"gpt\"."
|
||||
(let* ((type (disk-type-get type-name))
|
||||
(disk (disk-new-fresh device type)))
|
||||
(or disk
|
||||
(raise
|
||||
(condition
|
||||
(&error)
|
||||
(&message (message (format #f "Cannot create partition table of type
|
||||
~a on device ~a." type-name (device-path device)))))))))
|
||||
(let ((type (disk-type-get type-name)))
|
||||
(disk-new-fresh device type)))
|
||||
|
||||
|
||||
;;
|
||||
@@ -824,22 +762,24 @@ cause them to cross."
|
||||
(disk-add-partition disk partition no-constraint)))
|
||||
(partition-ok?
|
||||
(or partition-constraint-ok? partition-no-contraint-ok?)))
|
||||
(installer-log-line "Creating partition:")
|
||||
(installer-log-line "~/type: ~a" partition-type)
|
||||
(installer-log-line "~/filesystem-type: ~a"
|
||||
(filesystem-type-name filesystem-type))
|
||||
(installer-log-line "~/start: ~a" start-sector*)
|
||||
(installer-log-line "~/end: ~a" end-sector)
|
||||
(installer-log-line "~/start-range: [~a, ~a]"
|
||||
(geometry-start start-range)
|
||||
(geometry-end start-range))
|
||||
(installer-log-line "~/end-range: [~a, ~a]"
|
||||
(geometry-start end-range)
|
||||
(geometry-end end-range))
|
||||
(installer-log-line "~/constraint: ~a"
|
||||
partition-constraint-ok?)
|
||||
(installer-log-line "~/no-constraint: ~a"
|
||||
partition-no-contraint-ok?)
|
||||
(syslog "Creating partition:
|
||||
~/type: ~a
|
||||
~/filesystem-type: ~a
|
||||
~/start: ~a
|
||||
~/end: ~a
|
||||
~/start-range: [~a, ~a]
|
||||
~/end-range: [~a, ~a]
|
||||
~/constraint: ~a
|
||||
~/no-constraint: ~a
|
||||
"
|
||||
partition-type
|
||||
(filesystem-type-name filesystem-type)
|
||||
start-sector*
|
||||
end-sector
|
||||
(geometry-start start-range) (geometry-end start-range)
|
||||
(geometry-start end-range) (geometry-end end-range)
|
||||
partition-constraint-ok?
|
||||
partition-no-contraint-ok?)
|
||||
;; Set the partition name if supported.
|
||||
(when (and partition-ok? has-name? name)
|
||||
(partition-set-name partition name))
|
||||
@@ -928,7 +868,7 @@ partition."
|
||||
(format #f "Unable to create partition ~a~%" name)))))))))
|
||||
|
||||
(define (force-user-partitions-formatting user-partitions)
|
||||
"Set the NEED-FORMATTING? fields to #t on all <user-partition> records of
|
||||
"Set the NEED-FORMATING? fields to #t on all <user-partition> records of
|
||||
USER-PARTITIONS list and return the updated list."
|
||||
(map (lambda (p)
|
||||
(user-partition
|
||||
@@ -1066,48 +1006,15 @@ exists."
|
||||
(define-condition-type &no-root-mount-point &condition
|
||||
no-root-mount-point?)
|
||||
|
||||
;; Cannot not read the partition UUID.
|
||||
(define-condition-type &cannot-read-uuid &condition
|
||||
cannot-read-uuid?
|
||||
(partition cannot-read-uuid-partition))
|
||||
|
||||
(define (check-user-partitions user-partitions)
|
||||
"Check the following statements:
|
||||
|
||||
The USER-PARTITIONS list contains one <user-partition> record with a
|
||||
mount-point set to '/'. Raise &no-root-mount-point condition otherwise.
|
||||
|
||||
All the USER-PARTITIONS with a mount point and that will not be formatted have
|
||||
a valid UUID. Raise a &cannot-read-uuid condition specifying the faulty
|
||||
partition otherwise.
|
||||
|
||||
Return #t if all the statements are valid."
|
||||
(define (check-root)
|
||||
(let ((mount-points
|
||||
(map user-partition-mount-point user-partitions)))
|
||||
(or (member "/" mount-points)
|
||||
(raise
|
||||
(condition (&no-root-mount-point))))))
|
||||
|
||||
(define (check-uuid)
|
||||
(let ((mount-partitions
|
||||
(filter user-partition-mount-point user-partitions)))
|
||||
(every
|
||||
(lambda (user-partition)
|
||||
(let ((file-name (user-partition-file-name user-partition))
|
||||
(need-formatting?
|
||||
(user-partition-need-formatting? user-partition)))
|
||||
(or need-formatting?
|
||||
(read-partition-uuid file-name)
|
||||
(raise
|
||||
(condition
|
||||
(&cannot-read-uuid
|
||||
(partition file-name)))))))
|
||||
mount-partitions)))
|
||||
|
||||
(and (check-root)
|
||||
(check-uuid)
|
||||
#t))
|
||||
"Return #t if the USER-PARTITIONS lists contains one <user-partition> record
|
||||
with a mount-point set to '/', raise &no-root-mount-point condition
|
||||
otherwise."
|
||||
(let ((mount-points
|
||||
(map user-partition-mount-point user-partitions)))
|
||||
(or (member "/" mount-points)
|
||||
(raise
|
||||
(condition (&no-root-mount-point))))))
|
||||
|
||||
(define (set-user-partitions-file-name user-partitions)
|
||||
"Set the partition file-name of <user-partition> records in USER-PARTITIONS
|
||||
@@ -1120,37 +1027,48 @@ list and return the updated list."
|
||||
(file-name file-name))))
|
||||
user-partitions))
|
||||
|
||||
(define-syntax-rule (with-null-output-ports exp ...)
|
||||
"Evaluate EXP with both the output port and the error port pointing to the
|
||||
bit bucket."
|
||||
(with-output-to-port (%make-void-port "w")
|
||||
(lambda ()
|
||||
(with-error-to-port (%make-void-port "w")
|
||||
(lambda () exp ...)))))
|
||||
|
||||
(define (create-btrfs-file-system partition)
|
||||
"Create a btrfs file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.btrfs" "-f" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkfs.btrfs" "-f" partition)))
|
||||
|
||||
(define (create-ext4-file-system partition)
|
||||
"Create an ext4 file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.ext4" "-F" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkfs.ext4" "-F" partition)))
|
||||
|
||||
(define (create-fat16-file-system partition)
|
||||
"Create a fat16 file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.fat" "-F16" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkfs.fat" "-F16" partition)))
|
||||
|
||||
(define (create-fat32-file-system partition)
|
||||
"Create a fat32 file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.fat" "-F32" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkfs.fat" "-F32" partition)))
|
||||
|
||||
(define (create-jfs-file-system partition)
|
||||
"Create a JFS file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "jfs_mkfs" "-f" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "jfs_mkfs" "-f" partition)))
|
||||
|
||||
(define (create-ntfs-file-system partition)
|
||||
"Create a JFS file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition))
|
||||
|
||||
(define (create-xfs-file-system partition)
|
||||
"Create an XFS file-system for PARTITION file-name."
|
||||
((run-command-in-installer) "mkfs.xfs" "-f" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkfs.ntfs" "-F" "-f" partition)))
|
||||
|
||||
(define (create-swap-partition partition)
|
||||
"Set up swap area on PARTITION file-name."
|
||||
((run-command-in-installer) "mkswap" "-f" partition))
|
||||
(with-null-output-ports
|
||||
(invoke "mkswap" "-f" partition)))
|
||||
|
||||
(define (call-with-luks-key-file password proc)
|
||||
"Write PASSWORD in a temporary file and pass it to PROC as argument."
|
||||
@@ -1177,22 +1095,21 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise."
|
||||
(call-with-luks-key-file
|
||||
password
|
||||
(lambda (key-file)
|
||||
(installer-log-line "formatting and opening LUKS entry ~s at ~s"
|
||||
(syslog "formatting and opening LUKS entry ~s at ~s~%"
|
||||
label file-name)
|
||||
((run-command-in-installer) "cryptsetup" "-q" "luksFormat"
|
||||
file-name key-file)
|
||||
((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
|
||||
"--key-file" key-file file-name label)))))
|
||||
(system* "cryptsetup" "-q" "luksFormat" file-name key-file)
|
||||
(system* "cryptsetup" "open" "--type" "luks"
|
||||
"--key-file" key-file file-name label)))))
|
||||
|
||||
(define (luks-close user-partition)
|
||||
"Close the encrypted partition pointed by USER-PARTITION."
|
||||
(let ((label (user-partition-crypt-label user-partition)))
|
||||
(installer-log-line "closing LUKS entry ~s" label)
|
||||
((run-command-in-installer) "cryptsetup" "close" label)))
|
||||
(syslog "closing LUKS entry ~s~%" label)
|
||||
(system* "cryptsetup" "close" label)))
|
||||
|
||||
(define (format-user-partitions user-partitions)
|
||||
"Format the <user-partition> records in USER-PARTITIONS list with
|
||||
NEED-FORMATTING? field set to #t."
|
||||
NEED-FORMATING? field set to #t."
|
||||
(for-each
|
||||
(lambda (user-partition)
|
||||
(let* ((need-formatting?
|
||||
@@ -1229,10 +1146,6 @@ NEED-FORMATTING? field set to #t."
|
||||
(and need-formatting?
|
||||
(not (eq? type 'extended))
|
||||
(create-ntfs-file-system file-name)))
|
||||
((xfs)
|
||||
(and need-formatting?
|
||||
(not (eq? type 'extended))
|
||||
(create-xfs-file-system file-name)))
|
||||
((swap)
|
||||
(create-swap-partition file-name))
|
||||
(else
|
||||
@@ -1269,7 +1182,7 @@ respective mount-points."
|
||||
(file-name
|
||||
(user-partition-upper-file-name user-partition)))
|
||||
(mkdir-p target)
|
||||
(installer-log-line "mounting ~s on ~s" file-name target)
|
||||
(syslog "mounting ~s on ~s~%" file-name target)
|
||||
(mount file-name target mount-type)))
|
||||
sorted-partitions)))
|
||||
|
||||
@@ -1285,7 +1198,7 @@ respective mount-points."
|
||||
(target
|
||||
(string-append (%installer-target-dir)
|
||||
mount-point)))
|
||||
(installer-log-line "unmounting ~s" target)
|
||||
(syslog "unmounting ~s~%" target)
|
||||
(umount target)
|
||||
(when crypt-label
|
||||
(luks-close user-partition))))
|
||||
@@ -1383,9 +1296,9 @@ from (gnu system mapped-devices) and return it."
|
||||
`((bootloader-configuration
|
||||
,@(if (efi-installation?)
|
||||
`((bootloader grub-efi-bootloader)
|
||||
(targets (list ,(default-esp-mount-point))))
|
||||
(target ,(default-esp-mount-point)))
|
||||
`((bootloader grub-bootloader)
|
||||
(targets (list ,root-partition-disk))))
|
||||
(target ,root-partition-disk)))
|
||||
|
||||
;; XXX: Assume we defined the 'keyboard-layout' field of
|
||||
;; <operating-system> right above.
|
||||
@@ -1429,11 +1342,9 @@ USER-PARTITIONS, or return nothing."
|
||||
(let* ((uuids (map (lambda (file)
|
||||
(uuid->string (read-partition-uuid file)))
|
||||
swap-devices)))
|
||||
`((swap-devices
|
||||
(list ,@(map (lambda (uuid)
|
||||
`(swap-space
|
||||
(target (uuid ,uuid))))
|
||||
uuids))))))
|
||||
`((swap-devices (list ,@(map (lambda (uuid)
|
||||
`(uuid ,uuid))
|
||||
uuids))))))
|
||||
,@(if (null? encrypted-partitions)
|
||||
'()
|
||||
`((mapped-devices
|
||||
@@ -1476,6 +1387,6 @@ the devices not to be used before returning."
|
||||
(error
|
||||
(format #f (G_ "Device ~a is still in use.")
|
||||
file-name))
|
||||
(installer-log-line "Syncing ~a took ~a seconds."
|
||||
(syslog "Syncing ~a took ~a seconds.~%"
|
||||
file-name (time-second time)))))
|
||||
device-file-names)))
|
||||
|
||||
@@ -41,10 +41,7 @@
|
||||
installer-services-page
|
||||
installer-welcome-page
|
||||
installer-parameters-menu
|
||||
installer-parameters-page
|
||||
installer-dump-page
|
||||
installer-run-command
|
||||
installer-report-page))
|
||||
installer-parameters-page))
|
||||
|
||||
|
||||
;;;
|
||||
@@ -64,7 +61,7 @@
|
||||
(init installer-init)
|
||||
;; procedure: void -> void
|
||||
(exit installer-exit)
|
||||
;; procedure (key arguments) -> (action)
|
||||
;; procedure (key arguments) -> void
|
||||
(exit-error installer-exit-error)
|
||||
;; procedure void -> void
|
||||
(final-page installer-final-page)
|
||||
@@ -94,10 +91,4 @@
|
||||
;; procedure (menu-proc) -> void
|
||||
(parameters-menu installer-parameters-menu)
|
||||
;; procedure (keyboard-layout-selection) -> void
|
||||
(parameters-page installer-parameters-page)
|
||||
;; procedure (dump) -> void
|
||||
(dump-page installer-dump-page)
|
||||
;; procedure command -> bool
|
||||
(run-command installer-run-command)
|
||||
;; procedure (report) -> void
|
||||
(report-page installer-report-page))
|
||||
(parameters-page installer-parameters-page))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user