me
/
guix
Archived
1
0
Fork 0
Code

file-systems: 'mount-file-system' now takes a <file-system> object. 

* gnu/build/file-systems.scm (mount-file-system): Rename 'spec' to 'fs'
and assume it's a <file-system>.
* gnu/build/linux-boot.scm (boot-system): Assume MOUNTS is a list of
<file-system> and adjust accordingly.
* gnu/build/linux-container.scm (mount-file-systems): Remove
'file-system->spec' call.
* gnu/services/base.scm (file-system-shepherd-service): Add
'spec->file-system' call.  Add (gnu system file-systems) to 'modules'.
* gnu/system/linux-initrd.scm (raw-initrd): Use (gnu system
file-systems).  Add 'spec->file-system' call for #:mounts.
master
Ludovic Courtès 2017-10-03 23:25:38 +02:00
parent f26af33aec
commit 1c65cca574
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 53 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gnu/build/file-systems.scm
View File

@ -20,9 +20,11 @@
(define-module (gnu build file-systems)
#:use-module (gnu system uuid)
#:use-module (gnu system file-systems)
#:use-module (guix build utils)
#:use-module (guix build bournish)
#:use-module (guix build syscalls)
#:use-module ((guix build syscalls)
#:hide (file-system-type))
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
@ -552,11 +554,8 @@ corresponds to the symbols listed in FLAGS."
(()
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?)
(define* (mount-file-system fs #:key (root "/root"))
"Mount the file system described by FS, a <file-system> object, under ROOT.
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
@ -582,12 +581,14 @@ run a file system check."
(if options
(string-append "," options)
"")))))
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point))
(flags (mount-flags->bit-mask flags)))
(when check?
(let ((type (file-system-type fs))
(options (file-system-options fs))
(source (canonicalize-device-spec (file-system-device fs)
(file-system-title fs)))
(mount-point (string-append root "/"
(file-system-mount-point fs)))
(flags (mount-flags->bit-mask (file-system-flags fs))))
(when (file-system-check? fs)
(check-file-system source type))
;; Create the mount point. Most of the time this is a directory, but
@ -610,6 +611,6 @@ run a file system check."
(when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY)))
(let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
(mount source mount-point type flags #f)))))))
(mount source mount-point type flags #f)))))
;;; file-systems.scm ends here

20
gnu/build/linux-boot.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
@ -27,9 +27,11 @@
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (guix build utils)
#:use-module (guix build syscalls)
#:use-module ((guix build syscalls)
#:hide (file-system-type))
#:use-module (gnu build linux-modules)
#:use-module (gnu build file-systems)
#:use-module (gnu system file-systems)
#:export (mount-essential-file-systems
linux-command-line
find-long-option
@ -349,19 +351,17 @@ supports kernel command-line options '--load', '--root', and '--repl'.
Mount the root file system, specified by the '--root' command-line argument,
if any.
MOUNTS must be a list suitable for 'mount-file-system'.
MOUNTS must be a list of <file-system> objects.
When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost."
(define root-mount-point?
(match-lambda
((device _ "/" _ ...) #t)
(_ #f)))
(define (root-mount-point? fs)
(string=? (file-system-mount-point fs) "/"))
(define root-fs-type
(or (any (match-lambda
((device _ "/" type _ ...) type)
(_ #f))
(or (any (lambda (fs)
(and (root-mount-point? fs)
(file-system-type fs)))
mounts)
"ext4"))

3
gnu/build/linux-container.scm
View File

@ -152,8 +152,7 @@ for the process."
;; Mount user-specified file systems.
(for-each (lambda (file-system)
(mount-file-system (file-system->spec file-system)
#:root root))
(mount-file-system file-system #:root root))
mounts)
;; Jail the process inside the container's root file system.

6
gnu/services/base.scm
View File

@ -307,7 +307,8 @@ FILE-SYSTEM."
'#$packages))))
(lambda ()
(mount-file-system
'#$(file-system->spec file-system)
(spec->file-system
'#$(file-system->spec file-system))
#:root "/"))
(lambda ()
(setenv "PATH" $PATH)))
@ -322,9 +323,10 @@ FILE-SYSTEM."
(umount #$target)
#f))
;; We need an additional module.
;; We need additional modules.
(modules `(((gnu build file-systems)
#:select (mount-file-system))
(gnu system file-systems)
,@%default-modules)))))))
(define (file-system-shepherd-services file-systems)

6
gnu/system/linux-initrd.scm
View File

@ -187,9 +187,11 @@ to it are lost."
'((gnu build linux-boot)
(guix build utils)
(guix build bournish)
(gnu system file-systems)
(gnu build file-systems)))
#~(begin
(use-modules (gnu build linux-boot)
(gnu system file-systems)
(guix build utils)
(guix build bournish) ;add the 'bournish' meta-command
(srfi srfi-26)
@ -206,7 +208,9 @@ to it are lost."
(set-path-environment-variable "PATH" '("bin" "sbin")
'#$helper-packages)))
(boot-system #:mounts '#$(map file-system->spec file-systems)
(boot-system #:mounts
(map spec->file-system
'#$(map file-system->spec file-systems))
#:pre-mount (lambda ()
(and #$@device-mapping-commands))
#:linux-modules '#$linux-modules