aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/bootloader.scm7
-rw-r--r--gnu/build/chromium-extension.scm192
-rw-r--r--gnu/build/file-systems.scm105
-rw-r--r--gnu/build/image.scm10
-rw-r--r--gnu/build/linux-boot.scm59
-rw-r--r--gnu/build/linux-initrd.scm13
-rw-r--r--gnu/build/shepherd.scm16
7 files changed, 382 insertions, 20 deletions
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index 5ec839f902..3916930c89 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -38,10 +38,13 @@
(lambda (input)
(let ((bv (get-bytevector-n input size)))
(call-with-port
+ ;; Do not use "call-with-output-file" that would truncate the file.
(open-file-output-port device
- (file-options no-truncate no-create)
+ (file-options no-truncate no-fail)
(buffer-mode block)
- (native-transcoder))
+ ;; Use the binary-friendly ISO-8859-1
+ ;; encoding.
+ (make-transcoder (latin-1-codec)))
(lambda (output)
(seek output offset SEEK_SET)
(put-bytevector output bv)))))))
diff --git a/gnu/build/chromium-extension.scm b/gnu/build/chromium-extension.scm
new file mode 100644
index 0000000000..d65df09f37
--- /dev/null
+++ b/gnu/build/chromium-extension.scm
@@ -0,0 +1,192 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Marius Bakke <marius@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 build chromium-extension)
+ #:use-module (gcrypt base16)
+ #:use-module ((gcrypt hash) #:prefix hash:)
+ #:use-module (ice-9 iconv)
+ #:use-module (guix gexp)
+ #:use-module (guix packages)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages check)
+ #:use-module (gnu packages chromium)
+ #:use-module (gnu packages gnupg)
+ #:use-module (gnu packages tls)
+ #:use-module (gnu packages xorg)
+ #:use-module (guix build-system trivial)
+ #:export (make-chromium-extension))
+
+;;; Commentary:
+;;;
+;;; Tools to deal with Chromium extensions.
+;;;
+;;; Code:
+
+(define (make-signing-key seed)
+ "Return a derivation for a deterministic PKCS #8 private key using SEED."
+
+ (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
+in PACKAGE-OUTPUT of PACKAGE. The extension will be signed with SIGNING-KEY."
+ (define name (package-name package))
+ (define version (package-version package))
+
+ (with-imported-modules '((guix build utils))
+ (computed-file
+ (string-append name "-" version ".crx")
+ #~(begin
+ ;; This is not great. We pull Xorg and Chromium just to Zip and
+ ;; sign an extension. This should be implemented with something
+ ;; lighter. (TODO: where is the CRXv3 documentation..?)
+ (use-modules (guix build utils))
+ (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
+ (xvfb #$(file-append xorg-server "/bin/Xvfb"))
+ (packdir "/tmp/extension"))
+ (mkdir-p (dirname packdir))
+ (copy-recursively (ungexp package package-output) packdir)
+ (system (string-append xvfb " :1 &"))
+ (setenv "DISPLAY" ":1")
+ (sleep 2) ;give Xorg some time to initialize...
+ ;; Chromium stores the current time in the .crx Zip archive.
+ ;; Use a fixed timestamp for deterministic behavior.
+ ;; FIXME (core-updates): faketime is missing an absolute reference
+ ;; to 'date', hence the need to set PATH.
+ (setenv "PATH" #$(file-append coreutils "/bin"))
+ (invoke #$(file-append libfaketime "/bin/faketime")
+ "2000-01-01 00:00:00"
+ chromium
+ "--user-data-dir=/tmp/signing-profile"
+ (string-append "--pack-extension=" packdir)
+ (string-append "--pack-extension-key=" #$signing-key))
+ (copy-file (string-append packdir ".crx") #$output)))
+ #:local-build? #t)))
+
+(define* (crx->chromium-json crx version)
+ "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."
+ ;; See chrome/browser/extensions/external_provider_impl.cc and
+ ;; extensions/common/extension.h for documentation on the JSON format.
+ (computed-file "extension.json"
+ #~(call-with-output-file #$output
+ (lambda (port)
+ (format port "{
+ \"external_crx\": \"~a\",
+ \"external_version\": \"~a\"
+}
+"
+ #$crx #$version)))
+ #:local-build? #t))
+
+
+(define (signing-key->public-der key)
+ "Return a derivation for a file containing the public key of KEY in DER
+format."
+ (computed-file "der"
+ #~(system* #$(file-append gnutls "/bin/certtool")
+ "--load-privkey" #$key
+ "--pubkey-info"
+ "--outfile" #$output
+ "--outder")
+ #:local-build? #t))
+
+(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))
+
+ (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 p)
+ (name (string-append pname "-chromium"))
+ (source #f)
+ (build-system trivial-build-system)
+ (native-inputs '())
+ (inputs
+ `(("extension" ,(chromium-json->profile-object
+ (crx->chromium-json (make-crx signing-key p output)
+ version)
+ signing-key))))
+ (propagated-inputs '())
+ (outputs '("out"))
+ (arguments
+ '(#:modules ((guix build utils))
+ #:builder
+ (begin
+ (use-modules (guix build utils))
+ (copy-recursively (assoc-ref %build-inputs "extension")
+ (assoc-ref %outputs "out"))))))))
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 734d648575..b762e82ad2 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,9 +1,9 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020 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 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>
;;;
@@ -181,6 +181,98 @@ if DEVICE does not contain an ext2 file system."
;;;
+;;; Linux swap.
+;;;
+
+;; Linux "swap space" is not a file system but it has a UUID and volume name,
+;; like actual file systems, and we want to be able to look up swap partitions
+;; by UUID and by label.
+
+(define %linux-swap-magic
+ (string->utf8 "SWAPSPACE2"))
+
+;; Like 'PAGE_SIZE' in Linux, arch/x86/include/asm/page.h.
+;; XXX: This is always 4K on x86_64, i386, and ARMv7. However, on AArch64,
+;; this is determined by 'CONFIG_ARM64_PAGE_SHIFT' in the kernel, which is 12
+;; by default (4K) but can be 14 or 16.
+(define %page-size 4096)
+
+(define (linux-swap-superblock? sblock)
+ "Return #t when SBLOCK is an linux-swap superblock."
+ (and (= (bytevector-length sblock) %page-size)
+ (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
+ %linux-swap-magic)))
+
+(define (read-linux-swap-superblock device)
+ "Return the raw contents of DEVICE's linux-swap superblock as a bytevector, or #f
+if DEVICE does not contain an linux-swap file system."
+ (read-superblock device 0 %page-size linux-swap-superblock?))
+
+;; See 'union swap_header' in 'include/linux/swap.h'.
+
+(define (linux-swap-superblock-uuid sblock)
+ "Return the UUID of Linux-swap superblock SBLOCK as a 16-byte bytevector."
+ (sub-bytevector sblock (+ 1024 4 4 4) 16))
+
+(define (linux-swap-superblock-volume-name sblock)
+ "Return the label of Linux-swap superblock SBLOCK as a string."
+ (null-terminated-latin1->string
+ (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))
+
+
+;;;
+;;; Bcachefs file systems.
+;;;
+
+;; <https://evilpiepirate.org/git/bcachefs-tools.git/tree/libbcachefs/bcachefs_format.h>
+
+(define-syntax %bcachefs-endianness
+ ;; Endianness of bcachefs file systems.
+ (identifier-syntax (endianness little)))
+
+(define (bcachefs-superblock? sblock)
+ "Return #t when SBLOCK is an bcachefs superblock."
+ (bytevector=? (sub-bytevector sblock 24 16)
+ #vu8(#xc6 #x85 #x73 #xf6 #x4e #x1a #x45 #xca
+ #x82 #x65 #xf5 #x7f #x48 #xba #x6d #x81)))
+
+(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."
+ ;; 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 UUID’, you probably don't want this
+ ;; 56 16 user_uuid ← ‘external UUID’, the one by which to mount
+ ;; 72 32 label
+ ;; … 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)
+ "Return the external UUID of bcachefs superblock SBLOCK as a 16-byte
+bytevector."
+ (sub-bytevector sblock 56 16))
+
+(define (bcachefs-superblock-volume-name sblock)
+ "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)
+ "Return the health of a bcachefs file system on DEVICE."
+ (match (status:exit-val
+ (apply system* "bcachefs" "fsck" "-p" "-v"
+ ;; Make each multi-device member a separate argument.
+ (string-split device #\:)))
+ (0 'pass)
+ (1 'errors-corrected)
+ (2 'reboot-required)
+ (_ 'fatal-error)))
+
+
+;;;
;;; Btrfs file systems.
;;;
@@ -596,6 +688,10 @@ partition field reader that returned a value."
iso9660-superblock-volume-name)
(partition-field-reader read-ext2-superblock
ext2-superblock-volume-name)
+ (partition-field-reader read-linux-swap-superblock
+ linux-swap-superblock-volume-name)
+ (partition-field-reader read-bcachefs-superblock
+ bcachefs-superblock-volume-name)
(partition-field-reader read-btrfs-superblock
btrfs-superblock-volume-name)
(partition-field-reader read-fat32-superblock
@@ -612,6 +708,10 @@ partition field reader that returned a value."
iso9660-superblock-uuid)
(partition-field-reader read-ext2-superblock
ext2-superblock-uuid)
+ (partition-field-reader read-linux-swap-superblock
+ linux-swap-superblock-uuid)
+ (partition-field-reader read-bcachefs-superblock
+ bcachefs-superblock-external-uuid)
(partition-field-reader read-btrfs-superblock
btrfs-superblock-uuid)
(partition-field-reader read-fat32-superblock
@@ -719,6 +819,7 @@ containing ':/')."
(define check-procedure
(cond
((string-prefix? "ext" type) check-ext2-file-system)
+ ((string-prefix? "bcachefs" type) check-bcachefs-file-system)
((string-prefix? "btrfs" type) check-btrfs-file-system)
((string-suffix? "fat" type) check-fat-file-system)
((string-prefix? "jfs" type) check-jfs-file-system)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index ff63039c16..463b7fccc7 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -118,16 +118,16 @@ ROOT directory to populate the image."
((string=? type "vfat")
(make-vfat-image partition target root))
(else
- (format (current-error-port)
- "Unsupported partition type~%.")))))
+ (raise (condition
+ (&message
+ (message "unsupported partition type"))))))))
(define (convert-disk-image image format output)
"Convert IMAGE to OUTPUT according to the given FORMAT."
(case format
((compressed-qcow2)
- (begin
- (invoke "qemu-img" "convert" "-c" "-f" "raw"
- "-O" "qcow2" image output)))
+ (invoke "qemu-img" "convert" "-c" "-f" "raw"
+ "-O" "qcow2" image output))
(else
(copy-file image output))))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 32e3536039..bfaac9ec1f 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -1,5 +1,6 @@
;;; 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, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;;
@@ -110,6 +111,58 @@ OPTION doesn't appear in ARGUMENTS."
(substring arg (+ 1 (string-index arg #\=)))))
arguments)))
+(define (resume-if-hibernated device)
+ "Resume from hibernation if possible. This is safe ONLY if no on-disk file
+systems have been mounted; calling it later risks severe file system corruption!
+See <Documentation/swsusp.txt> in the kernel source directory. This is the
+caller's responsibility, as is catching exceptions if resumption was supposed to
+happen but didn't.
+
+Resume only from DEVICE if it's a string. If it's #f, use the kernel's default
+hibernation device (CONFIG_PM_STD_PARTITION). Never return if resumption
+succeeds. Return nothing otherwise. The kernel logs any details to dmesg."
+
+ (define (string->major:minor string)
+ "Return a string with MAJOR:MINOR numbers of the device specified by STRING"
+
+ ;; The "resume=" kernel command-line option always provides a string, which
+ ;; can represent a device, a UUID, or a label. Check for all three.
+ (let* ((spec (cond ((string-prefix? "/" string) string)
+ ((uuid string) => identity)
+ (else (file-system-label string))))
+ ;; XXX The kernel's swsusp_resume_can_resume() waits if ‘resumewait’
+ ;; 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)))
+ ;; 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.
+ (let ((resume "/sys/power/resume"))
+ (when (file-exists? resume) ; this kernel supports hibernation
+ ;; Honour the kernel's default device (only) if none other was given.
+ (let ((major:minor (if device
+ (or (false-if-exception (string->major:minor
+ device))
+ ;; We can't parse it. Maybe the kernel can.
+ device)
+ (let ((default (call-with-input-file resume
+ read-line)))
+ ;; Don't waste time echoing 0:0 to /sys.
+ (if (string=? "0:0" default)
+ #f
+ default)))))
+ (when major:minor
+ (call-with-output-file resume ; may throw an ‘Invalid argument’
+ (cut display major:minor <>))))))) ; may never return
+
(define* (make-disk-device-nodes base major #:optional (minor 0))
"Make the block device nodes around BASE (something like \"/root/dev/sda\")
with the given MAJOR number, starting with MINOR."
@@ -507,6 +560,12 @@ upon error."
(load-linux-modules-from-directory linux-modules
linux-module-directory)
+ (unless (member "noresume" args)
+ ;; Try to resume immediately after loading (storage) modules
+ ;; but before any on-disk file systems have been mounted.
+ (false-if-exception ; failure is not fatal
+ (resume-if-hibernated (find-long-option "resume" args))))
+
(when keymap-file
(let ((status (system* "loadkeys" keymap-file)))
(unless (zero? status)
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index ea7de58553..99796adba6 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,8 +39,9 @@
#:key
(compress? #t)
(gzip "gzip"))
- "Write a cpio archive containing DIRECTORY to file OUTPUT. When
-COMPRESS? is true, compress it using GZIP. On success, return OUTPUT."
+ "Write a cpio archive containing DIRECTORY to file OUTPUT, with reset
+timestamps in the archive. When COMPRESS? is true, compress it using GZIP.
+On success, return OUTPUT."
;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
;; before the files that are inside of it: "The Linux kernel cpio
@@ -141,12 +142,6 @@ REFERENCES-GRAPHS."
(symlink (string-append guile "/bin/guile") "proc/self/exe")
(readlink "proc/self/exe")
- ;; Reset the timestamps of all the files that will make it in the initrd.
- (for-each (lambda (file)
- (unless (eq? 'symlink (stat:type (lstat file)))
- (utime file 0 0 0 0)))
- (find-files "." ".*"))
-
(write-cpio-archive output "." #:gzip gzip))
;; Make sure directories are writable so we can delete files.
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index 91646288d5..d7b858dea4 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -21,7 +21,6 @@
#:use-module (gnu system file-systems)
#:use-module (gnu build linux-container)
#:use-module (guix build utils)
- #:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@@ -199,11 +198,24 @@ namespace, in addition to essential bind-mounts such /proc."
"This is a variant of 'fork+exec-command' procedure, that joins the
namespaces of process PID beforehand. If there is no support for containers,
on Hurd systems for instance, fallback to direct forking."
+ (define (strip-pid args)
+ ;; TODO: Replace with 'strip-keyword-arguments' when that no longer pulls
+ ;; in (guix config).
+ (let loop ((args args)
+ (result '()))
+ (match args
+ (()
+ (reverse result))
+ ((#:pid _ . rest)
+ (loop rest result))
+ ((head . rest)
+ (loop rest (cons head result))))))
+
(let ((container-support?
(file-exists? "/proc/self/ns"))
(fork-proc (lambda ()
(apply fork+exec-command command
- (strip-keyword-arguments '(#:pid) args)))))
+ (strip-pid args)))))
(if container-support?
(container-excursion* pid fork-proc)
(fork-proc))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-22 05:43:59 +0000