Merge remote-tracking branch 'upstream/version-1.2.0'

[jackhill/guix/guix.git] / gnu / build / install.scm

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index d46b588..63995e1 100644 (file)
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,6 +18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build install)
+  #:use-module (guix build syscalls)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
@@ -25,9 +26,10 @@
   #:export (install-boot-config
             evaluate-populate-directive
             populate-root-file-system
-            register-closure
             install-database-and-gc-roots
-            populate-single-profile-directory))
+            populate-single-profile-directory
+            mount-cow-store
+            unmount-cow-store))
 
 ;;; Commentary:
 ;;;
@@ -51,9 +53,14 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
     (copy-file bootcfg pivot)
     (rename-file pivot target)))
 
-(define (evaluate-populate-directive directive target)
+(define* (evaluate-populate-directive directive target
+                                      #:key
+                                      (default-gid 0)
+                                      (default-uid 0))
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
-directory TARGET."
+directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
+the context of the caller.  If the directive matches those defaults then,
+'chown' won't be run."
   (let loop ((directive directive))
     (catch 'system-error
       (lambda ()
@@ -63,7 +70,12 @@ directory TARGET."
           (('directory name uid gid)
            (let ((dir (string-append target name)))
              (mkdir-p dir)
-             (chown dir uid gid)))
+             ;; If called from a context without "root" permissions, "chown"
+             ;; to root will fail.  In that case, do not try to run "chown"
+             ;; and assume that the file will be chowned elsewhere (when
+             ;; interned in the store for instance).
+             (or (and (= uid default-uid) (= gid default-gid))
+                 (chown dir uid gid))))
           (('directory name uid gid mode)
            (loop `(directory ,name ,uid ,gid))
            (chmod (string-append target name) mode))
@@ -98,9 +110,7 @@ directory TARGET."
 (define (directives store)
   "Return a list of directives to populate the root file system that will host
 STORE."
-  `(;; Note: the store's GID is fixed precisely so we can set it here rather
-    ;; than at activation time.
-    (directory ,store 0 30000 #o1775)
+  `((directory ,store 0 0 #o1775)
 
     (directory "/etc")
     (directory "/var/log")                          ; for shepherd
@@ -222,4 +232,43 @@ This is used to create the self-contained tarballs with 'guix pack'."
     (_
      #t)))
 
+(define (mount-cow-store target backing-directory)
+  "Make the store copy-on-write, using TARGET as the backing store.  This is
+useful when TARGET is on a hard disk, whereas the current store is on a RAM
+disk."
+  (define (set-store-permissions directory)
+    "Set the right perms on DIRECTORY to use it as the store."
+    (chown directory 0 30000)      ;use the fixed 'guixbuild' GID
+    (chmod directory #o1775))
+
+  (let ((tmpdir (string-append target "/tmp")))
+    (mkdir-p tmpdir)
+    (mount tmpdir "/tmp" "none" MS_BIND))
+
+  (let* ((rw-dir (string-append target backing-directory))
+         (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
+    (mkdir-p rw-dir)
+    (mkdir-p work-dir)
+    (mkdir-p "/.rw-store")
+    (set-store-permissions rw-dir)
+    (set-store-permissions "/.rw-store")
+
+    ;; Mount the overlay, then atomically make it the store.
+    (mount "none" "/.rw-store" "overlay" 0
+           (string-append "lowerdir=" (%store-directory) ","
+                          "upperdir=" rw-dir ","
+                          "workdir=" work-dir))
+    (mount "/.rw-store" (%store-directory) "" MS_MOVE)
+    (rmdir "/.rw-store")))
+
+(define (unmount-cow-store target backing-directory)
+  "Unmount copy-on-write store."
+  (let ((tmp-dir "/remove"))
+    (mkdir-p tmp-dir)
+    (mount (%store-directory) tmp-dir "" MS_MOVE)
+    (umount tmp-dir)
+    (rmdir tmp-dir)
+    (delete-file-recursively
+     (string-append target backing-directory))))
+
 ;;; install.scm ends here