[PATCH 1/4] file-systems: Refactor check-file-system.

[PATCH 1/4] file-systems: Refactor check-file-system.

[David Craven]

* gnu/build/file-systems.scm (check-file-system): Use file-system type
  specific checker.
  (check-ext2-file-system): New variable.
---
 gnu/build/file-systems.scm | 55 +++++++++++++++++++++++++++++-----------------
 1 file changed, 35 insertions(+), 20 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index c121ca5f8..d753b6b79 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -135,6 +135,14 @@ if DEVICE does not contain an ext2 file system."
 #f if SBLOCK has no volume name."
   (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
 
+(define (check-ext2-file-system device)
+  "Return the health of an ext2 file system on DEVICE."
+  (match (status:exit-val
+          (system* "e2fsck" "-v" "-p" "-C" "0" device))
+    (0 'pass)
+    (1 'errors-corrected)
+    (2 'reboot-required)
+    (_ 'fatal-error)))
 
 \f
 ;;;
@@ -400,26 +408,33 @@ the following:
 
 (define (check-file-system device type)
   "Run a file system check of TYPE on DEVICE."
-  (define fsck
-    (string-append "fsck." type))
-
-  (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
-    (match (status:exit-val status)
-      (0
-       #t)
-      (1
-       (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
-               fsck device))
-      (2
-       (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
-               fsck device)
-       (sleep 3)
-       (reboot))
-      (code
-       (format (current-error-port) "'~a' exited with code ~a on ~a; \
-spawning Bourne-like REPL~%"
-               fsck code device)
-       (start-repl %bournish-language)))))
+  (define check-procedure
+    (cond
+     ((string-prefix? "ext" type) check-ext2-file-system)
+     (else #f)))
+
+  (if check-procedure
+      (match (check-procedure device)
+        ('pass
+         #t)
+        ('errors-corrected
+         (format (current-error-port)
+                 "File system check corrected errors on ~a; continuing~%"
+                 device))
+        ('reboot-required
+         (format (current-error-port)
+                 "File system check corrected errors on ~a; rebooting~%"
+                 device)
+         (sleep 3)
+         (reboot))
+        ('fatal-error
+         (format (current-error-port)
+                 "File system check on ~a failed; spawning Bourne-like REPL~%"
+                 device)
+         (start-repl %bournish-language)))
+      (format (current-error-port)
+              "No file system check procedure for ~a; skipping~%"
+              device)))
 
 (define (mount-flags->bit-mask flags)
   "Return the number suitable for the 'flags' argument of 'mount' that
-- 
2.11.0

[PATCH 2/4] file-systems: Refactor file-system predicates.

[David Craven]

* gnu/build/file-systems.scm (partition-field-reader,
  read-partition-field, %partition-label-readers,
  %partition-uuid-readers, read-partition-label, read-partition-uuid):
  New variables.
  (partition-predicate, partition-label-predicate,
  partition-uuid-predicate, luks-partition-uuid-predicate): Use
  partition field readers.
  (find-partition-by): New variable.
  (find-partition-by-label, find-partition-by-uuid,
  find-partition-by-luks-uuid): Use find-partition-by.
---
 gnu/build/file-systems.scm | 98 ++++++++++++++++++++++++++--------------------
 1 file changed, 56 insertions(+), 42 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index d753b6b79..3a86002e1 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -238,56 +238,70 @@ warning and #f as the result."
                 (else
                  (apply throw args))))))))
 
-(define (partition-predicate read field =)
+(define (partition-field-reader read field)
+  "Return a procedure that takes a device and returns the value of a FIELD in
+the partition header or #f."
+  (let ((read (ENOENT-safe read)))
+    (lambda (device)
+      (let ((sblock (read device)))
+        (and sblock
+             (field sblock))))))
+
+(define (read-partition-field device partition-field-readers)
+  (find (cut apply <> (list device)) partition-field-readers))
+
+(define %partition-label-readers
+  (list (partition-field-reader read-ext2-superblock
+                                ext2-superblock-volume-name)))
+
+(define %partition-uuid-readers
+  (list (partition-field-reader read-ext2-superblock
+                                ext2-superblock-uuid)))
+
+(define read-partition-label
+  (cut read-partition-field <> %partition-label-readers))
+
+(define read-partition-uuid
+  (cut read-partition-field <> %partition-uuid-readers))
+
+(define (partition-predicate reader =)
   "Return a predicate that returns true if the FIELD of partition header that
 was READ is = to the given value."
-  (let ((read (ENOENT-safe read)))
-    (lambda (expected)
-      "Return a procedure that, when applied to a partition name such as \"sda1\",
-returns #t if that partition's volume name is LABEL."
-      (lambda (part)
-        (let* ((device (string-append "/dev/" part))
-               (sblock (read device)))
-          (and sblock
-               (let ((actual (field sblock)))
-                 (and actual
-                      (= actual expected)))))))))
+  (lambda (expected)
+    (lambda (device)
+      (let ((actual (reader device)))
+        (and actual
+             (= actual expected))))))
 
 (define partition-label-predicate
-  (partition-predicate read-ext2-superblock
-                       ext2-superblock-volume-name
-                       string=?))
+  (partition-predicate read-partition-label string=?))
 
 (define partition-uuid-predicate
-  (partition-predicate read-ext2-superblock
-                       ext2-superblock-uuid
-                       bytevector=?))
+  (partition-predicate read-partition-uuid bytevector=?))
 
 (define luks-partition-uuid-predicate
-  (partition-predicate read-luks-header
-                       luks-header-uuid
-                       bytevector=?))
-
-(define (find-partition-by-label label)
-  "Return the first partition found whose volume name is LABEL, or #f if none
+  (partition-predicate
+   (lambda (device)
+     (let ((header (read-luks-header device)))
+       (and header (luks-header-uuid header))))
+   bytevector=?))
+
+(define (find-partition-by predicate)
+  "Return the first partition found that matches PREDICATE, or #f if none
 were found."
-  (and=> (find (partition-label-predicate label)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
-
-(define (find-partition-by-uuid uuid)
-  "Return the first partition whose unique identifier is UUID (a bytevector),
-or #f if none was found."
-  (and=> (find (partition-uuid-predicate uuid)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
-
-(define (find-partition-by-luks-uuid uuid)
-  "Return the first LUKS partition whose unique identifier is UUID (a bytevector),
-or #f if none was found."
-  (and=> (find (luks-partition-uuid-predicate uuid)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
+  (lambda (expected)
+    (find (predicate expected)
+          (map (cut string-append "/dev/" <>)
+               (disk-partitions)))))
+
+(define find-partition-by-label
+  (find-partition-by partition-label-predicate))
+
+(define find-partition-by-uuid
+  (find-partition-by partition-uuid-predicate))
+
+(define find-partition-by-luks-uuid
+  (find-paritition-by luks-partition-uuid-predicate))
 
 \f
 ;;;
-- 
2.11.0

Re: [PATCH 2/4] file-systems: Refactor file-system predicates.

[David Craven]

Updated patch, these patches now pass the basic, installed-os,
btrfs-root-os and encrypted-root-os tests.

[PATCH] file-systems: Refactor file-system predicates.

* gnu/build/file-systems.scm (partition-field-reader,
  read-partition-field, %partition-label-readers,
  %partition-uuid-readers, read-partition-label, read-partition-uuid):
  New variables.
  (partition-predicate, partition-label-predicate,
  partition-uuid-predicate, luks-partition-uuid-predicate): Use
  partition field readers.
  (find-partition-by): New variable.
  (find-partition-by-label, find-partition-by-uuid,
  find-partition-by-luks-uuid): Use find-partition-by.
---
 gnu/build/file-systems.scm | 96 ++++++++++++++++++++++++++--------------------
 1 file changed, 55 insertions(+), 41 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index d753b6b79..2f350c668 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -238,56 +238,70 @@ warning and #f as the result."
                 (else
                  (apply throw args))))))))

-(define (partition-predicate read field =)
+(define (partition-field-reader read field)
+  "Return a procedure that takes a device and returns the value of a FIELD in
+the partition superblock or #f."
+  (let ((read (ENOENT-safe read)))
+    (lambda (device)
+      (let ((sblock (read device)))
+        (and sblock
+             (field sblock))))))
+
+(define (read-partition-field device partition-field-readers)
+  (match (filter-map (cut apply <> (list device)) partition-field-readers)
+    ((field . _) field)
+    (_ #f)))
+
+(define %partition-label-readers
+  (list (partition-field-reader read-ext2-superblock
+                                ext2-superblock-volume-name)))
+
+(define %partition-uuid-readers
+  (list (partition-field-reader read-ext2-superblock
+                                ext2-superblock-uuid)))
+
+(define read-partition-label
+  (cut read-partition-field <> %partition-label-readers))
+
+(define read-partition-uuid
+  (cut read-partition-field <> %partition-uuid-readers))
+
+(define (partition-predicate reader =)
   "Return a predicate that returns true if the FIELD of partition header that
 was READ is = to the given value."
-  (let ((read (ENOENT-safe read)))
-    (lambda (expected)
-      "Return a procedure that, when applied to a partition name such
as \"sda1\",
-returns #t if that partition's volume name is LABEL."
-      (lambda (part)
-        (let* ((device (string-append "/dev/" part))
-               (sblock (read device)))
-          (and sblock
-               (let ((actual (field sblock)))
-                 (and actual
-                      (= actual expected)))))))))
+  (lambda (expected)
+    (lambda (device)
+      (let ((actual (reader device)))
+        (and actual
+             (= actual expected))))))

 (define partition-label-predicate
-  (partition-predicate read-ext2-superblock
-                       ext2-superblock-volume-name
-                       string=?))
+  (partition-predicate read-partition-label string=?))

 (define partition-uuid-predicate
-  (partition-predicate read-ext2-superblock
-                       ext2-superblock-uuid
-                       bytevector=?))
+  (partition-predicate read-partition-uuid bytevector=?))

 (define luks-partition-uuid-predicate
-  (partition-predicate read-luks-header
-                       luks-header-uuid
-                       bytevector=?))
+  (partition-predicate
+   (partition-field-reader read-luks-header luks-header-uuid)
+   bytevector=?))

-(define (find-partition-by-label label)
-  "Return the first partition found whose volume name is LABEL, or #f if none
+(define (find-partition-by predicate)
+  "Return the first partition found that matches PREDICATE, or #f if none
 were found."
-  (and=> (find (partition-label-predicate label)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
-
-(define (find-partition-by-uuid uuid)
-  "Return the first partition whose unique identifier is UUID (a bytevector),
-or #f if none was found."
-  (and=> (find (partition-uuid-predicate uuid)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
-
-(define (find-partition-by-luks-uuid uuid)
-  "Return the first LUKS partition whose unique identifier is UUID (a
bytevector),
-or #f if none was found."
-  (and=> (find (luks-partition-uuid-predicate uuid)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
+  (lambda (expected)
+    (find (predicate expected)
+          (map (cut string-append "/dev/" <>)
+               (disk-partitions)))))
+
+(define find-partition-by-label
+  (find-partition-by partition-label-predicate))
+
+(define find-partition-by-uuid
+  (find-partition-by partition-uuid-predicate))
+
+(define find-partition-by-luks-uuid
+  (find-partition-by luks-partition-uuid-predicate))



 ;;;
-- 
2.11.0

Re: [PATCH 2/4] file-systems: Refactor file-system predicates.

[Ludovic Courtès]

David Craven <david@craven.ch> skribis:

> Updated patch, these patches now pass the basic, installed-os,
> btrfs-root-os and encrypted-root-os tests.
>
> [PATCH] file-systems: Refactor file-system predicates.
>
> * gnu/build/file-systems.scm (partition-field-reader,
>   read-partition-field, %partition-label-readers,
>   %partition-uuid-readers, read-partition-label, read-partition-uuid):
>   New variables.
>   (partition-predicate, partition-label-predicate,
>   partition-uuid-predicate, luks-partition-uuid-predicate): Use
>   partition field readers.
>   (find-partition-by): New variable.
>   (find-partition-by-label, find-partition-by-uuid,
>   find-partition-by-luks-uuid): Use find-partition-by.

[...]

> +(define (read-partition-field device partition-field-readers)

Docstring please.

> +(define (find-partition-by predicate)
> +  "Return the first partition found that matches PREDICATE, or #f if none
>  were found."

I’d call it just ‘find-partition’.

Otherwise OK to commit, provided the relevant system tests agree.  :-)

Thanks!

Ludo’.

[PATCH 3/4] gnu: Add btrfs-progs/static.

[David Craven]

* gnu/packages/linux.scm (btrfs-progs/static): New variable.
---
 gnu/packages/linux.scm | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 10dbf20a2..dcf079e64 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -2749,6 +2749,36 @@ easy administration.")
     ;; GPL2: Everything else.
     (license (list license:gpl2 license:gpl2+))))
 
+(define-public btrfs-progs/static
+  (package
+    (name "btrfs-progs-static")
+    (version (package-version btrfs-progs))
+    (source #f)
+    (build-system trivial-build-system)
+    (inputs
+     `(("btrfs-progs:static" ,btrfs-progs "static")))
+    (arguments
+     `(#:modules ((guix build utils))
+       #:builder
+       (begin
+         (use-modules (guix build utils)
+                      (ice-9 ftw)
+                      (srfi srfi-26))
+
+         (let* ((btrfs  (assoc-ref %build-inputs "btrfs-progs:static"))
+                (out    (assoc-ref %outputs "out"))
+                (source (string-append btrfs "/bin/btrfs.static"))
+                (target (string-append out "/bin/btrfs")))
+           (mkdir-p (dirname target))
+           (copy-file source target)
+           (remove-store-references target)
+           (chmod target #o555)))))
+    (home-page (package-home-page btrfs-progs))
+    (synopsis "Statically-linked btrfs command from btrfsprogs")
+    (description "This package provides statically-linked command of btrfs taken
+from the btrfsprogs package.  It is meant to be used in initrds.")
+    (license (package-license btrfs-progs))))
+
 (define-public freefall
   (package
     (name "freefall")
-- 
2.11.0

Re: [PATCH 3/4] gnu: Add btrfs-progs/static.

[Ludovic Courtès]

David Craven <david@craven.ch> skribis:

> * gnu/packages/linux.scm (btrfs-progs/static): New variable.

LGTM!

[PATCH 4/4] system: Add btrfs file system support.

[David Craven]

* gnu/build/file-systems.scm (%btrfs-endianness, btrfs-superblock?,
  read-btrfs-superblock, btrfs-superblock-uuid,
  btrfs-superblock-volume-name, check-btrfs-file-system): New variables.
  (%paritition-label-readers, %partition-uuid-readers): Add btrfs
  readers.
* gnu/system/linux-initrd.scm (linux-modules): Add btrfs modules when a
  btrfs file-system is used.
* gnu/tests/install.scm (%btrfs-root-os %btrfs-root-os-source,
  %btrfs-root-installation-script, %test-btrfs-root-os): New system
  test.
---
 gnu/build/file-systems.scm  | 46 +++++++++++++++++++++++++--
 gnu/system/linux-initrd.scm |  6 ++++
 gnu/tests/install.scm       | 77 ++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 126 insertions(+), 3 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 3a86002e1..407c97dc9 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -146,6 +146,43 @@ if DEVICE does not contain an ext2 file system."
 
 \f
 ;;;
+;;; BTRFS file systems.
+;;;
+
+;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
+
+(define-syntax %btrfs-endianness
+  ;; Endianness of btrfs file systems.
+  (identifier-syntax (endianness little)))
+
+(define (btrfs-superblock? sblock)
+  "Return #t when SBLOCK is a btrfs superblock."
+  (bytevector=? (sub-bytevector sblock 64 8)
+                (string->utf8 "_BHRfS_M")))
+
+(define (read-btrfs-superblock device)
+  "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
+if DEVICE does not contain a btrfs file system."
+  (read-superblock device 65536 4096 btrfs-superblock?))
+
+(define (btrfs-superblock-uuid sblock)
+  "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
+  (sub-bytevector sblock 32 16))
+
+(define (btrfs-superblock-volume-name sblock)
+  "Return the volume name of SBLOCK as a string of at most 256 characters, or
+#f if SBLOCK has no volume name."
+  (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
+
+(define (check-btrfs-file-system device)
+  "Return the health of a btrfs file system on DEVICE."
+  (match (status:exit-val
+          (system* "btrfs" "device" "scan"))
+    (0 'pass)
+    (_ 'fatal-error)))
+
+\f
+;;;
 ;;; LUKS encrypted devices.
 ;;;
 
@@ -252,11 +289,15 @@ the partition header or #f."
 
 (define %partition-label-readers
   (list (partition-field-reader read-ext2-superblock
-                                ext2-superblock-volume-name)))
+                                ext2-superblock-volume-name)
+        (partition-field-reader read-btrfs-superblock
+                                btrfs-superblock-volume-name)))
 
 (define %partition-uuid-readers
   (list (partition-field-reader read-ext2-superblock
-                                ext2-superblock-uuid)))
+                                ext2-superblock-uuid)
+        (partition-field-reader read-btrfs-superblock
+                                btrfs-superblock-uuid)))
 
 (define read-partition-label
   (cut read-partition-field <> %partition-label-readers))
@@ -425,6 +466,7 @@ the following:
   (define check-procedure
     (cond
      ((string-prefix? "ext" type) check-ext2-file-system)
+     ((string-prefix? "btrfs" type) check-btrfs-file-system)
      (else #f)))
 
   (if check-procedure
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index a787072ba..4a753cdad 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -197,6 +197,9 @@ loaded at boot time in the order in which they appear."
       ,@(if (find (file-system-type-predicate "vfat") file-systems)
             '("nls_iso8859-1")
             '())
+      ,@(if (find (file-system-type-predicate "btrfs") file-systems)
+            '("btrfs")
+            '())
       ,@(if volatile-root?
             '("fuse")
             '())
@@ -214,6 +217,9 @@ loaded at boot time in the order in which they appear."
                   file-systems)
             (list fatfsck/static)
             '())
+      ,@(if (find (file-system-type-predicate "btrfs") file-systems)
+            (list btrfs-progs/static)
+            '())
       ,@(if volatile-root?
             (list unionfs-fuse/static)
             '())))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 4779b80e9..86117522d 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -36,7 +36,8 @@
   #:export (%test-installed-os
             %test-separate-store-os
             %test-raid-root-os
-            %test-encrypted-os))
+            %test-encrypted-os
+            %test-btrfs-root-os))
 
 ;;; Commentary:
 ;;;
@@ -518,4 +519,78 @@ build (current-guix) and then store a couple of full system images.")
       (run-basic-test %encrypted-root-os command "encrypted-root-os"
                       #:initialization enter-luks-passphrase)))))
 
+\f
+;;;
+;;; BTRFS root file system.
+;;;
+
+(define-os-with-source (%btrfs-root-os %btrfs-root-os-source)
+  ;; The OS we want to install.
+  (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+  (operating-system
+    (host-name "liberigilo")
+    (timezone "Europe/Paris")
+    (locale "en_US.UTF-8")
+
+    (bootloader (grub-configuration (device "/dev/vdb")))
+    (kernel-arguments '("console=ttyS0"))
+    (file-systems (cons (file-system
+                          (device "my-root")
+                          (title 'label)
+                          (mount-point "/")
+                          (type "btrfs"))
+                        %base-file-systems))
+    (users (cons (user-account
+                  (name "charlie")
+                  (group "users")
+                  (home-directory "/home/charlie")
+                  (supplementary-groups '("wheel" "audio" "video")))
+                 %base-user-accounts))
+    (services (cons (service marionette-service-type
+                             (marionette-configuration
+                              (imported-modules '((gnu services herd)
+                                                  (guix combinators)))))
+                    %base-services))))
+
+(define %btrfs-root-installation-script
+  ;; Shell script of a simple installation.
+  "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+  mkpart primary ext2 1M 3M \\
+  mkpart primary ext2 3M 1G \\
+  set 1 boot on \\
+  set 1 bios_grub on
+mkfs.btrfs -L my-root /dev/vdb2
+mount /dev/vdb2 /mnt
+btrfs subvolume create /mnt/home
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-btrfs-root-os
+  (system-test
+   (name "btrfs-root-os")
+   (description
+    "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+   (value
+    (mlet* %store-monad ((image   (run-install %btrfs-root-os
+                                               %btrfs-root-os-source
+                                               #:script
+                                               %btrfs-root-installation-script))
+                         (command (qemu-command/writable-image image)))
+      (run-basic-test %btrfs-root-os command "btrfs-root-os")))))
+
 ;;; install.scm ends here
-- 
2.11.0

Re: [PATCH 4/4] system: Add btrfs file system support.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 2329 bytes --]

David Craven <david@craven.ch> skribis:

> * gnu/build/file-systems.scm (%btrfs-endianness, btrfs-superblock?,
>   read-btrfs-superblock, btrfs-superblock-uuid,
>   btrfs-superblock-volume-name, check-btrfs-file-system): New variables.
>   (%paritition-label-readers, %partition-uuid-readers): Add btrfs
>   readers.
> * gnu/system/linux-initrd.scm (linux-modules): Add btrfs modules when a
>   btrfs file-system is used.
> * gnu/tests/install.scm (%btrfs-root-os %btrfs-root-os-source,
>   %btrfs-root-installation-script, %test-btrfs-root-os): New system
>   test.

Woohoo, excellent work!

You can add “Fixes <http://bugs.gnu.org/19280>.”

> +;;; BTRFS file systems.

“Btrfs” I think.

> +;;; BTRFS root file system.

Ditto.

> +(define %btrfs-root-installation-script
> +  ;; Shell script of a simple installation.
> +  "\
> +. /etc/profile
> +set -e -x
> +guix --version
> +
> +export GUIX_BUILD_OPTIONS=--no-grafts
> +ls -l /run/current-system/gc-roots
> +parted --script /dev/vdb mklabel gpt \\
> +  mkpart primary ext2 1M 3M \\
> +  mkpart primary ext2 3M 1G \\
> +  set 1 boot on \\
> +  set 1 bios_grub on
> +mkfs.btrfs -L my-root /dev/vdb2
> +mount /dev/vdb2 /mnt
> +btrfs subvolume create /mnt/home
> +herd start cow-store /mnt
> +mkdir /mnt/etc
> +cp /etc/target-config.scm /mnt/etc/config.scm
> +guix system build /mnt/etc/config.scm
> +guix system init /mnt/etc/config.scm /mnt --no-substitutes
> +sync
> +reboot\n")
> +
> +(define %test-btrfs-root-os
> +  (system-test
> +   (name "btrfs-root-os")
> +   (description
> +    "Test basic functionality of an OS installed like one would do by hand.
> +This test is expensive in terms of CPU and storage usage since we need to
> +build (current-guix) and then store a couple of full system images.")
> +   (value
> +    (mlet* %store-monad ((image   (run-install %btrfs-root-os
> +                                               %btrfs-root-os-source
> +                                               #:script
> +                                               %btrfs-root-installation-script))
> +                         (command (qemu-command/writable-image image)))
> +      (run-basic-test %btrfs-root-os command "btrfs-root-os")))))

Great stuff.

Could you remote apply this as well:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 753 bytes --]

diff --git a/doc/guix.texi b/doc/guix.texi
index adc7fefca..e57bf6128 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6901,9 +6901,9 @@ cfdisk
 
 Once you are done partitioning the target hard disk drive, you have to
 create a file system on the relevant partition(s)@footnote{Currently
-GuixSD pretty much assumes an ext4 file system.  In particular, code
-that reads partition UUIDs and labels only works with ext4.  This will
-be fixed in the future.}.
+GuixSD only supports ext4 and btrfs file systems.  In particular, code
+that reads partition UUIDs and labels only works for these file system
+types.}.
 
 Preferably, assign partitions a label so that you can easily and
 reliably refer to them in @code{file-system} declarations (@pxref{File

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]


OK with these changes!

In the future it would be nice to have btrfs installation instructions
in the manual.

Thank you!

Ludo’.

Re: [PATCH 1/4] file-systems: Refactor check-file-system.

[David Craven]

Also requires this patch:

[PATCH] gnu: e2fsck/static: Only copy e2fsck.

* gnu/packages/linux.scm (e2fsck/static)[arguments]: Only copy e2fsck.
  [synopsis, description]: Adjust accordingly.
---
 gnu/packages/linux.scm | 23 ++++++++++-------------
 1 file changed, 10 insertions(+), 13 deletions(-)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index dcf079e64..5fb0e30c9 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -705,6 +705,8 @@ slabtop, and skill.")
     (version (package-version e2fsprogs))
     (build-system trivial-build-system)
     (source #f)
+    (inputs
+     `(("e2fsprogs" ,e2fsprogs/static)))
     (arguments
      `(#:modules ((guix build utils))
        #:builder
@@ -713,23 +715,18 @@ slabtop, and skill.")
                       (ice-9 ftw)
                       (srfi srfi-26))

-         (let ((source (string-append (assoc-ref %build-inputs "e2fsprogs")
-                                      "/sbin"))
+         (let ((e2fsck (string-append (assoc-ref %build-inputs "e2fsprogs")
+                                      "/sbin/e2fsck"))
                (bin    (string-append (assoc-ref %outputs "out") "/sbin")))
            (mkdir-p bin)
            (with-directory-excursion bin
-             (for-each (lambda (file)
-                         (copy-file (string-append source "/" file)
-                                    file)
-                         (remove-store-references file)
-                         (chmod file #o555))
-                       (scandir source (cut string-prefix? "fsck." <>))))))))
-    (inputs `(("e2fsprogs" ,e2fsprogs/static)))
-    (synopsis "Statically-linked fsck.* commands from e2fsprogs")
-    (description
-     "This package provides statically-linked command of fsck.ext[234] taken
-from the e2fsprogs package.  It is meant to be used in initrds.")
+             (copy-file e2fsck "e2fsck")
+             (remove-store-references "e2fsck")
+             (chmod "e2fsck" #o555))))))
     (home-page (package-home-page e2fsprogs))
+    (synopsis "Statically-linked e2fsck command from e2fsprogs")
+    (description "This package provides statically-linked e2fsck command taken
+from the e2fsprogs package.  It is meant to be used in initrds.")
     (license (package-license e2fsprogs))))

 (define-public extundelete
-- 
2.11.0

Re: [PATCH 1/4] file-systems: Refactor check-file-system.

[Ludovic Courtès]

David Craven <david@craven.ch> skribis:

> Also requires this patch:
>
> [PATCH] gnu: e2fsck/static: Only copy e2fsck.
>
> * gnu/packages/linux.scm (e2fsck/static)[arguments]: Only copy e2fsck.
>   [synopsis, description]: Adjust accordingly.

Same question as in my other message, but otherwise no objections.  :-)

Ludo’.

Re: [PATCH 1/4] file-systems: Refactor check-file-system.

[David Craven]

> What’s wrong with using “fsck.extN” like we did before?

fsck.extN is exactly the same binary as e2fsck when compiled
statically. This reduces the e2fsck/static package to a third of it's
previous size.

David

Re: [PATCH 1/4] file-systems: Refactor check-file-system.

[Ludovic Courtès]

David Craven <david@craven.ch> skribis:

>> What’s wrong with using “fsck.extN” like we did before?
>
> fsck.extN is exactly the same binary as e2fsck when compiled
> statically. This reduces the e2fsck/static package to a third of it's
> previous size.

Oh I see.

I fixed the crux of the problem (hard links) in commit
74d212911e6de68cdea0d2d88fcf63ca3a193846.

Ludo’.

Re: [PATCH 1/4] file-systems: Refactor check-file-system.

[Ludovic Courtès]

Hi!

David Craven <david@craven.ch> skribis:

> * gnu/build/file-systems.scm (check-file-system): Use file-system type
>   specific checker.
>   (check-ext2-file-system): New variable.

[...]

> +(define (check-ext2-file-system device)
> +  "Return the health of an ext2 file system on DEVICE."
> +  (match (status:exit-val
> +          (system* "e2fsck" "-v" "-p" "-C" "0" device))

[...]

> -  (define fsck
> -    (string-append "fsck." type))

What’s wrong with using “fsck.extN” like we did before?
(Either way is fine with me, just curious.)

Otherwise LGTM, thanks!

Ludo’.