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.
This commit is contained in:
parent
ca2baf10ba
commit
a9d2a10546
|
@ -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."
|
||||
|
|
|
@ -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) '())))
|
||||
|
|
Loading…
Reference in New Issue