diff options
Diffstat (limited to 'gnu/build/file-systems.scm')
| -rw-r--r-- | gnu/build/file-systems.scm | 196 |
1 files changed, 135 insertions, 61 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index c121ca5f8b..6e5c6aaf15 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. ;;; @@ -135,6 +135,51 @@ 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))) + + +;;; +;;; 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))) ;;; @@ -230,56 +275,77 @@ 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) + "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It +takes a list of PARTITION-FIELD-READERS and returns the result of the first +partition field reader that returned a value." + (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) + (partition-field-reader read-btrfs-superblock + btrfs-superblock-volume-name))) + +(define %partition-uuid-readers + (list (partition-field-reader read-ext2-superblock + ext2-superblock-uuid) + (partition-field-reader read-btrfs-superblock + btrfs-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 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 partition-label-predicate)) + +(define find-partition-by-uuid + (find-partition partition-uuid-predicate)) + +(define find-partition-by-luks-uuid + (find-partition luks-partition-uuid-predicate)) ;;; @@ -400,26 +466,34 @@ 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) + ((string-prefix? "btrfs" type) check-btrfs-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 |