mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
linux-initrd: Allow use of volume labels in 'file-system' declarations.
* guix/build/linux-initrd.scm (%ext2-endianness, %ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name): New macros. (read-ext2-superblock, ext2-superblock-uuid, ext2-superblock-volume-name, disk-partitions, partition-label-predicate, find-partition-by-label, canonicalize-device-spec): New procedures. (mount-file-system): Use 'canonicalize-device-spec' on SOURCE. (boot-system): Likewise for ROOT. * doc/guix.texi (Using the Configuration System): Adjust 'file-system' declaration accordingly.
This commit is contained in:
parent
bd3fc08c4d
commit
85a83edb36
2 changed files with 115 additions and 3 deletions
|
@ -3130,7 +3130,7 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
|
|||
(bootloader (grub-configuration
|
||||
(device "/dev/sda")))
|
||||
(file-systems (list (file-system
|
||||
(device "/dev/disk/by-label/root")
|
||||
(device "/dev/sda1") ; or partition label
|
||||
(mount-point "/")
|
||||
(type "ext3"))))
|
||||
(users (list (user-account
|
||||
|
|
|
@ -18,12 +18,14 @@
|
|||
|
||||
(define-module (guix build linux-initrd)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (system foreign)
|
||||
#:autoload (system repl repl) (start-repl)
|
||||
#:autoload (system base compile) (compile-file)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (guix build utils)
|
||||
#:export (mount-essential-file-systems
|
||||
|
@ -31,9 +33,15 @@
|
|||
find-long-option
|
||||
make-essential-device-nodes
|
||||
configure-qemu-networking
|
||||
|
||||
disk-partitions
|
||||
partition-label-predicate
|
||||
find-partition-by-label
|
||||
|
||||
check-file-system
|
||||
mount-file-system
|
||||
bind-mount
|
||||
|
||||
load-linux-module*
|
||||
device-number
|
||||
boot-system))
|
||||
|
@ -88,6 +96,107 @@ Return the value associated with OPTION, or #f on failure."
|
|||
(lambda (arg)
|
||||
(substring arg (+ 1 (string-index arg #\=)))))))
|
||||
|
||||
(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 (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)
|
||||
|
||||
(call-with-input-file device
|
||||
(lambda (port)
|
||||
(seek port 1024 SEEK_SET)
|
||||
(let* ((block (get-bytevector-n port 264))
|
||||
(magic (bytevector-u16-ref block %ext2-sblock-magic
|
||||
%ext2-endianness)))
|
||||
(and (= magic %ext2-magic)
|
||||
block)))))
|
||||
|
||||
(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))
|
||||
|
||||
(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."
|
||||
(let ((bv (make-bytevector 16)))
|
||||
(bytevector-copy! sblock %ext2-sblock-volume-name bv 0 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 (disk-partitions)
|
||||
"Return the list of device names corresponding to valid disk partitions."
|
||||
(define (partition? major minor)
|
||||
(let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(not (zero? (call-with-input-file marker read))))
|
||||
(lambda args
|
||||
(if (= ENOENT (system-error-errno args))
|
||||
#f
|
||||
(apply throw args))))))
|
||||
|
||||
(call-with-input-file "/proc/partitions"
|
||||
(lambda (port)
|
||||
;; Skip the two header lines.
|
||||
(read-line port)
|
||||
(read-line port)
|
||||
|
||||
;; Read each subsequent line, and extract the last space-separated
|
||||
;; field.
|
||||
(let loop ((parts '()))
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(reverse parts)
|
||||
(match (string-tokenize line)
|
||||
(((= string->number major) (= string->number minor)
|
||||
blocks name)
|
||||
(if (partition? major minor)
|
||||
(loop (cons name parts))
|
||||
(loop parts))))))))))
|
||||
|
||||
(define (partition-label-predicate label)
|
||||
"Return a procedure that, when applied to a partition name such as \"sda1\",
|
||||
return #t if that partition's volume name is LABEL."
|
||||
(lambda (part)
|
||||
(let* ((device (string-append "/dev/" part))
|
||||
(sblock (read-ext2-superblock device)))
|
||||
(and sblock
|
||||
(string=? (ext2-superblock-volume-name sblock)
|
||||
label)))))
|
||||
|
||||
(define (find-partition-by-label label)
|
||||
"Return the first partition found whose volume name is LABEL, or #f if none
|
||||
were found."
|
||||
(and=> (find (partition-label-predicate label)
|
||||
(disk-partitions))
|
||||
(cut string-append "/dev/" <>)))
|
||||
|
||||
(define (canonicalize-device-spec spec)
|
||||
"Given SPEC, a string such as \"/dev/sda1\" or \"my-root-part\", return the
|
||||
corresponding device name."
|
||||
(if (string-prefix? "/" spec)
|
||||
spec
|
||||
(or (find-partition-by-label spec) spec)))
|
||||
|
||||
(define* (make-essential-device-nodes #:key (root "/"))
|
||||
"Make essential device nodes under ROOT/dev."
|
||||
;; The hand-made udev!
|
||||
|
@ -321,7 +430,8 @@ run a file system check."
|
|||
|
||||
(match spec
|
||||
((source mount-point type (flags ...) options check?)
|
||||
(let ((mount-point (string-append root "/" mount-point)))
|
||||
(let ((source (canonicalize-device-spec source))
|
||||
(mount-point (string-append root "/" mount-point)))
|
||||
(when check?
|
||||
(check-file-system source type))
|
||||
(mkdir-p mount-point)
|
||||
|
@ -381,6 +491,7 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
|
|||
|
||||
(close-port console))))
|
||||
|
||||
|
||||
(define* (boot-system #:key
|
||||
(linux-modules '())
|
||||
qemu-guest-networking?
|
||||
|
@ -451,7 +562,8 @@ to it are lost."
|
|||
(unless (file-exists? "/root")
|
||||
(mkdir "/root"))
|
||||
(if root
|
||||
(mount-root-file-system root root-fs-type
|
||||
(mount-root-file-system (canonicalize-device-spec root)
|
||||
root-fs-type
|
||||
#:volatile-root? volatile-root?)
|
||||
(mount "none" "/root" "tmpfs"))
|
||||
|
||||
|
|
Loading…
Reference in a new issue