Merge branch 'master' into core-updates

1 files changed, 54 insertions, 2 deletions

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index fa56853fd1..7011a279d3 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -18,8 +18,8 @@
 
 (define-module (gnu system file-systems)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (guix records)
-  #:use-module (guix store)
   #:use-module ((gnu build file-systems)
                 #:select (string->uuid uuid->string))
   #:re-export (string->uuid
@@ -63,7 +63,11 @@
             file-system-mapping-target
             file-system-mapping-writable?
 
-            %store-mapping))
+            file-system-mapping->bind-mount
+
+            %store-mapping
+            %network-configuration-files
+            %network-file-mappings))
 
 ;;; Commentary:
 ;;;
@@ -95,6 +99,20 @@
   (dependencies     file-system-dependencies      ; list of <file-system>
                     (default '())))               ; or <mapped-device>
 
+;; Note: This module is used both on the build side and on the host side.
+;; Arrange not to pull (guix store) and (guix config) because the latter
+;; differs from user to user.
+(define (%store-prefix)
+  "Return the store prefix."
+  (cond ((resolve-module '(guix store) #:ensure #f)
+         =>
+         (lambda (store)
+           ((module-ref store '%store-prefix))))
+        ((getenv "NIX_STORE")
+         => identity)
+        (else
+         "/gnu/store")))
+
 (define %not-slash
   (char-set-complement (char-set #\/)))
 
@@ -352,6 +370,21 @@ TARGET in the other system."
   (writable? file-system-mapping-writable?        ;Boolean
              (default #f)))
 
+(define (file-system-mapping->bind-mount mapping)
+  "Return a file system that realizes MAPPING, a <file-system-mapping>, using
+a bind mount."
+  (match mapping
+    (($ <file-system-mapping> source target writable?)
+     (file-system
+       (mount-point target)
+       (device source)
+       (type "none")
+       (flags (if writable?
+                  '(bind-mount)
+                  '(bind-mount read-only)))
+       (check? #f)
+       (create-mount-point? #t)))))
+
 (define %store-mapping
   ;; Mapping of the host's store into the guest.
   (file-system-mapping
@@ -359,4 +392,23 @@ TARGET in the other system."
    (target (%store-prefix))
    (writable? #f)))
 
+(define %network-configuration-files
+  ;; List of essential network configuration files.
+  '("/etc/resolv.conf"
+    "/etc/nsswitch.conf"
+    "/etc/services"
+    "/etc/hosts"))
+
+(define %network-file-mappings
+  ;; List of file mappings for essential network files.
+  (filter-map (lambda (file)
+                (file-system-mapping
+                 (source file)
+                 (target file)
+                 ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
+                 ;; symlink to a file in a tmpfs which, for an unknown reason,
+                 ;; cannot be bind mounted read-only within the container.
+                 (writable? (string=? file "/etc/resolv.conf"))))
+              %network-configuration-files))
+
 ;;; file-systems.scm ends here