Browse Source

Merge branch 'master' into core-updates

gn-latest-20200725
Marius Bakke 1 year ago
parent
commit
87a40d7203
No known key found for this signature in database GPG Key ID: A2A06DF2A33A54FA
  1. 157
      .guix-authorizations
  2. 7
      Makefile.am
  3. 198
      build-aux/git-authenticate.scm
  4. 24
      doc/contributing.texi
  5. 4
      doc/guix-cookbook.texi
  6. 136
      doc/guix.texi
  7. 56
      gnu/build/bootloader.scm
  8. 45
      gnu/build/file-systems.scm
  9. 273
      gnu/build/image.scm
  10. 21
      gnu/build/install.scm
  11. 175
      gnu/build/vm.scm
  12. 45
      gnu/ci.scm
  13. 76
      gnu/image.scm
  14. 11
      gnu/local.mk
  15. 24
      gnu/packages/algebra.scm
  16. 31
      gnu/packages/audio.scm
  17. 42
      gnu/packages/bioinformatics.scm
  18. 25
      gnu/packages/check.scm
  19. 126
      gnu/packages/chemistry.scm
  20. 2108
      gnu/packages/crates-io.scm
  21. 6
      gnu/packages/databases.scm
  22. 16
      gnu/packages/emacs-xyz.scm
  23. 76
      gnu/packages/enlightenment.scm
  24. 1
      gnu/packages/gnome.scm
  25. 163
      gnu/packages/heads.scm
  26. 17
      gnu/packages/image.scm
  27. 44
      gnu/packages/less.scm
  28. 4
      gnu/packages/libusb.scm
  29. 69
      gnu/packages/linux.scm
  30. 6
      gnu/packages/lisp-xyz.scm
  31. 49
      gnu/packages/messaging.scm
  32. 51
      gnu/packages/monitoring.scm
  33. 22
      gnu/packages/music.scm
  34. 21
      gnu/packages/patches/collectd-5.11.0-noinstallvar.patch
  35. 69
      gnu/packages/patches/grocsvs-dont-use-admiral.patch
  36. 67
      gnu/packages/patches/gromacs-tinyxml2.patch
  37. 20
      gnu/packages/patches/musl-cross-locale.patch
  38. 13
      gnu/packages/patches/rust-nettle-disable-vendor.patch
  39. 48
      gnu/packages/patches/rust-nettle-sys-disable-vendor.patch
  40. 7
      gnu/packages/python-xyz.scm
  41. 28
      gnu/packages/security-token.scm
  42. 162
      gnu/packages/sequoia.scm
  43. 49
      gnu/packages/spice.scm
  44. 45
      gnu/packages/statistics.scm
  45. 4
      gnu/packages/video.scm
  46. 4
      gnu/packages/virtualization.scm
  47. 9
      gnu/packages/vpn.scm
  48. 32
      gnu/packages/xdisorg.scm
  49. 22
      gnu/packages/xorg.scm
  50. 2
      gnu/services/base.scm
  51. 106
      gnu/services/ssh.scm
  52. 50
      gnu/system.scm
  53. 532
      gnu/system/image.scm
  54. 1
      gnu/system/install.scm
  55. 3
      gnu/system/linux-initrd.scm
  56. 216
      gnu/system/vm.scm
  57. 97
      gnu/tests/install.scm
  58. 1
      guix/build/store-copy.scm
  59. 1108
      guix/openpgp.scm
  60. 13
      guix/scripts/system.scm
  61. 1345
      tests/civodul.key
  62. 25
      tests/dsa.key
  63. 10
      tests/ed25519.key
  64. 10
      tests/ed25519.sec
  65. 253
      tests/openpgp.scm
  66. 18
      tests/rsa.key

157
.guix-authorizations

@ -0,0 +1,157 @@
;; This is the list of OpenPGP keys currently authorized to sign commits in
;; this repository.
(authorizations
(version 0)
(("AD17 A21E F8AE D8F1 CC02 DBD9 F7D5 C9BF 765C 61E3"
(name "andreas"))
("2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5"
(name "ajgrf"))
("306F CB8F 2C01 C25D 29D3 0556 61EF 502E F602 52F2"
(name "alexvong1995"))
("4FB9 9F49 2B12 A365 7997 E664 8246 0C08 2A0E E98F"
(name "alezost"))
("50F3 3E2E 5B0C 3D90 0424 ABE8 9BDC F497 A4BB CC7F"
(name "ambrevar"))
("27D5 86A4 F890 0854 329F F09F 1260 E464 82E6 3562"
(name "apteryx"))
("7F73 0343 F2F0 9F3C 77BF 79D3 2E25 EE8B 6180 2BB3"
(name "arunisaac"))
(;; primary: "3B12 9196 AE30 0C3C 0E90 A26F A715 5567 3271 9948"
"9A2B 401E D001 0650 1584 BAAC 8BC4 F447 6E8A 8E00"
(name "atheia"))
(;; primary: "BE62 7373 8E61 6D6D 1B3A 08E8 A21A 0202 4881 6103"
"39B3 3C8D 9448 0D2D DCC2 A498 8B44 A0CD C7B9 56F2"
(name "bandali"))
(;; primary: "34FF 38BC D151 25A6 E340 A0B5 3453 2F9F AFCA 8B8E"
"A0C5 E352 2EF8 EF5C 64CD B7F0 FD73 CAC7 19D3 2566"
(name "bavier"))
("3774 8024 880F D3FF DCA2 C9AB 5893 6E0E 2F1B 5A4C"
(name "beffa"))
("BCF8 F737 2CED 080A 67EB 592D 2A6A D9F4 AAC2 0DF6"
(name "benwoodcroft"))
("45CC 63B8 5258 C9D5 5F34 B239 D37D 0EA7 CECC 3912"
(name "biscuolo"))
("7988 3B9F 7D6A 4DBF 3719 0367 2506 A96C CF63 0B21"
(name "boskovits"))
("DFC0 C7F7 9EE6 0CA7 AE55 5E19 6722 43C4 A03F 0EEE"
(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"))
(;; primary: "0401 7A2A 6D9A 0CCD C81D 8EC2 96AB 007F 1A7E D999"
"09CD D25B 5244 A376 78F6 EEA8 0CC5 2153 1979 91A5"
(name "carl"))
("3E89 EEE7 458E 720D 9754 E0B2 5E28 A33B 0B84 F577"
(name "cbaines"))
("3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5"
(name "civodul"))
("510A 8628 E2A7 7678 8F8C 709C 4BC0 2592 5FF8 F4D3"
(name "cwebber"))
(;; primary: "295A F991 6F46 F8A1 34B0 29DA 8086 3842 F0FE D83B"
"76CE C6B1 7274 B465 C02D B3D9 E71A 3554 2C30 BAA5"
(name "dannym"))
("B3C0 DB4D AD73 BA5D 285E 19AE 5143 0234 CEFD 87C3"
(name "davexunit"))
("8CCB A7F5 52B9 CBEA E1FB 2915 8328 C747 0FF1 D807" ;FIXME: to be confirmed!
(name "davexunit (2nd)"))
("53C4 1E6E 41AA FE55 335A CA5E 446A 2ED4 D940 BF14"
(name "daviwil"))
("6909 6DFD D702 8BED ACC5 884B C5E0 51C7 9C0B ECDB"
(name "dvc"))
("5F43 B681 0437 2F4B A898 A64B 33B9 E9FD E28D 2C23"
(name "dvc (old)"))
("A28B F40C 3E55 1372 662D 14F7 41AA E7DC CA3D 8351"
(name "efraim"))
("9157 41FE B22F A4E3 3B6E 8F8D F4C1 D391 7EAC EE93"
(name "efraim (old)"))
(;; primary: "2453 02B1 BAB1 F867 FDCA 96BC 8F3F 861F 82EB 7A9A"
"CBC5 9C66 EC27 B971 7940 6B3E 6BE8 208A DF21 FE3F"
(name "glv"))
("2219 43F4 9E9F 276F 9499 3382 BF28 6CB6 593E 5FFD"
(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"))
;; https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00229.html
("DB34 CB51 D25C 9408 156F CDD6 A12F 8797 8D70 1B99"
(name "janneke (old)"))
("1A85 8392 E331 EAFD B8C2 7FFB F3C1 A0D9 C1D6 5273"
(name "janneke"))
(;; primary: "1BA4 08C5 8BF2 0EA7 3179 635A 865D C0A3 DED9 B5D0"
"E31D 9DDE EBA5 4A14 8A20 4550 DA45 97F9 47B4 1025"
(name "jlicht"))
("83B6 703A DCCA 3B69 4BCE 2DA6 E6A5 EE3C 1946 7A0D"
(name "kkebreau"))
("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"))
("2AE3 1395 932B E642 FC0E D99C 9BED 6EDA 32E5 B0BC"
(name "lsl88"))
("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"))
("4008 6A7E 0252 9B60 31FB 8607 8354 7635 3176 9CA6"
(name "mothacehe"))
(;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B"
"F5DA 2032 4B87 3D0B 7A38 7672 0DB0 FF88 4F55 6D79"
(name "nckx"))
("E576 BFB2 CF6E B13D F571 33B9 E315 A758 4613 1564"
(name "niedzejkob"))
("ED0E F1C8 E126 BA83 1B48 5FE9 DA00 B4F0 48E9 2F2D"
(name "ngz"))
("CEF4 CB91 4856 BA38 0A20 A7E2 3008 88CB 39C6 3817"
(name "pelzflorian"))
(;; 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"))
("74D6 A930 F44B 9B84 9EA5 5606 C166 AA49 5F7F 189C"
(name "reepca"))
("BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAC"
(name "rekado"))
("0154 E1B9 1CC9 D9EF 7764 8DE7 F3A7 27DB 44FC CA36"
(name "rhelling"))
(;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
"F556 FD94 FB8F 8B87 79E3 6832 CBD0 CD51 38C1 9AFC"
(name "roelj"))
(;; From commit 2cbede5935eb6a40173bbdf30a9ad22bf7574c22 (Jan. 2020). See
;; <https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00499.html>.
"1EFB 0909 1F17 D28C CBF9 B13A 53D4 57B2 D636 EE82"
(name "roptat"))
(;; primary: "D6B0 C593 DA8C 5EDC A44C 7A58 C336 91F7 1188 B004"
"A02C 2D82 0EF4 B25B A6B5 1D90 2AC6 A5EC 1C35 7C59"
(name "samplet"))
("77DD AD2D 97F5 31BB C0F3 C7FD DFB5 EB09 AA62 5423"
(name "sleep_walker"))
("F494 72F4 7A59 00D5 C235 F212 89F9 6D48 08F3 59C7"
(name "snape"))
("9ADE 9ECF 2B19 C180 9C99 5CEA A1F4 CFCC 5283 6BAC"
(name "taylanub"))
;; https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00826.html
(;; primary: "1DD1 681F E285 E07F 11DC 0C59 2E15 A6BC D77D 54FD"
"3D2C DA58 819C 08C2 A649 D43D 5C3B 064C 724A 5726"
(name "thomasd"))
("6580 7361 3BFC C5C7 E2E4 5D45 DC51 8FC8 7F97 16AA"
(name "vagrantc"))
(;; primary: "C955 CC5D C048 7FB1 7966 40A9 199A F6A3 67E9 4ABB"
"7238 7123 8EAC EB63 4548 5857 167F 8EA5 001A FA9C"
(name "wigust"))
("FF47 8FB2 64DE 32EC 2967 25A3 DDC0 F535 8812 F8F2"
(name "wingo"))))

7
Makefile.am

@ -70,6 +70,7 @@ MODULES = \
guix/docker.scm \
guix/json.scm \
guix/records.scm \
guix/openpgp.scm \
guix/pki.scm \
guix/progress.scm \
guix/combinators.scm \
@ -415,6 +416,7 @@ SCM_TESTS = \
tests/nar.scm \
tests/networking.scm \
tests/opam.scm \
tests/openpgp.scm \
tests/packages.scm \
tests/pack.scm \
tests/pki.scm \
@ -565,6 +567,11 @@ EXTRA_DIST += \
tests/signing-key.pub \
tests/signing-key.sec \
tests/cve-sample.json \
tests/civodul.key \
tests/rsa.key \
tests/dsa.key \
tests/ed25519.key \
tests/ed25519.sec \
build-aux/config.rpath \
bootstrap \
doc/build.scm \

198
build-aux/git-authenticate.scm

@ -23,8 +23,10 @@
(use-modules (git)
(guix git)
(guix gnupg)
(guix utils)
(guix openpgp)
(guix base16)
((guix utils)
#:select (cache-directory with-atomic-file-output))
((guix build utils) #:select (mkdir-p))
(guix i18n)
(guix progress)
@ -33,6 +35,7 @@
(srfi srfi-26)
(srfi srfi-34)
(srfi srfi-35)
(rnrs bytevectors)
(rnrs io ports)
(ice-9 match)
(ice-9 format)
@ -215,7 +218,8 @@
;; Fingerprint of authorized signing keys.
(map (match-lambda
((name fingerprint)
(string-filter char-set:graphic fingerprint)))
(base16-string->bytevector
(string-downcase (string-filter char-set:graphic fingerprint)))))
%committers))
(define %commits-with-bad-signature
@ -226,93 +230,146 @@
;; Commits lacking a signature.
'())
(define-syntax-rule (with-temporary-files file1 file2 exp ...)
(call-with-temporary-output-file
(lambda (file1 port1)
(call-with-temporary-output-file
(lambda (file2 port2)
exp ...)))))
(define (commit-signing-key repo commit-id)
"Return the OpenPGP key ID that signed COMMIT-ID (an OID). Raise an
exception if the commit is unsigned or has an invalid signature."
(define (commit-signing-key repo commit-id keyring)
"Return the OpenPGP key that signed COMMIT-ID (an OID). Raise an exception
if the commit is unsigned, has an invalid signature, or if its signing key is
not in KEYRING."
(let-values (((signature signed-data)
(catch 'git-error
(lambda ()
(commit-extract-signature repo commit-id))
(lambda _
(values #f #f)))))
(if (not signature)
(raise (condition
(&message
(message (format #f (G_ "commit ~a lacks a signature")
commit-id)))))
(begin
(with-fluids ((%default-port-encoding "UTF-8"))
(with-temporary-files data-file signature-file
(call-with-output-file data-file
(cut display signed-data <>))
(call-with-output-file signature-file
(cut display signature <>))
(let-values (((status data)
(with-error-to-port (%make-void-port "w")
(lambda ()
(gnupg-verify* signature-file data-file
#:key-download 'always)))))
(match status
('invalid-signature
;; There's a signature but it's invalid.
(raise (condition
(&message
(message (format #f (G_ "signature verification failed \
(unless signature
(raise (condition
(&message
(message (format #f (G_ "commit ~a lacks a signature")
commit-id))))))
(let ((signature (string->openpgp-packet signature)))
(with-fluids ((%default-port-encoding "UTF-8"))
(let-values (((status data)
(verify-openpgp-signature signature keyring
(open-input-string signed-data))))
(match status
('bad-signature
;; There's a signature but it's invalid.
(raise (condition
(&message
(message (format #f (G_ "signature verification failed \
for commit ~a")
(oid->string commit-id)))))))
('missing-key
(raise (condition
(&message
(message (format #f (G_ "could not authenticate \
(oid->string commit-id)))))))
('missing-key
(raise (condition
(&message
(message (format #f (G_ "could not authenticate \
commit ~a: key ~a is missing")
(oid->string commit-id)
data))))))
('valid-signature
(match data
((fingerprint . user)
fingerprint)))))))))))
(define (authenticate-commit repository commit)
(oid->string commit-id)
data))))))
('good-signature data)))))))
(define (read-authorizations port)
"Read authorizations in the '.guix-authorizations' format from PORT, and
return a list of authorized fingerprints."
(match (read port)
(('authorizations ('version 0)
(((? string? fingerprints) _ ...) ...)
_ ...)
(map (lambda (fingerprint)
(base16-string->bytevector
(string-downcase (string-filter char-set:graphic fingerprint))))
fingerprints))))
(define* (commit-authorized-keys repository commit
#:optional (default-authorizations '()))
"Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
authorizations listed in its parent commits. If one of the parent commits
does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
(define (commit-authorizations commit)
(catch 'git-error
(lambda ()
(let* ((tree (commit-tree commit))
(entry (tree-entry-bypath tree ".guix-authorizations"))
(blob (blob-lookup repository (tree-entry-id entry))))
(read-authorizations
(open-bytevector-input-port (blob-content blob)))))
(lambda (key error)
(if (= (git-error-code error) GIT_ENOTFOUND)
default-authorizations
(throw key error)))))
(apply lset-intersection bytevector=?
(map commit-authorizations (commit-parents commit))))
(define (authenticate-commit repository commit keyring)
"Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
Raise an error when authentication fails."
(define id
(commit-id commit))
(define signing-key
(commit-signing-key repository id))
(commit-signing-key repository id keyring))
(unless (member signing-key %authorized-signing-keys)
(unless (member (openpgp-public-key-fingerprint signing-key)
(commit-authorized-keys repository commit
%authorized-signing-keys))
(raise (condition
(&message
(message (format #f (G_ "commit ~a not signed by an authorized \
key: ~a")
(oid->string id) signing-key))))))
(oid->string id)
(openpgp-format-fingerprint
(openpgp-public-key-fingerprint
signing-key))))))))
signing-key)
(define (load-keyring-from-blob repository oid keyring)
"Augment KEYRING with the keyring available in the blob at OID, which may or
may not be ASCII-armored."
(let* ((blob (blob-lookup repository oid))
(port (open-bytevector-input-port (blob-content blob))))
(get-openpgp-keyring (if (port-ascii-armored? port)
(open-bytevector-input-port (read-radix-64 port))
port)
keyring)))
(define (load-keyring-from-reference repository reference)
"Load the '.key' files from the tree at REFERENCE in REPOSITORY and return
an OpenPGP keyring."
(let* ((reference (reference-lookup repository reference))
(target (reference-target reference))
(commit (commit-lookup repository target))
(tree (commit-tree commit)))
(fold (lambda (name keyring)
(if (string-suffix? ".key" name)
(let ((entry (tree-entry-bypath tree name)))
(load-keyring-from-blob repository
(tree-entry-id entry)
keyring))
keyring))
%empty-keyring
(tree-list tree))))
(define* (authenticate-commits repository commits
#:key (report-progress (const #t)))
#:key
(keyring-reference "refs/heads/keyring")
(report-progress (const #t)))
"Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for
each of them. Return an alist showing the number of occurrences of each key."
(parameterize ((current-keyring (string-append (config-directory)
"/keyrings/channels/guix.kbx")))
(fold (lambda (commit stats)
(report-progress)
(let ((signer (authenticate-commit repository commit)))
(match (assoc signer stats)
(#f (cons `(,signer . 1) stats))
((_ . count) (cons `(,signer . ,(+ count 1))
(alist-delete signer stats))))))
'()
commits)))
each of them. Return an alist showing the number of occurrences of each key.
The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY."
(define keyring
(load-keyring-from-reference repository keyring-reference))
(fold (lambda (commit stats)
(report-progress)
(let ((signer (authenticate-commit repository commit keyring)))
(match (assq signer stats)
(#f (cons `(,signer . 1) stats))
((_ . count) (cons `(,signer . ,(+ count 1))
(alist-delete signer stats))))))
'()
commits))
(define commit-short-id
(compose (cut string-take <> 7) oid->string commit-id))
@ -409,7 +466,10 @@ COMMIT-ID is written to cache, though)."
(format #t (G_ "Signing statistics:~%"))
(for-each (match-lambda
((signer . count)
(format #t " ~a ~10d~%" signer count)))
(format #t " ~a ~10d~%"
(openpgp-format-fingerprint
(openpgp-public-key-fingerprint signer))
count)))
(sort stats
(match-lambda*
(((_ . count1) (_ . count2))
@ -423,7 +483,3 @@ COMMIT-ID is written to cache, though)."
(G_ "Usage: git-authenticate START [END]
Authenticate commits START to END or the current head.\n"))))))
;;; Local Variables:
;;; eval: (put 'with-temporary-files 'scheme-indent-function 2)
;;; End:

24
doc/contributing.texi

@ -1187,18 +1187,38 @@ the OpenPGP key you will use to sign commits, and giving its fingerprint
(see below). See @uref{https://emailselfdefense.fsf.org/en/}, for an
introduction to public-key cryptography with GnuPG.
@c See <https://sha-mbles.github.io/>.
Set up GnuPG such that it never uses the SHA1 hash algorithm for digital
signatures, which is known to be unsafe since 2019, for instance by
adding the following line to @file{~/.gnupg/gpg.conf} (@pxref{GPG
Esoteric Options,,, gnupg, The GNU Privacy Guard Manual}):
@example
digest-algo sha512
@end example
@item
Maintainers ultimately decide whether to grant you commit access,
usually following your referrals' recommendation.
@item
@cindex OpenPGP, signed commits
If and once you've been given access, please send a message to
@email{guix-devel@@gnu.org} to say so, again signed with the OpenPGP key
you will use to sign commits (do that before pushing your first commit).
That way, everyone can notice and ensure you control that OpenPGP key.
@c TODO: Add note about adding the fingerprint to the list of authorized
@c keys once that has stabilized.
@quotation Important
Before you can push for the first time, maintainers must:
@enumerate
@item
add your OpenPGP key to the @code{keyring} branch;
@item
add your OpenPGP fingerprint to the @file{.guix-authorizations} file of
the branch(es) you will commit to.
@end enumerate
@end quotation
@item
Make sure to read the rest of this section and... profit!

4
doc/guix-cookbook.texi

@ -1594,7 +1594,7 @@ An example configuration can look like this:
@cindex stumpwm fonts
By default StumpWM uses X11 fonts, which could be small or pixelated on
your system. You could fix this by installing StumpWM contrib Lisp
module @code{sbcl-stumpwm-ttf-fonts}, adding it to Guix system packages:
module @code{sbcl-ttf-fonts}, adding it to Guix system packages:
@lisp
(use-modules (gnu))
@ -1603,7 +1603,7 @@ module @code{sbcl-stumpwm-ttf-fonts}, adding it to Guix system packages:
(operating-system
;; …
(packages (append (list sbcl stumpwm `(,stumpwm "lib"))
sbcl-stumpwm-ttf-fonts font-dejavu %base-packages)))
sbcl-ttf-fonts font-dejavu %base-packages)))
@end lisp
Then you need to add the following code to a StumpWM configuration file

136
doc/guix.texi

@ -79,6 +79,7 @@ Copyright @copyright{} 2020 Naga Malleswari@*
Copyright @copyright{} 2020 Brice Waegeneire@*
Copyright @copyright{} 2020 R Veera Kumar@*
Copyright @copyright{} 2020 Pierre Langlois@*
Copyright @copyright{} 2020 pinoaffe@*
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
@ -1768,22 +1769,11 @@ can do so by running Emacs with the @code{--no-site-file} option
@subsection The GCC toolchain
@cindex GCC
@cindex ld-wrapper
Guix offers individual compiler packages such as @code{gcc} but if you
are in need of a complete toolchain for compiling and linking source
code what you really want is the @code{gcc-toolchain} package. This
package provides a complete GCC toolchain for C/C++ development,
including GCC itself, the GNU C Library (headers and binaries, plus
debugging symbols in the @code{debug} output), Binutils, and a linker
wrapper.
The wrapper's purpose is to inspect the @code{-L} and @code{-l} switches
passed to the linker, add corresponding @code{-rpath} arguments, and
invoke the actual linker with this new set of arguments. You can instruct the
wrapper to refuse to link against libraries not in the store by setting the
@code{GUIX_LD_WRAPPER_ALLOW_IMPURITIES} environment variable to @code{no}.
@c XXX: The contents of this section were moved under
@c ``Development'', since it makes more sense there and is not specific
@c foreign distros. Remove it from here eventually?
@xref{Packages for C Development}, for information on packages for C/C++
development.
@node Upgrading Guix
@section Upgrading Guix
@ -4681,6 +4671,7 @@ easily distributed to users who do not run Guix.
@menu
* Invoking guix environment:: Setting up development environments.
* Invoking guix pack:: Creating software bundles.
* Packages for C Development:: Working with C code with Guix.
@end menu
@node Invoking guix environment
@ -5344,6 +5335,27 @@ In addition, @command{guix pack} supports all the common build options
(@pxref{Common Build Options}) and all the package transformation
options (@pxref{Package Transformation Options}).
@node Packages for C Development
@section Packages for C Development
@cindex GCC
@cindex ld-wrapper
@cindex linker wrapper
@cindex toolchain, for C development
If you need a complete toolchain for compiling and linking C or C++
source code, use the @code{gcc-toolchain} package. This package
provides a complete GCC toolchain for C/C++ development, including GCC
itself, the GNU C Library (headers and binaries, plus debugging symbols
in the @code{debug} output), Binutils, and a linker wrapper.
The wrapper's purpose is to inspect the @code{-L} and @code{-l} switches
passed to the linker, add corresponding @code{-rpath} arguments, and
invoke the actual linker with this new set of arguments. You can instruct the
wrapper to refuse to link against libraries not in the store by setting the
@code{GUIX_LD_WRAPPER_ALLOW_IMPURITIES} environment variable to @code{no}.
@c *********************************************************************
@node Programming Interface
@ -14379,6 +14391,86 @@ Whether to enable password-based authentication.
@end table
@end deftp
@cindex AutoSSH
@deffn {Scheme Variable} autossh-service-type
This is the type for the @uref{https://www.harding.motd.ca/autossh,
AutoSSH} program that runs a copy of @command{ssh} and monitors it,
restarting it as necessary should it die or stop passing traffic.
AutoSSH can be run manually from the command-line by passing arguments
to the binary @command{autossh} from the package @code{autossh}, but it
can also be run as a Guix service. This latter use case is documented
here.
AutoSSH can be used to forward local traffic to a remote machine using
an SSH tunnel, and it respects the @file{~/.ssh/config} of the user it
is run as.
For example, to specify a service running autossh as the user
@code{pino} and forwarding all local connections to port @code{8081} to
@code{remote:8081} using an SSH tunnel, add this call to the operating
system's @code{services} field:
@lisp
(service autossh-service-type
(autossh-configuration
(user "pino")
(ssh-options (list "-T" "-N" "-L" "8081:localhost:8081" "remote.net"))))
@end lisp
@end deffn
@deftp {Data Type} autossh-configuration
This data type represents the configuration of an AutoSSH service.
@table @asis
@item @code{user} (default @code{"autossh"})
The user as which the AutoSSH service is to be run.
This assumes that the specified user exists.
@item @code{poll} (default @code{600})
Specifies the connection poll time in seconds.
@item @code{first-poll} (default @code{#f})
Specifies how many seconds AutoSSH waits before the first connection
test. After this first test, polling is resumed at the pace defined in
@code{poll}. When set to @code{#f}, the first poll is not treated
specially and will also use the connection poll specified in
@code{poll}.
@item @code{gate-time} (default @code{30})
Specifies how many seconds an SSH connection must be active before it is
considered successful.
@item @code{log-level} (default @code{1})
The log level, corresponding to the levels used by syslog---so @code{0}
is the most silent while @code{7} is the chattiest.
@item @code{max-start} (default @code{#f})
The maximum number of times SSH may be (re)started before AutoSSH exits.
When set to @code{#f}, no maximum is configured and AutoSSH may restart indefinitely.
@item @code{message} (default @code{""})
The message to append to the echo message sent when testing connections.
@item @code{port} (default @code{"0"})
The ports used for monitoring the connection. When set to @code{"0"},
monitoring is disabled. When set to @code{"@var{n}"} where @var{n} is
a positive integer, ports @var{n} and @var{n}+1 are used for
monitoring the connection, such that port @var{n} is the base
monitoring port and @code{n+1} is the echo port. When set to
@code{"@var{n}:@var{m}"} where @var{n} and @var{m} are positive
integers, the ports @var{n} and @var{n}+1 are used for monitoring the
connection, such that port @var{n} is the base monitoring port and
@var{m} is the echo port.
@item @code{ssh-options} (default @code{'()})
The list of command-line arguments to pass to @command{ssh} when it is
run. Options @option{-f} and @option{-M} are reserved for AutoSSH and
may cause undefined behaviour.
@end table
@end deftp
@defvr {Scheme Variable} %facebook-host-aliases
This variable contains a string for use in @file{/etc/hosts}
(@pxref{Host Names,,, libc, The GNU C Library Reference Manual}). Each
@ -26074,10 +26166,10 @@ pointed to by the @code{GIT_SSL_CAINFO} environment variable. Thus, you
would typically run something like:
@example
$ guix install nss-certs
$ export SSL_CERT_DIR="$HOME/.guix-profile/etc/ssl/certs"
$ export SSL_CERT_FILE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt"
$ export GIT_SSL_CAINFO="$SSL_CERT_FILE"
guix install nss-certs
export SSL_CERT_DIR="$HOME/.guix-profile/etc/ssl/certs"
export SSL_CERT_FILE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt"
export GIT_SSL_CAINFO="$SSL_CERT_FILE"
@end example
As another example, R requires the @code{CURL_CA_BUNDLE} environment
@ -26085,8 +26177,8 @@ variable to point to a certificate bundle, so you would have to run
something like this:
@example
$ guix install nss-certs
$ export CURL_CA_BUNDLE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt"
guix install nss-certs
export CURL_CA_BUNDLE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt"
@end example
For other applications you may want to look up the required environment

56
gnu/build/bootloader.scm

@ -18,8 +18,12 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build bootloader)
#:use-module (guix build utils)
#:use-module (guix utils)
#:use-module (ice-9 binary-ports)
#:export (write-file-on-device))
#:use-module (ice-9 format)
#:export (write-file-on-device
install-efi-loader))
;;;
@ -36,3 +40,53 @@
(seek output offset SEEK_SET)
(put-bytevector output bv))
#:binary #t)))))
;;;
;;; EFI bootloader.
;;;
(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":
;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
(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 (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)
(mkdir-p efi-directory)
(invoke grub-mkstandalone "-O" (car efi-targets)
"-o" (string-append efi-directory "/"
(cdr efi-targets))
;; Graft the configuration file onto the image.
(string-append "boot/grub/grub.cfg=" grub-config))))
(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."
(let ((grub-config "grub.cfg"))
(call-with-output-file grub-config
(lambda (port)
;; Create a tiny configuration file telling the embedded grub where to
;; load the real thing. XXX This is quite fragile, and can prevent
;; the image from booting when there's more than one volume with this
;; label present. Reproducible almost-UUIDs could reduce the risk
;; (not eliminate it).
(format port
"insmod part_msdos~@
search --set=root --label Guix_image~@
configfile /boot/grub/grub.cfg~%")))
(install-efi grub-efi grub-config esp)
(delete-file grub-config)))

45
gnu/build/file-systems.scm

@ -98,6 +98,47 @@ takes a bytevector and returns #t when it's a valid superblock."
(define null-terminated-latin1->string
(cut latin1->string <> zero?))
(define (bytevector-utf16-length bv)
"Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
determine where the NUL terminator is and return its index. If there's no
NUL terminator, return the size of the bytevector."
(let ((length (bytevector-length bv)))
(let loop ((index 0))
(if (< index length)
(if (zero? (bytevector-u16-ref bv index 'little))
index
(loop (+ index 2)))
length))))
(define* (bytevector->u16-list bv endianness #:optional (index 0))
(if (< index (bytevector-length bv))
(cons (bytevector-u16-ref bv index endianness)
(bytevector->u16-list bv endianness (+ index 2)))
'()))
;; The initrd doesn't have iconv data, so do the conversion ourselves.
(define (utf16->string bv endianness)
(list->string
(map integer->char
(reverse
(let loop ((remainder (bytevector->u16-list bv endianness))
(result '()))
(match remainder
(() result)
((a) (cons a result))
((a b x ...)
(if (and (>= a #xD800) (< a #xDC00) ; high surrogate
(>= b #xDC00) (< b #xE000)) ; low surrogate
(loop x (cons (+ #x10000
(* #x400 (- a #xD800))
(- b #xDC00))
result))
(loop (cons b x) (cons a result))))))))))
(define (null-terminated-utf16->string bv endianness)
(utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
endianness))
;;;
;;; Ext2 file systems.
@ -377,7 +418,9 @@ if DEVICE does not contain an F2FS file system."
(define (f2fs-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 512 characters, or
#f if SBLOCK has no volume name."
(utf16->string (sub-bytevector sblock (- (+ #x470 12) #x400) 512) %f2fs-endianness))
(null-terminated-utf16->string
(sub-bytevector sblock (- (+ #x470 12) #x400) 512)
%f2fs-endianness))
(define (check-f2fs-file-system device)
"Return the health of a F2FS file system on DEVICE."

273
gnu/build/image.scm

@ -0,0 +1,273 @@
;;; 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 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build image)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
#:use-module (guix build utils)
#:use-module (guix store database)
#:use-module (gnu build bootloader)
#:use-module (gnu build install)
#:use-module (gnu build linux-boot)
#:use-module (gnu image)
#:use-module (gnu system uuid)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (make-partition-image
genimage
initialize-efi-partition
initialize-root-partition
make-iso9660-image))
(define (sexp->partition sexp)
"Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
<partition> record."
(match sexp
((size file-system label uuid)
(partition (size size)
(file-system file-system)
(label label)
(uuid uuid)))))
(define (size-in-kib size)
"Convert SIZE expressed in bytes, to kilobytes and return it as a string."
(number->string
(inexact->exact (ceiling (/ size 1024)))))
(define (estimate-partition-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-ext4-image partition target root
#:key
(owner-uid 0)
(owner-gid 0))
"Handle the creation of EXT4 partition images. See 'make-partition-image'."
(let ((size (partition-size partition))
(label (partition-label partition))
(uuid (partition-uuid partition))
(options "lazy_itable_init=1,lazy_journal_init=1"))
(invoke "mke2fs" "-t" "ext4" "-d" root
"-L" label "-U" (uuid->string uuid)
"-E" (format #f "root_owner=~a:~a,~a"
owner-uid owner-gid options)
target
(format #f "~ak"
(size-in-kib
(if (eq? size 'guess)
(estimate-partition-size root)
size))))))
(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)))
(invoke "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
(string-append root "/" file)
(string-append "::" file))))
(scandir root))))
(define* (make-partition-image partition-sexp target root)
"Create and return the image of PARTITION-SEXP as TARGET. Use the given
ROOT directory to populate the image."
(let* ((partition (sexp->partition partition-sexp))
(type (partition-file-system partition)))
(cond
((string=? type "ext4")
(make-ext4-image partition target root))
((string=? type "vfat")
(make-vfat-image partition target root))
(else
(format (current-error-port)
"Unsupported partition type~%.")))))
(define* (genimage config target)
"Use genimage to generate in TARGET directory, the image described in the
given CONFIG file."
;; genimage needs a 'root' directory.
(mkdir "root")
(invoke "genimage" "--config" config
"--outputpath" target))
(define* (register-closure prefix closure
#:key
(deduplicate? #t) (reset-timestamps? #t)
(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.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
(register-items items
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:registration-time %epoch
#:schema schema)))
(define* (initialize-efi-partition root
#:key
bootloader-package
#:allow-other-keys)
"Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
(install-efi-loader bootloader-package root))
(define* (initialize-root-partition root
#:key
bootcfg
bootcfg-location
(deduplicate? #t)
references-graphs
(register-closures? #t)
system-directory
#:allow-other-keys)
"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.
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."
(populate-root-file-system system-directory root)
(populate-store references-graphs root)
(when register-closures?
(for-each (lambda (closure)
(register-closure root
closure
#:reset-timestamps? #t
#:deduplicate? deduplicate?))
references-graphs))
(when bootcfg
(install-boot-config bootcfg bootcfg-location root)))
(define* (make-iso9660-image xorriso grub-mkrescue-environment
grub bootcfg system-directory root target
#:key (volume-id "Guix_image") (volume-uuid #f)
register-closures? (references-graphs '())
(compression? #t))
"Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
GRUB configuration and OS-DRV as the stuff in it."
(define grub-mkrescue
(string-append grub "/bin/grub-mkrescue"))
(define grub-mkrescue-sed.sh
(string-append (getcwd) "/" "grub-mkrescue-sed.sh"))
;; Use a modified version of grub-mkrescue-sed.sh, see below.
(copy-file (string-append xorriso
"/bin/grub-mkrescue-sed.sh")
grub-mkrescue-sed.sh)
;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp
;; that is read-only inside the build container.
(substitute* grub-mkrescue-sed.sh
(("/tmp/") (string-append (getcwd) "/"))
(("MKRESCUE_SED_XORRISO_ARGS \\$x")
(format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")"
(getcwd))))
;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
;; that.
(setenv "SOURCE_DATE_EPOCH"
(number->string
(time-second
(date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
;; Our patched 'grub-mkrescue' honors this environment variable and passes
;; it to 'mformat', which makes it the serial number of 'efi.img'. This
;; allows for deterministic builds.
(setenv "GRUB_FAT_SERIAL_NUMBER"
(number->string (if volume-uuid
;; On 32-bit systems the 2nd argument must be
;; lower than 2^32.
(string-hash (iso9660-uuid->string volume-uuid)
(- (expt 2 32) 1))
#x77777777)
16))
(setenv "MKRESCUE_SED_MODE" "original")
(setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso"))
(setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
(for-each (match-lambda
((name . value) (setenv name value)))
grub-mkrescue-environment)
(apply invoke grub-mkrescue
(string-append "--xorriso=" grub-mkrescue-sed.sh)
"-o" target
(string-append "boot/grub/grub.cfg=" bootcfg)
root
"--"
;; Set all timestamps to 1.
"-volume_date" "all_file_dates" "=1"
`(,@(if compression?
'(;; ‘zisofs’ compression reduces the total image size by
;; ~60%.
"-zisofs" "level=9:block_size=128k" ; highest compression
;; It's transparent to our Linux-Libre kernel but not to
;; GRUB. Don't compress the kernel, initrd, and other
;; files read by grub.cfg, as well as common
;; already-compressed file names.
"-find" "/" "-type" "f"
;; XXX Even after "--" above, and despite documentation
;; claiming otherwise, "-or" is stolen by grub-mkrescue
;; which then chokes on it (as ‘-o …’) and dies. Don't use
;; "-or".
"-not" "-wholename" "/boot/*"
"-not" "-wholename" "/System/*"
"-not" "-name" "unicode.pf2"
"-not" "-name" "bzImage"
"-not" "-name" "*.gz" ; initrd & all man pages
"-not" "-name" "*.png" ; includes grub-image.png
"-exec" "set_filter" "--zisofs"
"--")
'())
"-volid" ,(string-upcase volume-id)
,@(if volume-uuid
`("-volume_date" "uuid"
,(string-filter (lambda (value)
(not (char=? #\- value)))
(iso9660-uuid->string
volume-uuid)))
'()))))

21
gnu/build/install.scm

@ -25,7 +25,6 @@
#:export (install-boot-config
evaluate-populate-directive
populate-root-file-system
register-closure
install-database-and-gc-roots
populate-single-profile-directory))
@ -51,9 +50,14 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
(copy-file bootcfg pivot)
(rename-file pivot target)))
(define (evaluate-populate-directive directive target)
(define* (evaluate-populate-directive directive target
#:key
(default-gid 0)
(default-uid 0))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET."
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller. If the directive matches those defaults then,
'chown' won't be run."
(let loop ((directive directive))
(catch 'system-error
(lambda ()
@ -63,7 +67,12 @@ directory TARGET."
(('directory name uid gid)
(let ((dir (string-append target name)))
(mkdir-p dir)
(chown dir uid gid)))
;; If called from a context without "root" permissions, "chown"
;; to root will fail. In that case, do not try to run "chown"
;; and assume that the file will be chowned elsewhere (when
;; interned in the store for instance).
(or (and (= uid default-uid) (= gid default-gid))
(chown dir uid gid))))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
(chmod (string-append target name) mode))
@ -98,9 +107,7 @@ directory TARGET."
(define (directives store)
"Return a list of directives to populate the root file system that will host
STORE."
`(;; Note: the store's GID is fixed precisely so we can set it here rather
;; than at activation time.
(directory ,store 0 30000 #o1775)
`((directory ,store 0 0 #o1775)
(directory "/etc")
(directory "/var/log") ; for shepherd

175
gnu/build/vm.scm

@ -27,6 +27,7 @@
#: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)
@ -57,8 +58,7 @@
estimated-partition-size
root-partition-initializer
initialize-partition-table
initialize-hard-disk
make-iso9660-image))
initialize-hard-disk))
;;; Commentary:
;;;
@ -439,159 +439,6 @@ system that is passed to 'populate-root-file-system'."
(mkdir-p directory)
(symlink bootcfg (string-append directory "/bootcfg"))))
(define (install-efi grub esp config-file)
"Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
(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":
;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
(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 (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)
(mkdir-p efi-directory)
(invoke grub-mkstandalone "-O" (car efi-targets)
"-o" (string-append efi-directory "/"
(cdr efi-targets))
;; Graft the configuration file onto the image.
(string-append "boot/grub/grub.cfg=" config-file))))
(define* (make-iso9660-image xorriso grub-mkrescue-environment
grub config-file os-drv target
#:key (volume-id "Guix_image") (volume-uuid #f)
register-closures? (closures '()))
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
GRUB configuration and OS-DRV as the stuff in it."
(define grub-mkrescue
(string-append grub "/bin/grub-mkrescue"))
(define grub-mkrescue-sed.sh
(string-append xorriso "/bin/grub-mkrescue-sed.sh"))
(define target-store
(string-append "/tmp/root" (%store-directory)))
(define items
;; The store items to add to the image.
(delete-duplicates
(append-map (lambda (closure)
(map store-info-item
(call-with-input-file (string-append "/xchg/" closure)
read-reference-graph)))
closures)))
(populate-root-file-system os-drv "/tmp/root")
(mount (%store-directory) target-store "" MS_BIND)
(when register-closures?
(display "registering closures...\n")
(for-each (lambda (closure)
(register-closure
"/tmp/root"
(string-append "/xchg/" closure)
;; TARGET-STORE is a read-only bind-mount so we shouldn't try
;; to modify it.
#:deduplicate? #f
#:reset-timestamps? #f))
closures)
(register-bootcfg-root "/tmp/root" config-file))
;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
;; that.
(setenv "SOURCE_DATE_EPOCH"
(number->string
(time-second
(date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
;; Our patched 'grub-mkrescue' honors this environment variable and passes
;; it to 'mformat', which makes it the serial number of 'efi.img'. This
;; allows for deterministic builds.
(setenv "GRUB_FAT_SERIAL_NUMBER"
(number->string (if volume-uuid
;; On 32-bit systems the 2nd argument must be
;; lower than 2^32.
(string-hash (iso9660-uuid->string volume-uuid)
(- (expt 2 32) 1))
#x77777777)
16))
(setenv "MKRESCUE_SED_MODE" "original")
(setenv "MKRESCUE_SED_XORRISO" (string-append xorriso
"/bin/xorriso"))
(setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
(for-each (match-lambda
((name . value) (setenv name value)))
grub-mkrescue-environment)
(let ((pipe
(apply open-pipe* OPEN_WRITE
grub-mkrescue
(string-append "--xorriso=" grub-mkrescue-sed.sh)
"-o" target
(string-append "boot/grub/grub.cfg=" config-file)
"etc=/tmp/root/etc"
"var=/tmp/root/var"
"run=/tmp/root/run"
;; /mnt is used as part of the installation
;; process, as the mount point for the target
;; file system, so create it.
"mnt=/tmp/root/mnt"
"-path-list" "-"
"--"
;; Set all timestamps to 1.
"-volume_date" "all_file_dates" "=1"
;; ‘zisofs’ compression reduces the total image size by ~60%.
"-zisofs" "level=9:block_size=128k" ; highest compression
;; It's transparent to our Linux-Libre kernel but not to GRUB.
;; Don't compress the kernel, initrd, and other files read by
;; grub.cfg, as well as common already-compressed file names.
"-find" "/" "-type" "f"
;; XXX Even after "--" above, and despite documentation claiming
;; otherwise, "-or" is stolen by grub-mkrescue which then chokes
;; on it (as ‘-o …’) and dies. Don't use "-or".
"-not" "-wholename" "/boot/*"
"-not" "-wholename" "/System/*"
"-not" "-name" "unicode.pf2"
"-not" "-name" "bzImage"
"-not" "-name" "*.gz" ; initrd & all man pages
"-not" "-name" "*.png" ; includes grub-image.png
"-exec" "set_filter" "--zisofs"
"--"
"-volid" (string-upcase volume-id)
(if volume-uuid
`("-volume_date" "uuid"
,(string-filter (lambda (value)
(not (char=? #\- value)))
(iso9660-uuid->string
volume-uuid)))
`()))))
;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
;; '-path-list -' option.
(for-each (lambda (item)
(format pipe "~a=~a~%"
(string-drop item 1) item))
items)
(unless (zero? (close-pipe pipe))
(error "oh, my! grub-mkrescue failed" grub-mkrescue))))
(define* (initialize-hard-disk device
#:key
bootloader-package
@ -633,30 +480,16 @@ passing it a directory name where it is mounted."
(when esp
;; Mount the ESP somewhere and install GRUB UEFI image.
(let ((mount-point (string-append target "/boot/efi"))
(grub-config (string-append target "/tmp/grub-standalone.cfg")))
(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))
;; Create a tiny configuration file telling the embedded grub
;; where to load the real thing.
;; XXX This is quite fragile, and can prevent the image from booting
;; when there's more than one volume with this label present.
;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
(call-with-output-file grub-config
(lambda (port)
(format port
"insmod part_msdos~@
search --set=root --label Guix_image~@
configfile /boot/grub/grub.cfg~%")))
(display "creating EFI firmware image...")
(install-efi grub-efi mount-point grub-config)
(install-efi-loader grub-efi mount-point)
(display "done.\n")
(delete-file grub-config)
(umount mount-point)))
;; Register BOOTCFG as a GC root.

45
gnu/ci.scm

@ -38,6 +38,7 @@
#:select (lookup-compressor self-contained-tarball))
#:use-module (gnu bootloader)
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages)
#:use-module (gnu packages gcc)
#:use-module (gnu packages base)
@ -49,6 +50,7 @@
#:use-module (gnu packages make-bootstrap)
#:use-module (gnu packages package-management)
#:use-module (gnu system)
#:use-module (gnu system image)
#:use-module (gnu system vm)
#:use-module (gnu system install)
#:use-module (gnu tests)
@ -213,32 +215,23 @@ system.")
(expt 2 20))
(if (member system %guixsd-supported-systems)
(if (member system %u-boot-systems)
(list (->job 'flash-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image
(operating-system (inherit installation-os)
(bootloader (bootloader-configuration
(bootloader u-boot-bootloader)
(target #f))))
#:disk-image-size
(* 1500 MiB))))))
(list (->job 'usb-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:disk-image-size
(* 1500 MiB)))))
(->job 'iso9660-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-disk-image installation-os
#:file-system-type
"iso9660"))))))
(list (->job 'usb-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-image
(image
(inherit efi-disk-image)
(size (* 1500 MiB))
(operating-system installation-os))))))
(->job 'iso9660-image
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(system-image
(image
(inherit iso9660-image)
(operating-system installation-os)))))))
'()))
(define channel-build-system

76
gnu/image.scm

@ -0,0 +1,76 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu image)
#:use-module (guix records)
#:export (partition
partition?
partition-device
partition-size
partition-file-system
partition-label
partition-uuid
partition-flags
partition-initializer
image
image-name
image-format
image-size
image-operating-system
image-partitions
image-compression?
image-volatile-root?
image-substitutable?))
;;;
;;; Partition record.
;;;
(define-record-type* <partition> partition make-partition
partition?
(device partition-device (default #f))
(size partition-size)
(file-system partition-file-system (default "ext4"))
(label partition-label (default #f))
(uuid partition-uuid (default #f))
(flags partition-flags (default '()))
(initializer partition-initializer (default #f)))
;;;
;;; Image record.
;;;
(define-record-type* <image>
image make-image
image?
(format image-format) ;symbol
(size image-size ;size in bytes as integer
(default 'guess))
(operating-system image-operating-system ;<operating-system>
(default #f))
(partitions image-partitions ;list of <partition>
(default '()))
(compression? image-compression? ;boolean
(default #t))
(volatile-root? image-volatile-root? ;boolean
(default #t))
(substitutable? image-substitutable? ;boolean
(default #t)))

11
gnu/local.mk

@ -62,6 +62,7 @@ GNU_SYSTEM_MODULES = \
%D%/bootloader/u-boot.scm \
%D%/bootloader/depthcharge.scm \
%D%/ci.scm \