diff options
| -rw-r--r-- | AUTHORS | 12 | ||||
| -rw-r--r-- | Makefile.am | 5 | ||||
| -rw-r--r-- | THANKS | 6 | ||||
| -rw-r--r-- | TODO | 1 | ||||
| -rw-r--r-- | distro/packages/acl.scm | 61 | ||||
| -rw-r--r-- | distro/packages/attr.scm | 68 | ||||
| -rw-r--r-- | doc/guix.texi | 2 | ||||
| -rw-r--r-- | guix/download.scm | 2 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 57 | ||||
| -rw-r--r-- | guix/licenses.scm | 171 | ||||
| -rw-r--r-- | guix/store.scm | 106 | ||||
| -rw-r--r-- | tests/store.scm | 87 |
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: |