install: Add a service to back the store with the target disk.

Fixes <http://bugs.gnu.org/18061>.
Reported by Adam Pribyl <pribyl@lowlevel.cz>.

* gnu/services/dmd.scm (dmd-configuration-file)[config]: Import (guix
  build utils).
* gnu/system/install.scm (make-cow-store, cow-store-service): New
  procedures.
  (installation-services): Use it.
  (%backing-directory): New variable.
* doc/guix.texi (System Installation): Add the 'deco start cow-store
  /mnt' phase.

2 files changed, 78 insertions, 0 deletions

diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 74adb27885..dfda2708f5 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -49,6 +49,7 @@
 
           (use-modules (ice-9 ftw)
                        (guix build syscalls)
+                       (guix build utils)
                        ((guix build linux-initrd)
                         #:select (check-file-system canonicalize-device-spec)))
 
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index d4a32609ba..d3539b3f84 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -20,6 +20,7 @@
   #:use-module (gnu)
   #:use-module (guix gexp)
   #:use-module (guix monads)
+  #:use-module ((guix store) #:select (%store-prefix))
   #:use-module (gnu packages linux)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages disk)
@@ -42,6 +43,78 @@ manual."
                          "-f" (string-append #$guix "/share/info/guix.info")
                          "-n" "System Installation")))
 
+(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 (unionfs read-only read-write mount-point)
+    ;; Make MOUNT-POINT the union of READ-ONLY and READ-WRITE.
+
+    ;; Note: in the command below, READ-WRITE appears before READ-ONLY so that
+    ;; it is considered a "higher-level branch", as per unionfs-fuse(8),
+    ;; thereby allowing files existing on READ-ONLY to be copied over to
+    ;; READ-WRITE.
+    #~(fork+exec-command
+       (list (string-append #$unionfs-fuse "/bin/unionfs")
+             "-o"
+             "cow,allow_other,use_ino,max_files=65536,nonempty"
+             (string-append #$read-write "=RW:" #$read-only "=RO")
+             #$mount-point)))
+
+  (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
+      (unless (file-exists? "/.ro-store")
+        (mkdir "/.ro-store")
+        (mount #$(%store-prefix) "/.ro-store" "none"
+               (logior MS_BIND MS_RDONLY)))
+
+      (let ((rw-dir (string-append target #$%backing-directory)))
+        (mkdir-p rw-dir)
+        (mkdir-p "/.rw-store")
+        #$(set-store-permissions #~rw-dir)
+        #$(set-store-permissions "/.rw-store")
+
+        ;; Mount the union, then atomically make it the store.
+        (and #$(unionfs "/.ro-store" #~rw-dir "/.rw-store")
+             (begin
+               (sleep 1) ;XXX: wait for unionfs to be ready
+               (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
+               (rmdir "/.rw-store"))))))
+
+(define (cow-store-service)
+  "Return a service that makes the store copy-on-write, such that writes go to
+the user's target storage device rather than on the RAM disk."
+  ;; See <http://bugs.gnu.org/18061> for the initial report.
+  (with-monad %store-monad
+    (return (service
+             (requirement '(root-file-system user-processes))
+             (provision '(cow-store))
+             (documentation
+              "Make the store copy-on-write, with writes going to \
+the given target.")
+             (start #~(case-lambda
+                        ((target)
+                         #$(make-cow-store #~target)
+                         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 'user-processes' doesn't depend on us.
+                       (delete-file-recursively
+                        (string-append target #$%backing-directory))))))))
+
 (define (installation-services)
   "Return the list services for the installation image."
   (let ((motd (text-file "motd" "
@@ -88,6 +161,10 @@ You have been warned.  Thanks for being so brave.
           ;; Start udev so that useful device nodes are available.
           (udev-service)
 
+          ;; Add the 'cow-store' service, which users have to start manually
+          ;; since it takes the installation directory as an argument.
+          (cow-store-service)
+
           ;; Install Unicode support and a suitable font.
           (console-font-service "tty1")
           (console-font-service "tty2")