Merge branch 'master' into nix-integration
Conflicts: guix/store.scm
This commit is contained in:
Ludovic Courtès
commit
4d152bf1d9
12
AUTHORS
12
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>
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
6
THANKS
6
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>
|
||||
|
|
|
|||
1
TODO
1
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
|
||||
|
|
|
|||
|
|
@ -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+"))))
|
||||
|
|
@ -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+"))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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/"
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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
|
||||
106
guix/store.scm
106
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.
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
Loading…
Reference in New Issue