port cow store from guix internal

1 files changed, 62 insertions, 0 deletions

diff --git a/modules/freya/services/cow.scm b/modules/freya/services/cow.scm
new file mode 100644
index 0000000..e233db7
--- /dev/null
+++ b/modules/freya/services/cow.scm
@@ -0,0 +1,62 @@
+(define-module (freya services cow)
+	       #:use-module (gnu services shepherd)
+	       #:use-module (guix modules)
+	       #:use-module (gnu))
+
+; guix doesnt export the cow store
+; bruch >:(
+
+(define %backing-directory
+  ;; Sub-directory used as the backing store for copy-on-write.
+  "/tmp/guix-inst")
+
+(define cow-store-service-type
+  (shepherd-service-type
+   'cow-store
+   (lambda _
+     (define (import-module? module)
+       ;; Since we don't use deduplication support in 'populate-store', don't
+       ;; import (guix store deduplication) and its dependencies, which
+       ;; includes Guile-Gcrypt.
+       (and (guix-module-name? module)
+            (not (equal? module '(guix store deduplication)))))
+
+     (shepherd-service
+      (requirement '(root-file-system user-processes))
+      (provision '(cow-store))
+      (documentation
+       "Make the store copy-on-write, with writes going to \
+the given target.")
+
+      ;; This is meant to be explicitly started by the user.
+      (auto-start? #f)
+
+      (modules `((gnu build install)
+                 ,@%default-modules))
+      (start
+       (with-imported-modules (source-module-closure
+                               '((gnu build install))
+                               #:select? import-module?)
+         #~(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
+                ;; 'user-processes' doesn't depend on us.  The 'user-file-systems'
+                ;; service will unmount TARGET eventually.
+                (delete-file-recursively
+                 (string-append target #$%backing-directory))))))
+   (description "Make the store copy-on-write, with writes going to \
+the given target.")))
+
+(define-public (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.
+  (service cow-store-service-type 'mooooh!))
+