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.
This commit is contained in:
Ludovic Courtès
parent
8a9e21d1f7
commit
e2f4b305d0
|
|
@ -280,6 +280,7 @@ GNU_SYSTEM_MODULES = \
|
|||
gnu/system/vm.scm \
|
||||
\
|
||||
gnu/build/activation.scm \
|
||||
gnu/build/file-systems.scm \
|
||||
gnu/build/install.scm \
|
||||
gnu/build/linux-boot.scm \
|
||||
gnu/build/vm.scm
|
||||
|
|
|
|||
|
|
@ -0,0 +1,299 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu build file-systems)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (system foreign)
|
||||
#:autoload (system repl repl) (start-repl)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (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
|
||||
|
||||
mount-flags->bit-mask
|
||||
check-file-system
|
||||
mount-file-system))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This modules provides tools to deal with disk partitions, and to mount and
|
||||
;;; check file systems.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; 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-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 (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))))))
|
||||
|
||||
;;; file-systems.scm ends here
|
||||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@
|
|||
#:use-module ((gnu packages base)
|
||||
#:select (canonical-package glibc))
|
||||
#:use-module (gnu packages package-management)
|
||||
#:use-module ((gnu build linux-boot)
|
||||
#:use-module ((gnu build file-systems)
|
||||
#:select (mount-flags->bit-mask))
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix monads)
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
(define modules
|
||||
;; Extra modules visible to dmd.conf.
|
||||
'((guix build syscalls)
|
||||
(gnu build linux-boot)
|
||||
(gnu build file-systems)
|
||||
(guix build utils)))
|
||||
|
||||
(mlet %store-monad ((modules (imported-modules modules))
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
(use-modules (ice-9 ftw)
|
||||
(guix build syscalls)
|
||||
(guix build utils)
|
||||
((gnu build linux-boot)
|
||||
((gnu build file-systems)
|
||||
#:select (check-file-system canonicalize-device-spec)))
|
||||
|
||||
(register-services
|
||||
|
|
|
|||
|
|
@ -364,6 +364,7 @@ etc."
|
|||
(define %modules
|
||||
'((gnu build activation)
|
||||
(gnu build linux-boot)
|
||||
(gnu build file-systems)
|
||||
(guix build utils)))
|
||||
|
||||
(define (service-activations services)
|
||||
|
|
|
|||
|
|
@ -293,7 +293,8 @@ exception and backtrace!)."
|
|||
#:volatile-root? '#$volatile-root?))
|
||||
#:name "base-initrd"
|
||||
#:modules '((guix build utils)
|
||||
(gnu build linux-boot))
|
||||
(gnu build linux-boot)
|
||||
(gnu build file-systems))
|
||||
#:to-copy helper-packages
|
||||
#:linux linux-libre
|
||||
#:linux-modules linux-modules))
|
||||
|
|
|
|||
|
|
@ -115,6 +115,7 @@ input tuple. The output file name is when building for SYSTEM."
|
|||
'((gnu build vm)
|
||||
(gnu build install)
|
||||
(gnu build linux-boot)
|
||||
(gnu build file-systems)
|
||||
(guix build utils)))
|
||||
(guile-for-build
|
||||
(%guile-for-build))
|
||||
|
|
|
|||
Loading…
Reference in New Issue