diff options
| -rw-r--r-- | guix/store.scm | 40 | ||||
| -rw-r--r-- | tests/store.scm | 12 |
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) '()))) |