diff options
| -rw-r--r-- | gnu/build/install.scm | 44 | ||||
| -rw-r--r-- | gnu/system/install.scm | 52 |
2 files changed, 55 insertions, 41 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 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 |