1 files changed, 43 insertions, 1 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 87aa5d68da..63995e1d09 100644
--- 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)
@@ -26,7 +27,9 @@
             evaluate-populate-directive
             populate-root-file-system
             install-database-and-gc-roots
-            populate-single-profile-directory))
+            populate-single-profile-directory
+            mount-cow-store
+            unmount-cow-store))
 
 ;;; Commentary:
 ;;;
@@ -229,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