summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-12-09 23:52:59 +0100
committerLudovic Courtès <ludo@gnu.org>2012-12-09 23:52:59 +0100
commit3259877d3563ac022633fbd8b73134a10567331e (patch)
tree9958721827f6a8ba3f47333bdfa30a7865db8ee0
parentd3648e01185dbb3afed85a630b2f8934c68ea143 (diff)
downloadpatches-3259877d3563ac022633fbd8b73134a10567331e.tar
patches-3259877d3563ac022633fbd8b73134a10567331e.tar.gz
store: Add GC-related operations.
* guix/store.scm (gc-action): New enumerate type. (read-long-long, read-string-list, write-store-path, write-store-path-list, read-store-path-list): New procedures. (write-arg): Add support for `store-path' and `store-path-list'. (read-arg): Add support for `store-path-list'. (define-operation): Add support for multiple-value returns. (run-gc, live-paths, dead-paths, collect-garbage, delete-paths): New procedures. (%long-long-max): New macro. * tests/store.scm: New file. * Makefile.am (TESTS): Add it.
-rw-r--r--Makefile.am1
-rw-r--r--guix/store.scm102
-rw-r--r--tests/store.scm87
3 files changed, 186 insertions, 4 deletions
diff --git a/Makefile.am b/Makefile.am
index d52bd389be..7c33fe4b14 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -176,6 +176,7 @@ TESTS = \
tests/build-utils.scm \
tests/packages.scm \
tests/snix.scm \
+ tests/store.scm \
tests/union.scm \
tests/guix-build.sh \
tests/guix-download.sh \
diff --git a/guix/store.scm b/guix/store.scm
index 67620a1767..204364f319 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -50,8 +50,14 @@
add-text-to-store
add-to-store
build-derivations
+ add-temp-root
add-indirect-root
+ live-paths
+ dead-paths
+ collect-garbage
+ delete-paths
+
current-build-output-port
%store-prefix
@@ -111,8 +117,16 @@
(sha1 2)
(sha256 3))
+(define-enumerate-type gc-action
+ ;; store-api.hh
+ (return-live 0)
+ (return-dead 1)
+ (delete-dead 2)
+ (delete-specific 3))
+
(define %nix-state-dir
(or (getenv "NIX_STATE_DIR") "/nix/var/nix"))
+
(define %default-socket-path
(string-append %nix-state-dir "/daemon-socket/socket"))
@@ -133,6 +147,10 @@
(bytevector-u64-set! b 0 n (endianness little))
(put-bytevector p b)))
+(define (read-long-long p)
+ (let ((b (get-bytevector-n p 8)))
+ (bytevector-u64-ref b 0 (endianness little))))
+
(define write-padding
(let ((zero (make-bytevector 8 0)))
(lambda (n p)
@@ -159,9 +177,23 @@
(write-int (length l) p)
(for-each (cut write-string <> p) l))
+(define (read-string-list p)
+ (let ((len (read-int p)))
+ (unfold (cut >= <> len)
+ (lambda (i)
+ (read-string p))
+ 1+
+ 0)))
+
+(define (write-store-path f p)
+ (write-string f p)) ; TODO: assert path
+
(define (read-store-path p)
(read-string p)) ; TODO: assert path
+(define write-store-path-list write-string-list)
+(define read-store-path-list read-string-list)
+
(define (write-contents file p)
"Write the contents of FILE to output port P."
(define (dump in size)
@@ -223,7 +255,8 @@
(write-string ")" p))))
(define-syntax write-arg
- (syntax-rules (integer boolean file string string-list base16)
+ (syntax-rules (integer boolean file string string-list
+ store-path store-path-list base16)
((_ integer arg p)
(write-int arg p))
((_ boolean arg p)
@@ -234,11 +267,15 @@
(write-string arg p))
((_ string-list arg p)
(write-string-list arg p))
+ ((_ store-path arg p)
+ (write-store-path arg p))
+ ((_ store-path-list arg p)
+ (write-store-path-list arg p))
((_ base16 arg p)
(write-string (bytevector->base16-string arg) p))))
(define-syntax read-arg
- (syntax-rules (integer boolean string store-path base16)
+ (syntax-rules (integer boolean string store-path store-path-list base16)
((_ integer p)
(read-int p))
((_ boolean p)
@@ -247,6 +284,8 @@
(read-string p))
((_ store-path p)
(read-store-path p))
+ ((_ store-path-list p)
+ (read-store-path-list p))
((_ hash p)
(base16-string->bytevector (read-string p)))))
@@ -385,7 +424,7 @@ again until #t is returned or an error is raised."
(define-syntax define-operation
(syntax-rules ()
- ((_ (name (type arg) ...) docstring return)
+ ((_ (name (type arg) ...) docstring return ...)
(define (name server arg ...)
docstring
(let ((s (nix-server-socket server)))
@@ -395,7 +434,7 @@ again until #t is returned or an error is raised."
;; Loop until the server is done sending error output.
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
- (read-arg return s))))))
+ (values (read-arg return s) ...))))))
(define-operation (valid-path? (string path))
"Return #t when PATH is a valid store path."
@@ -436,6 +475,61 @@ name--it is the caller's responsibility to ensure that it is an absolute
file name. Return #t on success."
boolean)
+(define (run-gc server action to-delete min-freed)
+ "Perform the garbage-collector operation ACTION, one of the
+`gc-action' values. When ACTION is `delete-specific', the TO-DELETE is
+the list of store paths to delete. IGNORE-LIVENESS? should always be
+#f. MIN-FREED is the minimum amount of disk space to be freed, in
+bytes, before the GC can stop. Return the list of store paths delete,
+and the number of bytes freed."
+ (let ((s (nix-server-socket server)))
+ (write-int (operation-id collect-garbage) s)
+ (write-int action s)
+ (write-store-path-list to-delete s)
+ (write-arg boolean #f s) ; ignore-liveness?
+ (write-long-long min-freed s)
+ (write-int 0 s) ; obsolete
+ (when (>= (nix-server-minor-version server) 5)
+ ;; Obsolete `use-atime' and `max-atime' parameters.
+ (write-int 0 s)
+ (write-int 0 s))
+
+ ;; Loop until the server is done sending error output.
+ (let loop ((done? (process-stderr server)))
+ (or done? (loop (process-stderr server))))
+
+ (let ((paths (read-store-path-list s))
+ (freed (read-long-long s))
+ (obsolete (read-long-long s)))
+ (values paths freed))))
+
+(define-syntax-rule (%long-long-max)
+ ;; Maximum unsigned 64-bit integer.
+ (- (expt 2 64) 1))
+
+(define (live-paths server)
+ "Return the list of live store paths---i.e., store paths still
+referenced, and thus not subject to being garbage-collected."
+ (run-gc server (gc-action return-live) '() (%long-long-max)))
+
+(define (dead-paths server)
+ "Return the list of dead store paths---i.e., store paths no longer
+referenced, and thus subject to being garbage-collected."
+ (run-gc server (gc-action return-dead) '() (%long-long-max)))
+
+(define* (collect-garbage server #:optional (min-freed (%long-long-max)))
+ "Collect garbage from the store at SERVER. If MIN-FREED is non-zero,
+then collect at least MIN-FREED bytes. Return the paths that were
+collected, and the number of bytes freed."
+ (run-gc server (gc-action delete-dead) '() min-freed))
+
+(define* (delete-paths server paths #:optional (min-freed (%long-long-max)))
+ "Delete PATHS from the store at SERVER, if they are no longer
+referenced. If MIN-FREED is non-zero, then stop after at least
+MIN-FREED bytes have been collected. Return the paths that were
+collected, and the number of bytes freed."
+ (run-gc server (gc-action delete-specific) paths min-freed))
+
;;;
;;; Store paths.
diff --git a/tests/store.scm b/tests/store.scm
new file mode 100644
index 0000000000..71f68a1f23
--- /dev/null
+++ b/tests/store.scm
@@ -0,0 +1,87 @@
+;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
+
+
+(define-module (test-store)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix base32)
+ #:use-module (distro packages bootstrap)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-64))
+
+;; Test the (guix store) module.
+
+(define %store
+ (false-if-exception (open-connection)))
+
+(when %store
+ ;; Make sure we build everything by ourselves.
+ (set-build-options %store #:use-substitutes? #f))
+
+(define %seed
+ (seed->random-state (logxor (getpid) (car (gettimeofday)))))
+
+(define (random-text)
+ (number->string (random (expt 2 256) %seed) 16))
+
+
+(test-begin "store")
+
+(test-skip (if %store 0 10))
+
+(test-assert "dead-paths"
+ (let ((p (add-text-to-store %store "random-text"
+ (random-text) '())))
+ (member p (dead-paths %store))))
+
+;; FIXME: Find a test for `live-paths'.
+;;
+;; (test-assert "temporary root is in live-paths"
+;; (let* ((p1 (add-text-to-store %store "random-text"
+;; (random-text) '()))
+;; (b (add-text-to-store %store "link-builder"
+;; (format #f "echo ~a > $out" p1)
+;; '()))
+;; (d1 (derivation %store "link" (%current-system)
+;; "/bin/sh" `("-e" ,b) '()
+;; `((,b) (,p1))))
+;; (p2 (derivation-path->output-path d1)))
+;; (and (add-temp-root %store p2)
+;; (build-derivations %store (list d1))
+;; (valid-path? %store p1)
+;; (member (pk p2) (live-paths %store)))))
+
+(test-assert "dead path can be explicitly collected"
+ (let ((p (add-text-to-store %store "random-text"
+ (random-text) '())))
+ (let-values (((paths freed) (delete-paths %store (list p))))
+ (and (equal? paths (list p))
+ (> freed 0)
+ (not (file-exists? p))))))
+
+(test-end "store")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;;; Local Variables:
+;;; eval: (put 'test-assert 'scheme-indent-function 1)
+;;; End: