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:
Ludovic Courtès 2014-04-12 22:32:10 +02:00
parent ca2baf10ba
commit a9d2a10546
2 changed files with 48 additions and 4 deletions

View File

@ -21,6 +21,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix serialization) #:use-module (guix serialization)
#:autoload (guix base32) (bytevector->base32-string)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -35,6 +36,7 @@
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 popen) #:use-module (ice-9 popen)
#:export (%daemon-socket-file #:export (%daemon-socket-file
%gc-roots-directory
nix-server? nix-server?
nix-server-major-version nix-server-major-version
@ -63,6 +65,8 @@
build-derivations build-derivations
add-temp-root add-temp-root
add-indirect-root add-indirect-root
add-permanent-root
remove-permanent-root
substitutable? substitutable?
substitutable-path substitutable-path
@ -570,12 +574,40 @@ Return #t."
boolean) boolean)
(define-operation (add-indirect-root (string file-name)) (define-operation (add-indirect-root (string file-name))
"Make FILE-NAME an indirect root for the garbage collector; FILE-NAME "Make the symlink FILE-NAME an indirect root for the garbage collector:
can be anywhere on the file system, but it must be an absolute file whatever store item FILE-NAME points to will not be collected. Return #t on
name--it is the caller's responsibility to ensure that it is an absolute success.
file name. 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) 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 (define references
(operation (query-references (store-path path)) (operation (query-references (store-path path))
"Return the list of references of PATH." "Return the list of references of PATH."

View File

@ -147,6 +147,18 @@
;; (valid-path? %store p1) ;; (valid-path? %store p1)
;; (member (pk p2) (live-paths %store))))) ;; (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" (test-assert "dead path can be explicitly collected"
(let ((p (add-text-to-store %store "random-text" (let ((p (add-text-to-store %store "random-text"
(random-text) '()))) (random-text) '())))