TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2012-12-09 23:52:59 +01:00
parent d3648e0118
commit 3259877d35
3 changed files with 186 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

102
guix/store.scm
View File

@ -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.

87
tests/store.scm Normal file
View File

@ -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: