summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-12-09 23:54:37 +0100
committerLudovic Courtès <ludo@gnu.org>2012-12-09 23:54:37 +0100
commit4d152bf1d9ff894119e913e6506632348107cf65 (patch)
treec44f06f725e3a398bd7698dd2b58480d356021b8
parent4ce823c4241ff941ca301c39db23ab91eeaa1ac9 (diff)
parent3259877d3563ac022633fbd8b73134a10567331e (diff)
downloadpatches-4d152bf1d9ff894119e913e6506632348107cf65.tar
patches-4d152bf1d9ff894119e913e6506632348107cf65.tar.gz
Merge branch 'master' into nix-integration
Conflicts: guix/store.scm
-rw-r--r--AUTHORS12
-rw-r--r--Makefile.am5
-rw-r--r--THANKS6
-rw-r--r--TODO1
-rw-r--r--distro/packages/acl.scm61
-rw-r--r--distro/packages/attr.scm68
-rw-r--r--doc/guix.texi2
-rw-r--r--guix/download.scm2
-rw-r--r--guix/gnu-maintenance.scm57
-rw-r--r--guix/licenses.scm171
-rw-r--r--guix/store.scm106
-rw-r--r--tests/store.scm87
12 files changed, 570 insertions, 8 deletions
diff --git a/AUTHORS b/AUTHORS
index cbf594f492..1d0ebf75b0 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -1 +1,11 @@
-Ludovic Courtès <ludo@gnu.org>
+GNU Guix is consists of Scheme code that implements the deployment model
+of the Nix package management tool. In fact, it currently talks to a
+build daemon whose code comes from Nix (see the manual for details.)
+
+Nix was initially written by Eelco Dolstra; other people have been
+contributing to it. See `nix/AUTHORS' for details.
+
+GNU Guix was initiated by Ludovic Courtès <ludo@gnu.org>, but it would
+not be what it is without the contributions of the following people:
+
+ Nikita Karetnikov <nikita@karetnikov.org>
diff --git a/Makefile.am b/Makefile.am
index 49e0c3016a..0b59f8901c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -27,6 +27,8 @@ MODULES = \
guix/utils.scm \
guix/derivations.scm \
guix/download.scm \
+ guix/gnu-maintenance.scm \
+ guix/licenses.scm \
guix/build-system.scm \
guix/build-system/gnu.scm \
guix/build-system/trivial.scm \
@@ -41,6 +43,8 @@ MODULES = \
guix/snix.scm \
guix.scm \
distro.scm \
+ distro/packages/acl.scm \
+ distro/packages/attr.scm \
distro/packages/autotools.scm \
distro/packages/base.scm \
distro/packages/bash.scm \
@@ -172,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/THANKS b/THANKS
index 588e2d5a88..d0ffe9edc4 100644
--- a/THANKS
+++ b/THANKS
@@ -1,3 +1,9 @@
A big thanks to Eelco Dolstra, who designed and implemented Nix.
Transposing functional programming discipline to package management
proved to be inspiring and fruitful.
+
+Thanks to the following people who contributed to GNU Guix through
+suggestions, bug reports, patches, or general infrastructure help:
+
+ Andreas Enge <andreas@enge.fr>
+ Jason Self <jself@gnu.org>
diff --git a/TODO b/TODO
index f0088a5ae2..1579504ea5 100644
--- a/TODO
+++ b/TODO
@@ -104,7 +104,6 @@ etc.
** add ‘--roll-back’
** add ‘--list-generations’, and ‘--delete-generations’
** add ‘--upgrade’
-** add ‘--list-installed’ and ‘--list-available’
** add ‘--search’
* guix build utils
diff --git a/distro/packages/acl.scm b/distro/packages/acl.scm
new file mode 100644
index 0000000000..a119b5bf52
--- /dev/null
+++ b/distro/packages/acl.scm
@@ -0,0 +1,61 @@
+;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Nikita Karetnikov <nikita@karetnikov.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 (distro packages acl)
+ #:use-module (distro packages attr)
+ #:use-module (distro packages perl)
+ #:use-module ((distro packages gettext)
+ #:renamer (symbol-prefix-proc 'guix:))
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (guix build-system gnu))
+
+(define-public acl
+ (package
+ (name "acl")
+ (version "2.2.51")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://savannah/acl/acl-"
+ version ".src.tar.gz"))
+ (sha256
+ (base32
+ "09aj30m49ivycl3irram8c3givc0crivjm3ymw0nhfaxrwhlb186"))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:phases
+ (alist-replace 'check
+ (lambda _
+ (patch-shebang "test/run")
+ (system* "make" "tests" "-C" "test")
+
+ ;; XXX: Ignore the test result since this is
+ ;; dependent on the underlying file system.
+ #t)
+ %standard-phases)))
+ (inputs `(("attr" ,attr)
+ ("gettext" ,guix:gettext)
+ ("perl" ,perl)))
+ (home-page
+ "http://savannah.nongnu.org/projects/acl")
+ (synopsis
+ "Library and tools for manipulating access control lists")
+ (description
+ "Library and tools for manipulating access control lists.")
+ (license '("GPLv2+" "LGPLv2.1+"))))
diff --git a/distro/packages/attr.scm b/distro/packages/attr.scm
new file mode 100644
index 0000000000..03d3a17a8e
--- /dev/null
+++ b/distro/packages/attr.scm
@@ -0,0 +1,68 @@
+;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Nikita Karetnikov <nikita@karetnikov.org>
+;;; 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 (distro packages attr)
+ #:use-module (distro packages perl)
+ #:use-module ((distro packages gettext)
+ #:renamer (symbol-prefix-proc 'guix:))
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (guix build-system gnu))
+
+(define-public attr
+ (package
+ (name "attr")
+ (version "2.4.46")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://savannah/attr/attr-"
+ version ".src.tar.gz"))
+ (sha256
+ (base32
+ "07qf6kb2zk512az481bbnsk9jycn477xpva1a726n5pzlzf9pmnw"))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:phases
+ (alist-replace 'install
+ (lambda _
+ (zero? (system* "make"
+ "install"
+ "install-lib"
+ "install-dev")))
+ (alist-replace 'check
+ (lambda _
+ (for-each patch-shebang
+ (find-files "test" ".*"))
+ (system* "make" "tests" "-C" "test")
+
+ ;; XXX: Ignore the test result since
+ ;; this is dependent on the underlying
+ ;; file system.
+ #t)
+ %standard-phases))))
+ (inputs `(("perl" ,perl)
+ ("gettext" ,guix:gettext)))
+ (home-page
+ "http://savannah.nongnu.org/projects/attr/")
+ (synopsis
+ "Library and tools for manipulating extended attributes")
+ (description
+ "Portable library and tools for manipulating extended attributes.")
+ (license '("GPLv2+" "LGPLv2.1+"))))
diff --git a/doc/guix.texi b/doc/guix.texi
index bab5cf7a8f..b01aa961c1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -210,7 +210,7 @@ want to roll back.
@table @code
@item --install=@var{package}
-@itemx -x @var{package}
+@itemx -i @var{package}
Install @var{package}.
@var{package} may specify either a simple package name, such as
diff --git a/guix/download.scm b/guix/download.scm
index 146b64d997..b21f6f5533 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -65,7 +65,7 @@
"ftp://mirror.cict.fr/gnupg/"
"ftp://ftp.strasbourg.linuxfr.org/pub/gnupg/")
(savannah
- "http://download.savannah.gnu.org/"
+ "http://download.savannah.gnu.org/releases/"
"ftp://ftp.twaren.net/Unix/NonGNU/"
"ftp://mirror.csclub.uwaterloo.ca/nongnu/"
"ftp://mirror.publicns.net/pub/nongnu/"
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
new file mode 100644
index 0000000000..2035e44fdb
--- /dev/null
+++ b/guix/gnu-maintenance.scm
@@ -0,0 +1,57 @@
+;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Nikita Karetnikov <nikita@karetnikov.org>
+;;; 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 (guix gnu-maintenance)
+ #:use-module (web uri)
+ #:use-module (web client)
+ #:use-module (web response)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (official-gnu-packages))
+
+(define (http-fetch uri)
+ "Return a string containing the textual data at URI, a string."
+ (let*-values (((resp data)
+ (http-get (string->uri uri)))
+ ((code)
+ (response-code resp)))
+ (case code
+ ((200)
+ data)
+ (else
+ (error "download failed:" uri code
+ (response-reason-phrase resp))))))
+
+(define %package-list-url
+ (string-append "http://cvs.savannah.gnu.org/"
+ "viewvc/*checkout*/gnumaint/"
+ "gnupackages.txt?root=womb"))
+
+(define (official-gnu-packages)
+ "Return a list of GNU packages."
+ (define %package-line-rx
+ (make-regexp "^package: (.+)$"))
+
+ (let ((lst (string-split (http-fetch %package-list-url) #\nl)))
+ (filter-map (lambda (line)
+ (and=> (regexp-exec %package-line-rx line)
+ (cut match:substring <> 1)))
+ lst)))
diff --git a/guix/licenses.scm b/guix/licenses.scm
new file mode 100644
index 0000000000..9c1b7249e1
--- /dev/null
+++ b/guix/licenses.scm
@@ -0,0 +1,171 @@
+;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright (C) 2012 Nikita Karetnikov <nikita@karetnikov.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 (guix licenses)
+ #:use-module (srfi srfi-9)
+ #:export (license? license-name license-uri license-comment
+ asl2.0
+ boost1.0
+ bsd-2 bsd-3 bsd-4
+ cddl1.0
+ cpl1.0
+ epl1.0
+ gpl2 gpl2+ gpl3 gpl3+
+ ijg
+ ibmpl1.0
+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+
+ mpl2.0
+ openssl
+ public-domain
+ x11
+ zlib))
+
+(define-record-type <license>
+ (license name uri comment)
+ license?
+ (name license-name)
+ (uri license-uri)
+ (comment license-comment))
+
+;;; Commentary:
+;;;
+;;; Available licenses.
+;;;
+;;; This list is based on these links:
+;;; https://github.com/NixOS/nixpkgs/blob/master/pkgs/lib/licenses.nix
+;;; https://www.gnu.org/licenses/license-list
+;;;
+;;; Code:
+
+(define asl2.0
+ (license "ASL 2.0"
+ "http://directory.fsf.org/wiki/License:Apache2.0"
+ "https://www.gnu.org/licenses/license-list#apache2"))
+
+(define boost1.0
+ (license "Boost 1.0"
+ "http://directory.fsf.org/wiki/License:Boost1.0"
+ "https://www.gnu.org/licenses/license-list#boost"))
+
+(define bsd-2
+ (license "FreeBSD"
+ "http://directory.fsf.org/wiki/License:FreeBSD"
+ "https://www.gnu.org/licenses/license-list#FreeBSD"))
+
+(define bsd-3
+ (license "Modified BSD"
+ "http://directory.fsf.org/wiki/License:BSD_3Clause"
+ "https://www.gnu.org/licenses/license-list#ModifiedBSD"))
+
+(define bsd-4
+ (license "Original BSD"
+ "http://directory.fsf.org/wiki/License:BSD_4Clause"
+ "https://www.gnu.org/licenses/license-list#OriginalBSD"))
+
+(define cddl1.0
+ (license "CDDL 1.0"
+ "http://directory.fsf.org/wiki/License:CDDLv1.0"
+ "https://www.gnu.org/licenses/license-list#CDDL"))
+
+(define cpl1.0
+ (license "CPL 1.0"
+ "http://directory.fsf.org/wiki/License:CPLv1.0"
+ "https://www.gnu.org/licenses/license-list#CommonPublicLicense10"))
+
+(define epl1.0
+ (license "EPL 1.0"
+ "http://directory.fsf.org/wiki/License:EPLv1.0"
+ "https://www.gnu.org/licenses/license-list#EPL"))
+
+(define gpl2
+ (license "GPL 2"
+ "https://www.gnu.org/licenses/old-licenses/gpl-2.0.html"
+ "https://www.gnu.org/licenses/license-list#GPLv2"))
+
+(define gpl2+
+ (license "GPL 2+"
+ "https://www.gnu.org/licenses/old-licenses/gpl-2.0.html"
+ "https://www.gnu.org/licenses/license-list#GPLv2"))
+
+(define gpl3
+ (license "GPL 3"
+ "https://www.gnu.org/licenses/gpl.html"
+ "https://www.gnu.org/licenses/license-list#GNUGPLv3"))
+
+(define gpl3+
+ (license "GPL 3+"
+ "https://www.gnu.org/licenses/gpl.html"
+ "https://www.gnu.org/licenses/license-list#GNUGPLv3"))
+
+(define ijg
+ (license "IJG"
+ "http://directory.fsf.org/wiki/License:JPEG"
+ "https://www.gnu.org/licenses/license-list#ijg"))
+
+(define ibmpl1.0
+ (license "IBMPL 1.0"
+ "http://directory.fsf.org/wiki/License:IBMPLv1.0"
+ "https://www.gnu.org/licenses/license-list#IBMPL"))
+
+(define lgpl2.1
+ (license "LGPL 2.1"
+ "https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html"
+ "https://www.gnu.org/licenses/license-list#LGPLv2.1"))
+
+(define lgpl2.1+
+ (license "LGPL 2.1+"
+ "https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html"
+ "https://www.gnu.org/licenses/license-list#LGPLv2.1"))
+
+(define lgpl3
+ (license "LGPL 3"
+ "https://www.gnu.org/licenses/lgpl.html"
+ "https://www.gnu.org/licenses/license-list#LGPLv3"))
+
+(define lgpl3+
+ (license "LGPL 3+"
+ "https://www.gnu.org/licenses/lgpl.html"
+ "https://www.gnu.org/licenses/license-list#LGPLv3"))
+
+(define mpl2.0
+ (license "MPL 2.0"
+ "http://directory.fsf.org/wiki/License:MPLv2.0"
+ "https://www.gnu.org/licenses/license-list#MPL-2.0"))
+
+(define openssl
+ (license "OpenSSL"
+ "http://directory.fsf.org/wiki/License:OpenSSL"
+ "https://www.gnu.org/licenses/license-list#OpenSSL"))
+
+(define public-domain
+ (license "Public Domain"
+ "http://directory.fsf.org/wiki/License:PublicDomain"
+ "https://www.gnu.org/licenses/license-list#PublicDomain"))
+
+(define x11
+ (license "X11"
+ "http://directory.fsf.org/wiki/License:X11"
+ "https://www.gnu.org/licenses/license-list#X11License"))
+
+(define zlib
+ (license "Zlib"
+ "http://www.gzip.org/zlib/zlib_license.html"
+ "https://www.gnu.org/licenses/license-list#ZLib"))
+
+;;; licenses.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index 3bfb03e6b5..a8dd566355 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -51,8 +51,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
@@ -112,6 +118,13 @@
(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 %default-socket-path
(string-append (or (getenv "NIX_STATE_DIR") %state-directory)
"/daemon-socket/socket"))
@@ -133,6 +146,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 +176,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 +254,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 +266,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 +283,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 +423,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 +433,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."
@@ -424,6 +462,11 @@ FIXED? is for backward compatibility with old Nix versions and must be #t."
Return #t on success."
boolean)
+(define-operation (add-temp-root (store-path path))
+ "Make PATH a temporary root for the duration of the current session.
+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
@@ -431,6 +474,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: