;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 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 David C. Trudgian <dave@trudgian.net>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build file-systems)
+ #:use-module (gnu system uuid)
+ #:use-module (gnu system file-systems)
#:use-module (guix build utils)
#:use-module (guix build bournish)
- #:use-module (guix build syscalls)
+ #:use-module ((guix build syscalls)
+ #:hide (file-system-type))
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
- #:use-module (ice-9 format)
- #:use-module (ice-9 regex)
#:use-module (system foreign)
#:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1)
find-partition-by-luks-uuid
canonicalize-device-spec
- uuid->string
- string->uuid
+ read-partition-label
+ read-partition-uuid
+ read-luks-partition-uuid
bind-mount
mount-flags->bit-mask
check-file-system
- mount-file-system)
- #:re-export (mount
- umount
- MS_BIND
- MS_MOVE
- MS_RDONLY))
+ mount-file-system))
;;; Commentary:
;;;
;;;
;;; Code:
-;; 'mount' is already defined in the statically linked Guile used for initial
-;; RAM disks, in which case the bindings in (guix build syscalls) do not work
-;; (the FFI bindings do not work there). Override them in that case.
-(when (module-defined? the-scm-module 'mount)
- (set! mount (@ (guile) mount))
- (set! umount (@ (guile) umount)))
-
(define (bind-mount source target)
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
+(define (seek* fd/port offset whence)
+ "Like 'seek' but return -1 instead of throwing to 'system-error' upon
+EINVAL. This makes it easier to catch cases like OFFSET being too large for
+FD/PORT."
+ (catch 'system-error
+ (lambda ()
+ (seek fd/port offset whence))
+ (lambda args
+ (if (= EINVAL (system-error-errno args))
+ -1
+ (apply throw args)))))
+
+(define (read-superblock device offset size magic?)
+ "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
+superblock on success, and #f if no valid superblock was found. MAGIC?
+takes a bytevector and returns #t when it's a valid superblock."
+ (call-with-input-file device
+ (lambda (port)
+ (and (= offset (seek* port offset SEEK_SET))
+ (let ((block (make-bytevector size)))
+ (match (get-bytevector-n! port block 0 (bytevector-length block))
+ ((? eof-object?)
+ #f)
+ ((? number? len)
+ (and (= len (bytevector-length block))
+ (and (magic? block)
+ block)))))))))
+
+(define null-terminated-latin1->string
+ (cut latin1->string <> zero?))
+
\f
;;;
;;; Ext2 file systems.
;;;
+;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+;; TODO: Use "packed structs" from Guile-OpenGL or similar.
+
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
-;; Offset in bytes of interesting parts of an ext2 superblock. See
-;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
-;; TODO: Use "packed structs" from Guile-OpenGL or similar.
-(define-syntax %ext2-sblock-magic (identifier-syntax 56))
-(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
-(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
-(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
+(define (ext2-superblock? sblock)
+ "Return #t when SBLOCK is an ext2 superblock."
+ (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
+ (= magic #xef53)))
(define (read-ext2-superblock device)
"Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
- (define %ext2-magic
- ;; The magic bytes that identify an ext2 file system.
- #xef53)
+ (read-superblock device 1024 264 ext2-superblock?))
- (define superblock-size
- ;; Size of the interesting part of an ext2 superblock.
- 264)
+(define (ext2-superblock-uuid sblock)
+ "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
+ (sub-bytevector sblock 104 16))
- (define block
- ;; The superblock contents.
- (make-bytevector superblock-size))
+(define (ext2-superblock-volume-name sblock)
+ "Return the volume name of SBLOCK as a string of at most 16 characters, or
+#f if SBLOCK has no volume name."
+ (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
- (call-with-input-file device
- (lambda (port)
- (seek port 1024 SEEK_SET)
+(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)))
- ;; Note: work around <http://bugs.gnu.org/17466>.
- (and (eqv? superblock-size (get-bytevector-n! port block 0
- superblock-size))
- (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
- %ext2-endianness)))
- (and (= magic %ext2-magic)
- block))))))
+\f
+;;;
+;;; Btrfs file systems.
+;;;
-(define (ext2-superblock-uuid sblock)
- "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
- (let ((uuid (make-bytevector 16)))
- (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
- uuid))
+;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
-(define (ext2-superblock-volume-name sblock)
+(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
+;;;
+;;; FAT32 file systems.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
+
+(define (fat32-superblock? sblock)
+ "Return #t when SBLOCK is a fat32 superblock."
+ (bytevector=? (sub-bytevector sblock 82 8)
+ (string->utf8 "FAT32 ")))
+
+(define (read-fat32-superblock device)
+ "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
+#f if DEVICE does not contain a fat32 file system."
+ (read-superblock device 0 90 fat32-superblock?))
+
+(define (fat32-superblock-uuid sblock)
+ "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
+ (sub-bytevector sblock 67 4))
+
+(define (fat32-superblock-volume-name sblock)
+ "Return the volume name of SBLOCK as a string of at most 11 characters, or
+#f if SBLOCK has no volume name. The volume name is a latin1 string.
+Trailing spaces are trimmed."
+ (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
+
+(define (check-fat-file-system device)
+ "Return the health of a fat file system on DEVICE."
+ (match (status:exit-val
+ (system* "fsck.vfat" "-v" "-a" device))
+ (0 'pass)
+ (1 'errors-corrected)
+ (_ 'fatal-error)))
+
+\f
+;;;
+;;; FAT16 file systems.
+;;;
+
+(define (fat16-superblock? sblock)
+ "Return #t when SBLOCK is a fat16 boot record."
+ (bytevector=? (sub-bytevector sblock 54 8)
+ (string->utf8 "FAT16 ")))
+
+(define (read-fat16-superblock device)
+ "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
+#f if DEVICE does not contain a fat16 file system."
+ (read-superblock device 0 62 fat16-superblock?))
+
+(define (fat16-superblock-uuid sblock)
+ "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
+ (sub-bytevector sblock 39 4))
+
+(define (fat16-superblock-volume-name sblock)
+ "Return the volume name of SBLOCK as a string of at most 11 characters, or
+#f if SBLOCK has no volume name. The volume name is a latin1 string.
+Trailing spaces are trimmed."
+ (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
+ (lambda (c) #f))
+ #\space))
+
+\f
+;;;
+;;; ISO9660 file systems.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
+
+(define (iso9660-superblock? sblock)
+ "Return #t when SBLOCK is an iso9660 volume descriptor."
+ (bytevector=? (sub-bytevector sblock 1 6)
+ ;; Note: "\x01" is the volume descriptor format version
+ (string->utf8 "CD001\x01")))
+
+(define (read-iso9660-primary-volume-descriptor device offset)
+ "Find and read the first primary volume descriptor, starting at OFFSET.
+ Return #f if not found."
+ (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
+ (type-code (if sblock
+ (bytevector-u8-ref sblock 0)
+ (error (format #f
+ "Could not read ISO9660 primary
+volume descriptor from ~s"
+ device)))))
+ (match type-code
+ (255 #f) ; Volume Descriptor Set Terminator.
+ (1 sblock) ; Primary Volume Descriptor
+ (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
+
+(define (read-iso9660-superblock device)
+ "Return the raw contents of DEVICE's iso9660 primary volume descriptor
+as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
+ ;; Start reading at sector 16.
+ ;; Since we are not sure that the device contains an ISO9660 file system,
+ ;; we have to find that out first.
+ (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
+ (read-iso9660-primary-volume-descriptor device (* 2048 16))
+ #f)) ; Device does not contain an iso9660 file system.
+
+(define (iso9660-superblock-uuid sblock)
+ "Return the modification time of an iso9660 primary volume descriptor
+SBLOCK as a bytevector. If that's not set, returns the creation time."
+ ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
+ ;; Compare Grub: "2014-12-02-19-30-23-00".
+ ;; Compare blkid result: "2014-12-02-19-30-23-00".
+ ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
+ (let* ((creation-time (sub-bytevector sblock 813 17))
+ (modification-time (sub-bytevector sblock 830 17))
+ (unset-time (make-bytevector 17 0))
+ (time (if (bytevector=? unset-time modification-time)
+ creation-time
+ modification-time)))
+ (sub-bytevector time 0 16))) ; strips GMT offset.
+
+(define (iso9660-superblock-volume-name sblock)
+ "Return the volume name of SBLOCK as a string. The volume name is an ASCII
+string. Trailing spaces are trimmed."
+ ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
+ (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
+ (lambda (c) #f)) #\space))
+
+\f
+;;;
+;;; JFS file systems.
+;;;
+
+;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.
+
+(define-syntax %jfs-endianness
+ ;; Endianness of JFS file systems.
+ (identifier-syntax (endianness little)))
+
+(define (jfs-superblock? sblock)
+ "Return #t when SBLOCK is a JFS superblock."
+ (bytevector=? (sub-bytevector sblock 0 4)
+ (string->utf8 "JFS1")))
+
+(define (read-jfs-superblock device)
+ "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
+if DEVICE does not contain a JFS file system."
+ (read-superblock device 32768 184 jfs-superblock?))
+
+(define (jfs-superblock-uuid sblock)
+ "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
+ (sub-bytevector sblock 136 16))
+
+(define (jfs-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
- (let ((bv (make-bytevector 16)))
- (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
+ (null-terminated-latin1->string (sub-bytevector sblock 152 16)))
- ;; This is a Latin-1, nul-terminated string.
- (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
- (if (null? bytes)
- #f
- (list->string (map integer->char bytes))))))
+(define (check-jfs-file-system device)
+ "Return the health of a JFS file system on DEVICE."
+ (match (status:exit-val
+ (system* "jfs_fsck" "-p" "-v" device))
+ (0 'pass)
+ (1 'errors-corrected)
+ (2 'reboot-required)
+ (_ 'fatal-error)))
\f
;;;
;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
;; version 1.2.1 of this document.
+;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
+;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
+;; It is a WIP document.
+
(define-syntax %luks-endianness
;; Endianness of LUKS headers.
(identifier-syntax (endianness big)))
-(define-syntax %luks-header-size
- ;; Size in bytes of the LUKS header, including key slots.
- (identifier-syntax 592))
-
-(define %luks-magic
- ;; The 'LUKS_MAGIC' constant.
- (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
- (list #xba #xbe))))
-
-(define (sub-bytevector bv start size)
- "Return a copy of the SIZE bytes of BV starting from offset START."
- (let ((result (make-bytevector size)))
- (bytevector-copy! bv start result 0 size)
- result))
+(define (luks-superblock? sblock)
+ "Return #t when SBLOCK is a luks superblock."
+ (define %luks-magic
+ ;; The 'LUKS_MAGIC' constant.
+ (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
+ (list #xba #xbe))))
+ (let ((magic (sub-bytevector sblock 0 6))
+ (version (bytevector-u16-ref sblock 6 %luks-endianness)))
+ (and (bytevector=? magic %luks-magic)
+ (or (= version 1) (= version 2)))))
(define (read-luks-header file)
"Read a LUKS header from FILE. Return the raw header on success, and #f if
not valid header was found."
- (call-with-input-file file
- (lambda (port)
- (let ((header (make-bytevector %luks-header-size)))
- (match (get-bytevector-n! port header 0 (bytevector-length header))
- ((? eof-object?)
- #f)
- ((? number? len)
- (and (= len (bytevector-length header))
- (let ((magic (sub-bytevector header 0 6)) ;XXX: inefficient
- (version (bytevector-u16-ref header 6 %luks-endianness)))
- (and (bytevector=? magic %luks-magic)
- (= version 1)
- header)))))))))
+ ;; Size in bytes of the LUKS binary header, which includes key slots in
+ ;; LUKS1. In LUKS2 the binary header is partially backward compatible, so
+ ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
+ ;; not part of this header in LUKS2, but are included in the JSON metadata
+ ;; area that follows.
+ (read-superblock file 0 592 luks-superblock?))
(define (luks-header-uuid header)
"Return the LUKS UUID from HEADER, as a 16-byte bytevector."
(define (disk-partitions)
"Return the list of device names corresponding to valid disk partitions."
- (define (last-character str)
- (string-ref str (- (string-length str) 1)))
-
(define (partition? name major minor)
- ;; Select device names that end in a digit, like libblkid's 'probe_all'
- ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition"
- ;; doesn't work for partitions coming from mapped devices.
- (and (char-set-contains? char-set:digit (last-character name))
- (> major 2))) ;ignore RAM disks and floppy disks
+ ;; grub-mkrescue does some funny things for EFI support which
+ ;; makes it a lot more difficult than one would expect to support
+ ;; booting an ISO-9660 image from an USB flash drive.
+ ;; For example there's a buggy (too small) hidden partition in it
+ ;; which Linux mounts and then proceeds to fail while trying to
+ ;; fall off the edge.
+ ;; In any case, partition tables are supposed to be optional so
+ ;; here we allow checking entire disks for file systems, too.
+ (> major 2)) ;ignore RAM disks and floppy disks
(call-with-input-file "/proc/partitions"
(lambda (port)
#f)
((= ENOMEDIUM errno) ;for removable media
#f)
+ ((= EIO errno) ;unreadable hardware like audio CDs
+ (format (current-error-port)
+ "warning: failed to read from device '~a'~%" device)
+ #f)
(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-iso9660-superblock
+ iso9660-superblock-volume-name)
+ (partition-field-reader read-ext2-superblock
+ ext2-superblock-volume-name)
+ (partition-field-reader read-btrfs-superblock
+ btrfs-superblock-volume-name)
+ (partition-field-reader read-fat32-superblock
+ fat32-superblock-volume-name)
+ (partition-field-reader read-fat16-superblock
+ fat16-superblock-volume-name)
+ (partition-field-reader read-jfs-superblock
+ jfs-superblock-volume-name)))
+
+(define %partition-uuid-readers
+ (list (partition-field-reader read-iso9660-superblock
+ iso9660-superblock-uuid)
+ (partition-field-reader read-ext2-superblock
+ ext2-superblock-uuid)
+ (partition-field-reader read-btrfs-superblock
+ btrfs-superblock-uuid)
+ (partition-field-reader read-fat32-superblock
+ fat32-superblock-uuid)
+ (partition-field-reader read-fat16-superblock
+ fat16-superblock-uuid)
+ (partition-field-reader read-jfs-superblock
+ jfs-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 luks-partition-field-reader
+ (partition-field-reader read-luks-header luks-header-uuid))
+
+(define read-luks-partition-uuid
+ (cut read-partition-field <> (list luks-partition-field-reader)))
+
+(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 uuid=?))
-(define partition-luks-uuid-predicate
- (partition-predicate read-luks-header
- luks-header-uuid
- bytevector=?))
+(define luks-partition-uuid-predicate
+ (partition-predicate luks-partition-field-reader uuid=?))
-(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 (partition-luks-uuid-predicate uuid)
- (disk-partitions))
- (cut string-append "/dev/" <>)))
+ (lambda (expected)
+ (find (predicate expected)
+ (map (cut string-append "/dev/" <>)
+ (disk-partitions)))))
-\f
-;;;
-;;; UUIDs.
-;;;
+(define find-partition-by-label
+ (find-partition partition-label-predicate))
-(define-syntax %network-byte-order
- (identifier-syntax (endianness big)))
+(define find-partition-by-uuid
+ (find-partition partition-uuid-predicate))
-(define (uuid->string uuid)
- "Convert UUID, a 16-byte bytevector, to its string representation, something
-like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
- ;; See <https://tools.ietf.org/html/rfc4122>.
- (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
- (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
- (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
- (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
- (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
- (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
- time-low time-mid time-hi clock-seq node)))
-
-(define %uuid-rx
- ;; The regexp of a UUID.
- (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
-
-(define (string->uuid str)
- "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
-return its contents as a 16-byte bytevector. Return #f if STR is not a valid
-UUID representation."
- (and=> (regexp-exec %uuid-rx str)
- (lambda (match)
- (letrec-syntax ((hex->number
- (syntax-rules ()
- ((_ index)
- (string->number (match:substring match index)
- 16))))
- (put!
- (syntax-rules ()
- ((_ bv index (number len) rest ...)
- (begin
- (bytevector-uint-set! bv index number
- (endianness big) len)
- (put! bv (+ index len) rest ...)))
- ((_ bv index)
- bv))))
- (let ((time-low (hex->number 1))
- (time-mid (hex->number 2))
- (time-hi (hex->number 3))
- (clock-seq (hex->number 4))
- (node (hex->number 5))
- (uuid (make-bytevector 16)))
- (put! uuid 0
- (time-low 4) (time-mid 2) (time-hi 2)
- (clock-seq 2) (node 6)))))))
+(define find-partition-by-luks-uuid
+ (find-partition luks-partition-uuid-predicate))
\f
-(define* (canonicalize-device-spec spec #:optional (title 'any))
- "Return the device name corresponding to SPEC. TITLE is a symbol, one of
-the following:
-
- • 'device', in which case SPEC is known to designate a device node--e.g.,
- \"/dev/sda1\";
- • 'label', in which case SPEC is known to designate a partition label--e.g.,
- \"my-root-part\";
- • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
- designating a partition;
- • 'any', in which case SPEC can be anything.
-"
+(define (canonicalize-device-spec spec)
+ "Return the device name corresponding to SPEC, which can be a <uuid>, a
+<file-system-label>, or a string (typically a /dev file name)."
(define max-trials
;; Number of times we retry partition label resolution, 1 second per
;; trial. Note: somebody reported a delay of 16 seconds (!) before their
;; this long.
20)
- (define canonical-title
- ;; The realm of canonicalization.
- (if (eq? title 'any)
- (if (string? spec)
- ;; The "--root=SPEC" kernel command-line option always provides a
- ;; string, but the string can represent a device, a UUID, or a
- ;; label. So check for all three.
- (cond ((string-prefix? "/" spec) 'device)
- ((string->uuid spec) 'uuid)
- (else 'label))
- 'uuid)
- title))
-
(define (resolve find-partition spec fmt)
(let loop ((count 0))
(let ((device (find-partition spec)))
(sleep 1)
(loop (+ 1 count))))))))
- (case canonical-title
- ((device)
- ;; Nothing to do.
- spec)
- ((label)
+ (match spec
+ ((? string?)
+ ;; Nothing to do, but wait until SPEC shows up.
+ (resolve identity spec identity))
+ ((? file-system-label?)
;; Resolve the label.
- (resolve find-partition-by-label spec identity))
- ((uuid)
+ (resolve find-partition-by-label
+ (file-system-label->string spec)
+ identity))
+ ((? uuid?)
(resolve find-partition-by-uuid
- (if (string? spec)
- (string->uuid spec)
- spec)
- uuid->string))
- (else
- (error "unknown device title" title))))
+ (uuid-bytevector spec)
+ uuid->string))))
(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)
+ ((string-suffix? "fat" type) check-fat-file-system)
+ ((string-prefix? "jfs" type) check-jfs-file-system)
+ ((string-prefix? "nfs" type) (const 'pass))
+ (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~%"
+ device)
+
+ ;; Spawn a REPL only if someone would be able to interact with it.
+ (when (isatty? (current-input-port))
+ (format (current-error-port) "Spawning Bourne-like REPL.~%")
+
+ ;; 'current-output-port' is typically connected to /dev/klog (in
+ ;; PID 1), but here we want to make sure we talk directly to the
+ ;; user.
+ (with-output-to-file "/dev/console"
+ (lambda ()
+ (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
(logior MS_NODEV (loop rest)))
(('no-exec rest ...)
(logior MS_NOEXEC (loop rest)))
+ (('no-atime rest ...)
+ (logior MS_NOATIME (loop rest)))
+ (('strict-atime rest ...)
+ (logior MS_STRICTATIME (loop rest)))
+ (('lazy-time rest ...)
+ (logior MS_LAZYTIME (loop rest)))
(()
0))))
-(define (regular-file? file-name)
- "Return #t if FILE-NAME is a regular file."
- (eq? (stat:type (stat file-name)) 'regular))
-
-(define* (mount-file-system spec #:key (root "/root"))
- "Mount the file system described by SPEC under ROOT. SPEC must have the
-form:
-
- (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
-
-DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
-FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
-run a file system check."
+(define* (mount-file-system fs #:key (root "/root"))
+ "Mount the file system described by FS, a <file-system> object, under ROOT."
(define (mount-nfs source mount-point type flags options)
(let* ((idx (string-rindex source #\:))
(if options
(string-append "," options)
"")))))
- (match spec
- ((source title mount-point type (flags ...) options check?)
- (let ((source (canonicalize-device-spec source title))
- (mount-point (string-append root "/" mount-point))
- (flags (mount-flags->bit-mask flags)))
- (when check?
- (check-file-system source type))
-
- ;; Create the mount point. Most of the time this is a directory, but
- ;; in the case of a bind mount, a regular file may be needed.
- (if (and (= MS_BIND (logand flags MS_BIND))
- (regular-file? source))
- (unless (file-exists? mount-point)
- (mkdir-p (dirname mount-point))
- (call-with-output-file mount-point (const #t)))
- (mkdir-p mount-point))
-
- (cond
- ((string-prefix? "nfs" type)
- (mount-nfs source mount-point type flags options))
- (else
- (mount source mount-point type flags options)))
-
- ;; For read-only bind mounts, an extra remount is needed, as per
- ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
- (when (and (= MS_BIND (logand flags MS_BIND))
- (= MS_RDONLY (logand flags MS_RDONLY)))
- (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
- (mount source mount-point type flags #f)))))))
+ (let ((type (file-system-type fs))
+ (options (file-system-options fs))
+ (source (canonicalize-device-spec (file-system-device fs)))
+ (mount-point (string-append root "/"
+ (file-system-mount-point fs)))
+ (flags (mount-flags->bit-mask (file-system-flags fs))))
+ (when (file-system-check? fs)
+ (check-file-system source type))
+
+ ;; Create the mount point. Most of the time this is a directory, but
+ ;; in the case of a bind mount, a regular file or socket may be needed.
+ (if (and (= MS_BIND (logand flags MS_BIND))
+ (not (file-is-directory? source)))
+ (unless (file-exists? mount-point)
+ (mkdir-p (dirname mount-point))
+ (call-with-output-file mount-point (const #t)))
+ (mkdir-p mount-point))
+
+ (cond
+ ((string-prefix? "nfs" type)
+ (mount-nfs source mount-point type flags options))
+ (else
+ (mount source mount-point type flags options)))
+
+ ;; For read-only bind mounts, an extra remount is needed, as per
+ ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
+ (when (and (= MS_BIND (logand flags MS_BIND))
+ (= MS_RDONLY (logand flags MS_RDONLY)))
+ (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
+ (mount source mount-point type flags #f)))))
;;; file-systems.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff