3
5
Fork 0
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:
Ludovic Courtès 2014-05-30 23:44:28 +02:00
parent bd3fc08c4d
commit 85a83edb36
2 changed files with 115 additions and 3 deletions

View file

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

View file

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