ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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.
This commit is contained in:
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) (define-module (gnu build file-systems)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:use-module (gnu system file-systems)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build bournish) #: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 io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -552,11 +554,8 @@ (define (mount-flags->bit-mask flags)
(() (()
0)))) 0))))
(define* (mount-file-system spec #:key (root "/root")) (define* (mount-file-system fs #:key (root "/root"))
"Mount the file system described by SPEC under ROOT. SPEC must have the "Mount the file system described by FS, a <file-system> object, under ROOT.
form:
(DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; 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 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
@ -582,12 +581,14 @@ (define (mount-nfs source mount-point type flags options)
(if options (if options
(string-append "," options) (string-append "," options)
""))))) "")))))
(match spec (let ((type (file-system-type fs))
((source title mount-point type (flags ...) options check?) (options (file-system-options fs))
(let ((source (canonicalize-device-spec source title)) (source (canonicalize-device-spec (file-system-device fs)
(mount-point (string-append root "/" mount-point)) (file-system-title fs)))
(flags (mount-flags->bit-mask flags))) (mount-point (string-append root "/"
(when check? (file-system-mount-point fs)))
(flags (mount-flags->bit-mask (file-system-flags fs))))
(when (file-system-check? fs)
(check-file-system source type)) (check-file-system source type))
;; Create the mount point. Most of the time this is a directory, but ;; Create the mount point. Most of the time this is a directory, but
@ -610,6 +611,6 @@ (define (mount-nfs source mount-point type flags options)
(when (and (= MS_BIND (logand flags MS_BIND)) (when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY))) (= MS_RDONLY (logand flags MS_RDONLY)))
(let ((flags (logior MS_BIND MS_REMOUNT 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 ;;; file-systems.scm ends here

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

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -27,9 +27,11 @@ (define-module (gnu build linux-boot)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (guix build utils) #: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 linux-modules)
#:use-module (gnu build file-systems) #:use-module (gnu build file-systems)
#:use-module (gnu system file-systems)
#:export (mount-essential-file-systems #:export (mount-essential-file-systems
linux-command-line linux-command-line
find-long-option find-long-option
@ -349,19 +351,17 @@ (define* (boot-system #:key
Mount the root file system, specified by the '--root' command-line argument, Mount the root file system, specified by the '--root' command-line argument,
if any. 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 When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost." to it are lost."
(define root-mount-point? (define (root-mount-point? fs)
(match-lambda (string=? (file-system-mount-point fs) "/"))
((device _ "/" _ ...) #t)
(_ #f)))
(define root-fs-type (define root-fs-type
(or (any (match-lambda (or (any (lambda (fs)
((device _ "/" type _ ...) type) (and (root-mount-point? fs)
(_ #f)) (file-system-type fs)))
mounts) mounts)
"ext4")) "ext4"))

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

@ -152,8 +152,7 @@ (define* (mount* source target type #:optional (flags 0) options
;; Mount user-specified file systems. ;; Mount user-specified file systems.
(for-each (lambda (file-system) (for-each (lambda (file-system)
(mount-file-system (file-system->spec file-system) (mount-file-system file-system #:root root))
#:root root))
mounts) mounts)
;; Jail the process inside the container's root file system. ;; Jail the process inside the container's root file system.

6
gnu/services/base.scm
View file

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

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

@ -187,9 +187,11 @@ (define kodir
'((gnu build linux-boot) '((gnu build linux-boot)
(guix build utils) (guix build utils)
(guix build bournish) (guix build bournish)
(gnu system file-systems)
(gnu build file-systems))) (gnu build file-systems)))
#~(begin #~(begin
(use-modules (gnu build linux-boot) (use-modules (gnu build linux-boot)
(gnu system file-systems)
(guix build utils) (guix build utils)
(guix build bournish) ;add the 'bournish' meta-command (guix build bournish) ;add the 'bournish' meta-command
(srfi srfi-26) (srfi srfi-26)
@ -206,7 +208,9 @@ (define kodir
(set-path-environment-variable "PATH" '("bin" "sbin") (set-path-environment-variable "PATH" '("bin" "sbin")
'#$helper-packages))) '#$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 () #:pre-mount (lambda ()
(and #$@device-mapping-commands)) (and #$@device-mapping-commands))
#:linux-modules '#$linux-modules #:linux-modules '#$linux-modules