From 384344198dcaa97847e66d3dd82f279ede08d690 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 16 Jan 2017 22:33:46 +0100
Subject: file-systems: 'file-system-needed-for-boot?' is #t for parents of the
 store.

Suggested by John Darrington <john@darrington.wattle.id.au>.

* 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 +++++++++++++++++++++++++++++++++-----
 1 file changed, 33 insertions(+), 5 deletions(-)

(limited to 'gnu/system/file-systems.scm')

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 4cc1221eb8..fa56853fd1 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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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
-- 
cgit v1.2.3