aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/guix.texi2
-rw-r--r--guix/build/linux-initrd.scm116
2 files changed, 115 insertions, 3 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index c10479ff12..eeadb04d78 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 5be3c1ac2a..3873ade13e 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -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"))