aboutsummaryrefslogtreecommitdiff
path: root/gnu/build/linux-boot.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-09-03 14:19:51 +0200
committerLudovic Courtès <ludo@gnu.org>2014-09-03 15:43:07 +0200
commite2f4b305d0b7cff1e19c7f67ea633ef8a971e712 (patch)
tree65302d216abc0b0811e4beb41179f586abe01a41 /gnu/build/linux-boot.scm
parent8a9e21d1f719748213414343cd02ec113ebe90c1 (diff)
downloadguix-e2f4b305d0b7cff1e19c7f67ea633ef8a971e712.tar
guix-e2f4b305d0b7cff1e19c7f67ea633ef8a971e712.tar.gz
Move part of (gnu build linux-boot) to (gnu build file-systems).
* gnu/build/linux-boot.scm (%ext2-endianness, %ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name, read-ext2-superblock, ext2-superblock-uuid, ext2-superblock-volume-name, disk-partitions, partition-label-predicate, find-partition-by-label, canonicalize-device-spec, MS_RDONLY, MS_NOSUID, MS_NODEV, MS_NOEXEC, MS_BIND, MS_MOVE, bind-mount, check-file-system, mount-flags->bit-mask, mount-file-system): Move to... * gnu/build/file-systems.scm: ... here. New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * gnu/services/base.scm: Use (gnu build file-systems). * gnu/services/dmd.scm (dmd-configuration-file): Likewise. * gnu/system.scm (operating-system-activation-script): Likewise. * gnu/system/linux-initrd.scm (base-initrd): Likewise. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise.
Diffstat (limited to 'gnu/build/linux-boot.scm')
-rw-r--r--gnu/build/linux-boot.scm259
1 files changed, 1 insertions, 258 deletions
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 24000e191a..21ee58ad50 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -18,33 +18,22 @@
(define-module (gnu build linux-boot)
#:use-module (rnrs io ports)
- #:use-module (rnrs bytevectors)
- #:use-module (system foreign)
#:use-module (system repl error-handling)
#: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)
+ #:use-module (gnu build file-systems)
#:export (mount-essential-file-systems
linux-command-line
find-long-option
make-essential-device-nodes
configure-qemu-networking
- disk-partitions
- partition-label-predicate
- find-partition-by-label
- canonicalize-device-spec
-
- mount-flags->bit-mask
- check-file-system
- mount-file-system
bind-mount
-
load-linux-module*
device-number
boot-system))
@@ -99,172 +88,6 @@ 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)
-
- (define superblock-size
- ;; Size of the interesting part of an ext2 superblock.
- 264)
-
- (define block
- ;; The superblock contents.
- (make-bytevector superblock-size))
-
- (call-with-input-file device
- (lambda (port)
- (seek port 1024 SEEK_SET)
-
- ;; 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))))))
-
-(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 (catch 'system-error
- (lambda ()
- (read-ext2-superblock device))
- (lambda args
- ;; When running on the hand-made /dev,
- ;; 'disk-partitions' could return partitions for which
- ;; we have no /dev node. Handle that gracefully.
- (if (= ENOENT (system-error-errno args))
- (begin
- (format (current-error-port)
- "warning: device '~a' not found~%"
- device)
- #f)
- (apply throw args))))))
- (and sblock
- (let ((volume (ext2-superblock-volume-name sblock)))
- (and volume
- (string=? volume 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 #: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\";
- • 'any', in which case SPEC can be anything.
-"
- (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
- ;; USB key would be detected by the kernel, so we must wait for at least
- ;; this long.
- 20)
-
- (define canonical-title
- ;; The realm of canonicalization.
- (if (eq? title 'any)
- (if (string-prefix? "/" spec)
- 'device
- 'label)
- title))
-
- (case canonical-title
- ((device)
- ;; Nothing to do.
- spec)
- ((label)
- ;; Resolve the label.
- (let loop ((count 0))
- (let ((device (find-partition-by-label spec)))
- (or device
- ;; Some devices take a bit of time to appear, most notably USB
- ;; storage devices. Thus, wait for the device to appear.
- (if (> count max-trials)
- (error "failed to resolve partition label" spec)
- (begin
- (format #t "waiting for partition '~a' to appear...~%"
- spec)
- (sleep 1)
- (loop (+ 1 count))))))))
- ;; TODO: Add support for UUIDs.
- (else
- (error "unknown device title" title))))
-
(define* (make-disk-device-nodes base major #:optional (minor 0))
"Make the block device nodes around BASE (something like \"/root/dev/sda\")
with the given MAJOR number, starting with MINOR."
@@ -395,18 +218,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise."
(logand (network-interface-flags sock interface) IFF_UP)))
-;; Linux mount flags, from libc's <sys/mount.h>.
-(define MS_RDONLY 1)
-(define MS_NOSUID 2)
-(define MS_NODEV 4)
-(define MS_NOEXEC 8)
-(define MS_BIND 4096)
-(define MS_MOVE 8192)
-
-(define (bind-mount source target)
- "Bind-mount SOURCE at TARGET."
- (mount source target "" MS_BIND))
-
(define (load-linux-module* file)
"Load Linux module from FILE, the name of a `.ko' file."
(define (slurp module)
@@ -479,74 +290,6 @@ UNIONFS."
(copy-file "/proc/mounts" "/root/etc/mtab"))
-(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" 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 REPL~%"
- fsck code device)
- (start-repl)))))
-
-(define (mount-flags->bit-mask flags)
- "Return the number suitable for the 'flags' argument of 'mount' that
-corresponds to the symbols listed in FLAGS."
- (let loop ((flags flags))
- (match flags
- (('read-only rest ...)
- (logior MS_RDONLY (loop rest)))
- (('bind-mount rest ...)
- (logior MS_BIND (loop rest)))
- (('no-suid rest ...)
- (logior MS_NOSUID (loop rest)))
- (('no-dev rest ...)
- (logior MS_NODEV (loop rest)))
- (('no-exec rest ...)
- (logior MS_NOEXEC (loop rest)))
- (()
- 0))))
-
-(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."
- (match spec
- ((source title mount-point type (flags ...) options check?)
- (let ((source (canonicalize-device-spec source title))
- (mount-point (string-append root "/" mount-point)))
- (when check?
- (check-file-system source type))
- (mkdir-p mount-point)
- (mount source mount-point type (mount-flags->bit-mask flags)
- (if options
- (string->pointer options)
- %null-pointer))
-
- ;; Update /etc/mtab.
- (mkdir-p (string-append root "/etc"))
- (let ((port (open-file (string-append root "/etc/mtab") "a")))
- (format port "~a ~a ~a ~a 0 0~%"
- source mount-point type (or options ""))
- (close-port port))))))
-
(define (switch-root root)
"Switch to ROOT as the root file system, in a way similar to what
util-linux' switch_root(8) does."