summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-04-12 22:32:10 +0200
committerLudovic Courtès <ludo@gnu.org>2014-04-12 22:32:10 +0200
commita9d2a10546b128c3d6df5665ef6dab929cb3db39 (patch)
treed3df68734fc6e550c01c890ba5567553cf1ff41b
parentca2baf10bad8433e92d7dde6629946f54043d63f (diff)
downloadpatches-a9d2a10546b128c3d6df5665ef6dab929cb3db39.tar
patches-a9d2a10546b128c3d6df5665ef6dab929cb3db39.tar.gz
store: Add 'add-permanent-root' and 'remove-permanent-root'.
* guix/store.scm (add-indirect-root): Improve docstring. (%gc-roots-directory): New variable. (add-permanent-root, remove-permanent-root): New procedures. * tests/store.scm ("permanent root"): New test.
-rw-r--r--guix/store.scm40
-rw-r--r--tests/store.scm12
2 files changed, 48 insertions, 4 deletions
diff --git a/guix/store.scm b/guix/store.scm
index 58f7e36762..c1898c5c81 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -21,6 +21,7 @@
#:use-module (guix utils)
#:use-module (guix config)
#:use-module (guix serialization)
+ #:autoload (guix base32) (bytevector->base32-string)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
@@ -35,6 +36,7 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 popen)
#:export (%daemon-socket-file
+ %gc-roots-directory
nix-server?
nix-server-major-version
@@ -63,6 +65,8 @@
build-derivations
add-temp-root
add-indirect-root
+ add-permanent-root
+ remove-permanent-root
substitutable?
substitutable-path
@@ -570,12 +574,40 @@ Return #t."
boolean)
(define-operation (add-indirect-root (string file-name))
- "Make FILE-NAME an indirect root for the garbage collector; FILE-NAME
-can be anywhere on the file system, but it must be an absolute file
-name--it is the caller's responsibility to ensure that it is an absolute
-file name. Return #t on success."
+ "Make the symlink FILE-NAME an indirect root for the garbage collector:
+whatever store item FILE-NAME points to will not be collected. Return #t on
+success.
+
+FILE-NAME can be anywhere on the file system, but it must be an absolute file
+name--it is the caller's responsibility to ensure that it is an absolute file
+name."
boolean)
+(define %gc-roots-directory
+ ;; The place where garbage collector roots (symlinks) are kept.
+ (string-append %state-directory "/gcroots"))
+
+(define (add-permanent-root target)
+ "Add a garbage collector root pointing to TARGET, an element of the store,
+preventing TARGET from even being collected. This can also be used if TARGET
+does not exist yet.
+
+Raise an error if the caller does not have write access to the GC root
+directory."
+ (let* ((root (string-append %gc-roots-directory "/" (basename target))))
+ (catch 'system-error
+ (lambda ()
+ (symlink target root))
+ (lambda args
+ ;; If ROOT already exists, this is fine; otherwise, re-throw.
+ (unless (= EEXIST (system-error-errno args))
+ (apply throw args))))))
+
+(define (remove-permanent-root target)
+ "Remove the permanent garbage collector root pointing to TARGET. Raise an
+error if there is no such root."
+ (delete-file (string-append %gc-roots-directory "/" (basename target))))
+
(define references
(operation (query-references (store-path path))
"Return the list of references of PATH."
diff --git a/tests/store.scm b/tests/store.scm
index 3932a8eb45..90137b9754 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -147,6 +147,18 @@
;; (valid-path? %store p1)
;; (member (pk p2) (live-paths %store)))))
+(test-assert "permanent root"
+ (let* ((p (with-store store
+ (let ((p (add-text-to-store store "random-text"
+ (random-text))))
+ (add-permanent-root p)
+ (add-permanent-root p) ; should not throw
+ p))))
+ (and (member p (live-paths %store))
+ (begin
+ (remove-permanent-root p)
+ (->bool (member p (dead-paths %store)))))))
+
(test-assert "dead path can be explicitly collected"
(let ((p (add-text-to-store %store "random-text"
(random-text) '())))