Merge remote-tracking branch 'origin/master' into core-updates

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