mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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.
This commit is contained in:
parent
573489fbcd
commit
22827396ba
2 changed files with 55 additions and 41 deletions
|
@ -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 @@ (define-module (gnu build install)
|
|||
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 @@ (define (symlink* old new)
|
|||
(_
|
||||
#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
|
||||
|
|
|
@ -175,39 +175,6 @@ (define %backing-directory
|
|||
;; 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 @@ (define cow-store-service-type
|
|||
;; 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
|
||||
|
|
Loading…
Reference in a new issue