From 22827396baea149f193f6e9558b522e6d9c89a44 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Wed, 12 Aug 2020 12:16:24 +0200
Subject: install: Factorize cow-store procedure.

Move the cow-store procedure from the service declaration in (gnu system
install) to (gnu build install), so that it can be called from within a
different context than Shepherd.

* gnu/build/install.scm (mount-cow-store, unmount-cow-store): New procedures.
* gnu/system/install.scm (make-cow-store): Remove it,
(cow-store-service-type): adapt it accordingly.
---
 gnu/build/install.scm  | 44 +++++++++++++++++++++++++++++++++++++++++-
 gnu/system/install.scm | 52 ++++++++++++--------------------------------------
 2 files changed, 55 insertions(+), 41 deletions(-)

(limited to 'gnu')

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
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index a87c2f4207..be5a678cec 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -175,39 +175,6 @@ manual."
   ;; Sub-directory used as the backing store for copy-on-write.
   "/tmp/guix-inst")
 
-(define (make-cow-store target)
-  "Return a gexp that makes 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.
-    #~(begin
-        (chown #$directory 0 30000)             ;use the fixed 'guixbuild' GID
-        (chmod #$directory #o1775)))
-
-  #~(begin
-      ;; Bind-mount TARGET's /tmp in case we need space to build things.
-      (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-prefix) ","
-                              "upperdir=" rw-dir ","
-                              "workdir=" work-dir))
-        (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
-        (rmdir "/.rw-store"))))
-
 (define cow-store-service-type
   (shepherd-service-type
    'cow-store
@@ -222,13 +189,18 @@ the given target.")
       ;; This is meant to be explicitly started by the user.
       (auto-start? #f)
 
-      (start #~(case-lambda
-                 ((target)
-                  #$(make-cow-store #~target)
-                  target)
-                 (else
-                  ;; Do nothing, and mark the service as stopped.
-                  #f)))
+      (modules `((gnu build install)
+                 ,@%default-modules))
+      (start
+       (with-imported-modules (source-module-closure
+                               '((gnu build install)))
+         #~(case-lambda
+             ((target)
+              (mount-cow-store target #$%backing-directory)
+              target)
+             (else
+              ;; Do nothing, and mark the service as stopped.
+              #f))))
       (stop #~(lambda (target)
                 ;; Delete the temporary directory, but leave everything
                 ;; mounted as there may still be processes using it since
-- 
cgit v1.2.3