[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: file-systems: 'file-system-needed-for-boot?' is #t for parents of
From: |
Ludovic Courtès |
Subject: |
01/02: file-systems: 'file-system-needed-for-boot?' is #t for parents of the store. |
Date: |
Mon, 16 Jan 2017 22:27:28 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 384344198dcaa97847e66d3dd82f279ede08d690
Author: Ludovic Courtès <address@hidden>
Date: Mon Jan 16 22:33:46 2017 +0100
file-systems: 'file-system-needed-for-boot?' is #t for parents of the store.
Suggested by John Darrington <address@hidden>.
* gnu/system/file-systems.scm (%not-slash): New variable.
(file-prefix?): New procedure.
(file-system-needed-for-boot?): Use it to check whether FS holds the
store.
* tests/file-systems.scm ("file-system-needed-for-boot?"): New test.
* gnu/tests/install.scm (%separate-store-os)[file-systems]: Remove
'needed-for-boot?' field for "/gnu".
---
gnu/system/file-systems.scm | 38 +++++++++++++++++++++++++++++++++-----
gnu/tests/install.scm | 5 ++---
tests/file-systems.scm | 24 +++++++++++++++++++++++-
3 files changed, 58 insertions(+), 9 deletions(-)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 4cc1221..fa56853 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -95,11 +95,39 @@
(dependencies file-system-dependencies ; list of <file-system>
(default '()))) ; or <mapped-device>
-(define-inlinable (file-system-needed-for-boot? fs)
- "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root
-file system."
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define (file-prefix? file1 file2)
+ "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
+where both FILE1 and FILE2 are absolute file name. For example:
+
+ (file-prefix? \"/gnu\" \"/gnu/store\")
+ => #t
+
+ (file-prefix? \"/gn\" \"/gnu/store\")
+ => #f
+"
+ (and (string-prefix? "/" file1)
+ (string-prefix? "/" file2)
+ (let loop ((file1 (string-tokenize file1 %not-slash))
+ (file2 (string-tokenize file2 %not-slash)))
+ (match file1
+ (()
+ #t)
+ ((head1 tail1 ...)
+ (match file2
+ ((head2 tail2 ...)
+ (and (string=? head1 head2) (loop tail1 tail2)))
+ (()
+ #f)))))))
+
+(define (file-system-needed-for-boot? fs)
+ "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
+store--e.g., if FS is the root file system."
(or (%file-system-needed-for-boot? fs)
- (string=? "/" (file-system-mount-point fs))))
+ (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
+ (not (memq 'bind-mount (file-system-flags fs))))))
(define (file-system->spec fs)
"Return a list corresponding to file-system FS that can be passed to the
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index ae54154..4e8d594 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -257,8 +257,7 @@ build (current-guix) and then store a couple of full system
images.")
(device "store-fs")
(title 'label)
(mount-point "/gnu")
- (type "ext4")
- (needed-for-boot? #t)) ;definitely!
+ (type "ext4"))
%base-file-systems))
(users %base-user-accounts)
(services (cons (service marionette-service-type
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index aed27e8..fd1599e 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2017 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-file-systems)
+ #:use-module (guix store)
#:use-module (gnu system file-systems)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors))
@@ -50,4 +51,25 @@
(string-contains message "invalid UUID")
(equal? form '(uuid "foobar"))))))
+(test-assert "file-system-needed-for-boot?"
+ (let-syntax ((dummy-fs (syntax-rules ()
+ ((_ directory)
+ (file-system
+ (device "foo")
+ (mount-point directory)
+ (type "ext4"))))))
+ (parameterize ((%store-prefix "/gnu/guix/store"))
+ (and (file-system-needed-for-boot? (dummy-fs "/"))
+ (file-system-needed-for-boot? (dummy-fs "/gnu"))
+ (file-system-needed-for-boot? (dummy-fs "/gnu/guix"))
+ (file-system-needed-for-boot? (dummy-fs "/gnu/guix/store"))
+ (not (file-system-needed-for-boot?
+ (dummy-fs "/gnu/guix/store/foo")))
+ (not (file-system-needed-for-boot? (dummy-fs "/gn")))
+ (not (file-system-needed-for-boot?
+ (file-system
+ (inherit (dummy-fs (%store-prefix)))
+ (device "/foo")
+ (flags '(bind-mount read-only)))))))))
+
(test-end)